Line data Source code
1 : !-------------------------------------------------------------------------------
2 : !physics data types module
3 : !-------------------------------------------------------------------------------
4 : module physics_types
5 :
6 : use shr_kind_mod, only: r8 => shr_kind_r8
7 : use ppgrid, only: pcols, pver
8 : use constituents, only: pcnst, qmin, cnst_name, cnst_get_ind
9 : use geopotential, only: geopotential_t
10 : use physconst, only: zvir, gravit, cpair, rair
11 : use air_composition, only: cpairv, rairv
12 : use phys_grid, only: get_ncols_p, get_rlon_all_p, get_rlat_all_p, get_gcol_all_p
13 : use cam_logfile, only: iulog
14 : use cam_abortutils, only: endrun
15 : use phys_control, only: waccmx_is
16 : use shr_const_mod, only: shr_const_rwv
17 :
18 : implicit none
19 : private ! Make default type private to the module
20 :
21 : ! Public types:
22 :
23 : public physics_state
24 : public physics_tend
25 : public physics_ptend
26 :
27 : ! Public interfaces
28 :
29 : public physics_update
30 : public physics_state_check ! Check state object for invalid data.
31 : public physics_ptend_reset
32 : public physics_ptend_init
33 : public physics_state_set_grid
34 : public physics_dme_adjust ! adjust dry mass and energy for change in water
35 : ! cannot be applied to eul or sld dycores
36 : public physics_state_copy ! copy a physics_state object
37 : public physics_ptend_copy ! copy a physics_ptend object
38 : public physics_ptend_sum ! accumulate physics_ptend objects
39 : public physics_ptend_scale ! Multiply physics_ptend objects by a constant factor.
40 : public physics_tend_init ! initialize a physics_tend object
41 :
42 : public set_state_pdry ! calculate dry air masses in state variable
43 : public set_wet_to_dry
44 : public set_dry_to_wet
45 : public physics_type_alloc
46 :
47 : public physics_state_alloc ! allocate individual components within state
48 : public physics_state_dealloc ! deallocate individual components within state
49 : public physics_tend_alloc ! allocate individual components within tend
50 : public physics_tend_dealloc ! deallocate individual components within tend
51 : public physics_ptend_alloc ! allocate individual components within tend
52 : public physics_ptend_dealloc ! deallocate individual components within tend
53 :
54 : public physics_cnst_limit ! apply limiters to constituents (waccmx)
55 : !-------------------------------------------------------------------------------
56 : integer, parameter, public :: phys_te_idx = 1
57 : integer ,parameter, public :: dyn_te_idx = 2
58 :
59 : type physics_state
60 : integer :: &
61 : lchnk, &! chunk index
62 : ngrdcol, &! -- Grid -- number of active columns (on the grid)
63 : psetcols=0, &! -- -- max number of columns set - if subcols = pcols*psubcols, else = pcols
64 : ncol=0 ! -- -- sum of nsubcol for all ngrdcols - number of active columns
65 : real(r8), dimension(:), allocatable :: &
66 : lat, &! latitude (radians)
67 : lon, &! longitude (radians)
68 : ps, &! surface pressure
69 : psdry, &! dry surface pressure
70 : phis, &! surface geopotential
71 : ulat, &! unique latitudes (radians)
72 : ulon ! unique longitudes (radians)
73 : real(r8), dimension(:,:),allocatable :: &
74 : t, &! temperature (K)
75 : u, &! zonal wind (m/s)
76 : v, &! meridional wind (m/s)
77 : s, &! dry static energy
78 : omega, &! vertical pressure velocity (Pa/s)
79 : pmid, &! midpoint pressure (Pa)
80 : pmiddry, &! midpoint pressure dry (Pa)
81 : pdel, &! layer thickness (Pa)
82 : pdeldry, &! layer thickness dry (Pa)
83 : rpdel, &! reciprocal of layer thickness (Pa)
84 : rpdeldry,&! recipricol layer thickness dry (Pa)
85 : lnpmid, &! ln(pmid)
86 : lnpmiddry,&! log midpoint pressure dry (Pa)
87 : exner, &! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp)
88 : zm ! geopotential height above surface at midpoints (m)
89 :
90 : real(r8), dimension(:,:,:),allocatable :: &
91 : q ! constituent mixing ratio (kg/kg moist or dry air depending on type)
92 :
93 : real(r8), dimension(:,:),allocatable :: &
94 : pint, &! interface pressure (Pa)
95 : pintdry, &! interface pressure dry (Pa)
96 : lnpint, &! ln(pint)
97 : lnpintdry,&! log interface pressure dry (Pa)
98 : zi ! geopotential height above surface at interfaces (m)
99 :
100 : real(r8), dimension(:,:),allocatable :: &
101 : ! Second dimension is (phys_te_idx) CAM physics total energy and
102 : ! (dyn_te_idx) dycore total energy computed in physics
103 : te_ini, &! vertically integrated total (kinetic + static) energy of initial state
104 : te_cur, &! vertically integrated total (kinetic + static) energy of current state
105 : tw_ini, &! vertically integrated total water of initial state
106 : tw_cur ! vertically integrated total water of new state
107 : real(r8), dimension(:,:),allocatable :: &
108 : temp_ini, &! Temperature of initial state (used for energy computations)
109 : z_ini ! Height of initial state (used for energy computations)
110 : integer :: count ! count of values with significant energy or water imbalances
111 : integer, dimension(:),allocatable :: &
112 : latmapback, &! map from column to unique lat for that column
113 : lonmapback, &! map from column to unique lon for that column
114 : cid ! unique column id
115 : integer :: ulatcnt, &! number of unique lats in chunk
116 : uloncnt ! number of unique lons in chunk
117 :
118 : end type physics_state
119 :
120 : !-------------------------------------------------------------------------------
121 : type physics_tend
122 :
123 : integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols
124 :
125 : real(r8), dimension(:,:),allocatable :: dtdt, dudt, dvdt
126 : real(r8), dimension(:), allocatable :: flx_net
127 : real(r8), dimension(:), allocatable :: &
128 : te_tnd, &! cumulative boundary flux of total energy
129 : tw_tnd ! cumulative boundary flux of total water
130 : end type physics_tend
131 :
132 : !-------------------------------------------------------------------------------
133 : ! This is for tendencies returned from individual parameterizations
134 : type physics_ptend
135 :
136 : integer :: psetcols=0 ! max number of columns set- if subcols = pcols*psubcols, else = pcols
137 :
138 : character*24 :: name ! name of parameterization which produced tendencies.
139 :
140 : logical :: &
141 : ls = .false., &! true if dsdt is returned
142 : lu = .false., &! true if dudt is returned
143 : lv = .false. ! true if dvdt is returned
144 :
145 : logical,dimension(pcnst) :: lq = .false. ! true if dqdt() is returned
146 :
147 : integer :: &
148 : top_level, &! top level index for which nonzero tendencies have been set
149 : bot_level ! bottom level index for which nonzero tendencies have been set
150 :
151 : real(r8), dimension(:,:),allocatable :: &
152 : s, &! heating rate (J/kg/s)
153 : u, &! u momentum tendency (m/s/s)
154 : v ! v momentum tendency (m/s/s)
155 : real(r8), dimension(:,:,:),allocatable :: &
156 : q ! consituent tendencies (kg/kg/s)
157 :
158 : ! boundary fluxes
159 : real(r8), dimension(:),allocatable ::&
160 : hflux_srf, &! net heat flux at surface (W/m2)
161 : hflux_top, &! net heat flux at top of model (W/m2)
162 : taux_srf, &! net zonal stress at surface (Pa)
163 : taux_top, &! net zonal stress at top of model (Pa)
164 : tauy_srf, &! net meridional stress at surface (Pa)
165 : tauy_top ! net meridional stress at top of model (Pa)
166 : real(r8), dimension(:,:),allocatable ::&
167 : cflx_srf, &! constituent flux at surface (kg/m2/s)
168 : cflx_top ! constituent flux top of model (kg/m2/s)
169 :
170 : end type physics_ptend
171 :
172 :
173 : !===============================================================================
174 : contains
175 : !===============================================================================
176 1536 : subroutine physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, psetcols)
177 : implicit none
178 : type(physics_state), pointer :: phys_state(:)
179 : type(physics_tend), pointer :: phys_tend(:)
180 : integer, intent(in) :: begchunk, endchunk
181 : integer, intent(in) :: psetcols
182 :
183 : integer :: ierr=0, lchnk
184 :
185 10800 : allocate(phys_state(begchunk:endchunk), stat=ierr)
186 1536 : if( ierr /= 0 ) then
187 0 : write(iulog,*) 'physics_types: phys_state allocation error = ',ierr
188 0 : call endrun('physics_types: failed to allocate physics_state array')
189 : end if
190 :
191 7728 : do lchnk=begchunk,endchunk
192 7728 : call physics_state_alloc(phys_state(lchnk),lchnk,pcols)
193 : end do
194 :
195 10800 : allocate(phys_tend(begchunk:endchunk), stat=ierr)
196 1536 : if( ierr /= 0 ) then
197 0 : write(iulog,*) 'physics_types: phys_tend allocation error = ',ierr
198 0 : call endrun('physics_types: failed to allocate physics_tend array')
199 : end if
200 :
201 7728 : do lchnk=begchunk,endchunk
202 7728 : call physics_tend_alloc(phys_tend(lchnk),phys_state(lchnk)%psetcols)
203 : end do
204 :
205 1536 : end subroutine physics_type_alloc
206 : !===============================================================================
207 2566584 : subroutine physics_update(state, ptend, dt, tend)
208 : !-----------------------------------------------------------------------
209 : ! Update the state and or tendency structure with the parameterization tendencies
210 : !-----------------------------------------------------------------------
211 : use scamMod, only: scm_crm_mode, single_column
212 : use phys_control, only: phys_getopts
213 : use cam_thermo, only: cam_thermo_dry_air_update ! Routine which updates physconst variables (WACCM-X)
214 : use air_composition, only: dry_air_species_num
215 : use qneg_module , only: qneg3
216 :
217 : !------------------------------Arguments--------------------------------
218 : type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies
219 :
220 : type(physics_state), intent(inout) :: state ! Physics state variables
221 :
222 : real(r8), intent(in) :: dt ! time step
223 :
224 : type(physics_tend ), intent(inout), optional :: tend ! Physics tendencies over timestep
225 : ! tend is usually only needed by calls from physpkg.
226 : !
227 : !---------------------------Local storage-------------------------------
228 : integer :: k,m ! column,level,constituent indices
229 : integer :: ixcldice, ixcldliq ! indices for CLDICE and CLDLIQ
230 : integer :: ixnumice, ixnumliq
231 : integer :: ixnumsnow, ixnumrain
232 : integer :: ncol ! number of columns
233 : integer :: ixh, ixh2 ! constituent indices for H, H2
234 :
235 5133168 : real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer
236 :
237 2566584 : real(r8),allocatable :: cpairv_loc(:,:)
238 2566584 : real(r8),allocatable :: rairv_loc(:,:)
239 :
240 : ! PERGRO limits cldliq/ice for macro/microphysics:
241 : character(len=24), parameter :: pergro_cldlim_names(4) = &
242 : (/ "stratiform", "cldwat ", "micro_mg ", "macro_park" /)
243 :
244 : ! cldliq/ice limits that are always on.
245 : character(len=24), parameter :: cldlim_names(2) = &
246 : (/ "convect_deep", "zm_conv_tend" /)
247 :
248 : ! Whether to do validation of state on each call.
249 : logical :: state_debug_checks
250 :
251 : !-----------------------------------------------------------------------
252 :
253 : ! The column radiation model does not update the state
254 2566584 : if(single_column.and.scm_crm_mode) return
255 :
256 :
257 : !-----------------------------------------------------------------------
258 : ! If no fields are set, then return
259 34956936 : if (.not. (any(ptend%lq(:)) .or. ptend%ls .or. ptend%lu .or. ptend%lv)) then
260 352944 : ptend%name = "none"
261 352944 : ptend%psetcols = 0
262 352944 : return
263 : end if
264 :
265 : !-----------------------------------------------------------------------
266 : ! Check that the state/tend/ptend are all dimensioned with the same number of columns
267 2213640 : if (state%psetcols /= ptend%psetcols) then
268 : call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) &
269 0 : //': state and ptend must have the same number of psetcols.')
270 : end if
271 :
272 2213640 : if (present(tend)) then
273 1136232 : if (state%psetcols /= tend%psetcols) then
274 : call endrun('ERROR in physics_update with ptend%name='//trim(ptend%name) &
275 0 : //': state and tend must have the same number of psetcols.')
276 : end if
277 : end if
278 :
279 :
280 : !-----------------------------------------------------------------------
281 2213640 : call phys_getopts(state_debug_checks_out=state_debug_checks)
282 :
283 2213640 : ncol = state%ncol
284 :
285 : ! Update u,v fields
286 2213640 : if(ptend%lu) then
287 61988112 : do k = ptend%top_level, ptend%bot_level
288 1024046064 : state%u (:ncol,k) = state%u (:ncol,k) + ptend%u(:ncol,k) * dt
289 61328664 : if (present(tend)) &
290 649702728 : tend%dudt(:ncol,k) = tend%dudt(:ncol,k) + ptend%u(:ncol,k)
291 : end do
292 : end if
293 :
294 2213640 : if(ptend%lv) then
295 61988112 : do k = ptend%top_level, ptend%bot_level
296 1024046064 : state%v (:ncol,k) = state%v (:ncol,k) + ptend%v(:ncol,k) * dt
297 61328664 : if (present(tend)) &
298 649702728 : tend%dvdt(:ncol,k) = tend%dvdt(:ncol,k) + ptend%v(:ncol,k)
299 : end do
300 : end if
301 :
302 : ! Update constituents, all schemes use time split q: no tendency kept
303 2213640 : call cnst_get_ind('CLDICE', ixcldice, abort=.false.)
304 2213640 : call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.)
305 : ! Check for number concentration of cloud liquid and cloud ice (if not present
306 : ! the indices will be set to -1)
307 2213640 : call cnst_get_ind('NUMICE', ixnumice, abort=.false.)
308 2213640 : call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.)
309 2213640 : call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.)
310 2213640 : call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.)
311 :
312 92972880 : do m = 1, pcnst
313 92972880 : if(ptend%lq(m)) then
314 3027231648 : do k = ptend%top_level, ptend%bot_level
315 50042191248 : state%q(:ncol,k,m) = state%q(:ncol,k,m) + ptend%q(:ncol,k,m) * dt
316 : end do
317 :
318 : ! now test for mixing ratios which are too small
319 : ! don't call qneg3 for number concentration variables
320 : if (m /= ixnumice .and. m /= ixnumliq .and. &
321 32204592 : m /= ixnumrain .and. m /= ixnumsnow ) then
322 28179792 : call qneg3(trim(ptend%name), state%lchnk, ncol, state%psetcols, pver, m, m, qmin(m:m), state%q(:,1:pver,m:m))
323 : else
324 378331200 : do k = ptend%top_level, ptend%bot_level
325 : ! checks for number concentration
326 6250046400 : state%q(:ncol,k,m) = max(1.e-12_r8,state%q(:ncol,k,m))
327 6254071200 : state%q(:ncol,k,m) = min(1.e10_r8,state%q(:ncol,k,m))
328 : end do
329 : end if
330 :
331 : end if
332 :
333 : end do
334 :
335 : !------------------------------------------------------------------------
336 : ! This is a temporary fix for the large H, H2 in WACCM-X
337 : ! Well, it was supposed to be temporary, but it has been here
338 : ! for a while now.
339 : !------------------------------------------------------------------------
340 2213640 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
341 0 : call cnst_get_ind('H', ixh)
342 0 : do k = ptend%top_level, ptend%bot_level
343 0 : state%q(:ncol,k,ixh) = min(state%q(:ncol,k,ixh), 0.01_r8)
344 : end do
345 :
346 0 : call cnst_get_ind('H2', ixh2)
347 0 : do k = ptend%top_level, ptend%bot_level
348 0 : state%q(:ncol,k,ixh2) = min(state%q(:ncol,k,ixh2), 6.e-5_r8)
349 : end do
350 : endif
351 :
352 : ! Special tests for cloud liquid and ice:
353 : ! Enforce a minimum non-zero value.
354 2213640 : if (ixcldliq > 1) then
355 2213640 : if(ptend%lq(ixcldliq)) then
356 : #ifdef PERGRO
357 : if ( any(ptend%name == pergro_cldlim_names) ) &
358 : call state_cnst_min_nz(1.e-12_r8, ixcldliq, ixnumliq)
359 : #endif
360 3306528 : if ( any(ptend%name == cldlim_names) ) &
361 65016 : call state_cnst_min_nz(1.e-36_r8, ixcldliq, ixnumliq)
362 : end if
363 : end if
364 :
365 2213640 : if (ixcldice > 1) then
366 2213640 : if(ptend%lq(ixcldice)) then
367 : #ifdef PERGRO
368 : if ( any(ptend%name == pergro_cldlim_names) ) &
369 : call state_cnst_min_nz(1.e-12_r8, ixcldice, ixnumice)
370 : #endif
371 3483000 : if ( any(ptend%name == cldlim_names) ) &
372 65016 : call state_cnst_min_nz(1.e-36_r8, ixcldice, ixnumice)
373 : end if
374 : end if
375 :
376 : !------------------------------------------------------------------------
377 : ! Get indices for molecular weights and call WACCM-X cam_thermo_update
378 : !------------------------------------------------------------------------
379 2213640 : if (dry_air_species_num>0) then
380 0 : call cam_thermo_dry_air_update(state%q, state%t, state%lchnk, state%ncol)
381 : endif
382 :
383 : !-----------------------------------------------------------------------
384 : ! cpairv_loc and rairv_loc need to be allocated to a size which matches state and ptend
385 : ! If psetcols == pcols, the cpairv is the correct size and just copy
386 : ! If psetcols > pcols and all cpairv match cpair, then assign the constant cpair
387 6640920 : allocate(cpairv_loc(state%psetcols,pver))
388 2213640 : if (state%psetcols == pcols) then
389 3501978480 : cpairv_loc(:,:) = cpairv(:,:,state%lchnk)
390 0 : else if (state%psetcols > pcols .and. all(cpairv(:,:,:) == cpair)) then
391 0 : cpairv_loc(:,:) = cpair
392 : else
393 0 : call endrun('physics_update: cpairv is not allowed to vary when subcolumns are turned on')
394 : end if
395 6640920 : allocate(rairv_loc(state%psetcols,pver))
396 2213640 : if (state%psetcols == pcols) then
397 3501978480 : rairv_loc(:,:) = rairv(:,:,state%lchnk)
398 0 : else if (state%psetcols > pcols .and. all(rairv(:,:,:) == rair)) then
399 0 : rairv_loc(:,:) = rair
400 : else
401 0 : call endrun('physics_update: rairv_loc is not allowed to vary when subcolumns are turned on')
402 : end if
403 :
404 2213640 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
405 0 : zvirv(:,:) = shr_const_rwv / rairv_loc(:,:) - 1._r8
406 : else
407 3501978480 : zvirv(:,:) = zvir
408 : endif
409 :
410 : !-------------------------------------------------------------------------------------------------------------
411 : ! Update temperature from dry static energy (moved from above for WACCM-X so updating after cpairv_loc update)
412 : !-------------------------------------------------------------------------------------------------------------
413 :
414 2213640 : if(ptend%ls) then
415 147258144 : do k = ptend%top_level, ptend%bot_level
416 2432710368 : state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k)
417 145691568 : if (present(tend)) &
418 1309268592 : tend%dtdt(:ncol,k) = tend%dtdt(:ncol,k) + ptend%s(:ncol,k)/cpairv_loc(:ncol,k)
419 : end do
420 : end if
421 :
422 : ! Derive new geopotential fields if heating or water tendency not 0.
423 :
424 2213640 : if (ptend%ls .or. ptend%lq(1)) then
425 : call geopotential_t ( &
426 : state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , &
427 : state%t , state%q(:,:,:), rairv_loc(:,:), gravit , zvirv , &
428 1625400 : state%zi , state%zm , ncol )
429 : ! update dry static energy for use in next process
430 152787600 : do k = ptend%top_level, ptend%bot_level
431 151162200 : state%s(:ncol,k) = state%t(:ncol,k)*cpairv_loc(:ncol,k) &
432 2676844800 : + gravit*state%zm(:ncol,k) + state%phis(:ncol)
433 : end do
434 : end if
435 :
436 2213640 : if (state_debug_checks) call physics_state_check(state, ptend%name)
437 :
438 2213640 : deallocate(cpairv_loc, rairv_loc)
439 :
440 : ! Deallocate ptend
441 2213640 : call physics_ptend_dealloc(ptend)
442 :
443 2213640 : ptend%name = "none"
444 92972880 : ptend%lq(:) = .false.
445 2213640 : ptend%ls = .false.
446 2213640 : ptend%lu = .false.
447 2213640 : ptend%lv = .false.
448 4780224 : ptend%psetcols = 0
449 :
450 : contains
451 :
452 130032 : subroutine state_cnst_min_nz(lim, qix, numix)
453 : ! Small utility function for setting minimum nonzero
454 : ! constituent concentrations.
455 :
456 : ! Lower limit and constituent index
457 : real(r8), intent(in) :: lim
458 : integer, intent(in) :: qix
459 : ! Number concentration that goes with qix.
460 : ! Ignored if <= 0 (and therefore constituent is not present).
461 : integer, intent(in) :: numix
462 :
463 130032 : if (numix > 0) then
464 : ! Where q is too small, zero mass and number
465 : ! concentration.
466 606163824 : where (state%q(:ncol,:,qix) < lim)
467 130032 : state%q(:ncol,:,qix) = 0._r8
468 130032 : state%q(:ncol,:,numix) = 0._r8
469 : end where
470 : else
471 : ! If no number index, just do mass.
472 0 : where (state%q(:ncol,:,qix) < lim)
473 0 : state%q(:ncol,:,qix) = 0._r8
474 : end where
475 : end if
476 :
477 2566584 : end subroutine state_cnst_min_nz
478 :
479 :
480 : end subroutine physics_update
481 :
482 : !===============================================================================
483 :
484 2402496 : subroutine physics_state_check(state, name)
485 : !-----------------------------------------------------------------------
486 : ! Check a physics_state object for invalid data (e.g NaNs, negative
487 : ! temperatures).
488 : !-----------------------------------------------------------------------
489 : use shr_infnan_mod, only: assignment(=), &
490 : shr_infnan_posinf, shr_infnan_neginf
491 : use shr_assert_mod, only: shr_assert_in_domain
492 : use constituents, only: pcnst
493 :
494 : !------------------------------Arguments--------------------------------
495 : ! State to check.
496 : type(physics_state), intent(in) :: state
497 : ! Name of the package responsible for this state.
498 : character(len=*), intent(in), optional :: name
499 :
500 : !---------------------------Local storage-------------------------------
501 : ! Shortened name for ncol.
502 : integer :: ncol
503 : ! Double precision positive/negative infinity.
504 : real(r8) :: posinf_r8, neginf_r8
505 : ! Canned message.
506 : character(len=64) :: msg
507 : ! Constituent index
508 : integer :: m
509 :
510 : !-----------------------------------------------------------------------
511 :
512 2402496 : ncol = state%ncol
513 :
514 2402496 : posinf_r8 = shr_infnan_posinf
515 2402496 : neginf_r8 = shr_infnan_neginf
516 :
517 : ! It may be reasonable to check some of the integer components of the
518 : ! state as well, but this is not yet implemented.
519 :
520 : ! Check for NaN first to avoid any IEEE exceptions.
521 :
522 2402496 : if (present(name)) then
523 : msg = "NaN produced in physics_state by package "// &
524 2402496 : trim(name)//"."
525 : else
526 0 : msg = "NaN found in physics_state."
527 : end if
528 :
529 : ! 1-D variables
530 0 : call shr_assert_in_domain(state%ps(:ncol), is_nan=.false., &
531 2402496 : varname="state%ps", msg=msg)
532 0 : call shr_assert_in_domain(state%psdry(:ncol), is_nan=.false., &
533 2402496 : varname="state%psdry", msg=msg)
534 0 : call shr_assert_in_domain(state%phis(:ncol), is_nan=.false., &
535 2402496 : varname="state%phis", msg=msg)
536 0 : call shr_assert_in_domain(state%te_ini(:ncol,:), is_nan=.false., &
537 2402496 : varname="state%te_ini", msg=msg)
538 0 : call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., &
539 2402496 : varname="state%te_cur", msg=msg)
540 0 : call shr_assert_in_domain(state%tw_ini(:ncol,:), is_nan=.false., &
541 2402496 : varname="state%tw_ini", msg=msg)
542 0 : call shr_assert_in_domain(state%tw_cur(:ncol,:), is_nan=.false., &
543 2402496 : varname="state%tw_cur", msg=msg)
544 0 : call shr_assert_in_domain(state%temp_ini(:ncol,:), is_nan=.false., &
545 2402496 : varname="state%temp_ini", msg=msg)
546 0 : call shr_assert_in_domain(state%z_ini(:ncol,:), is_nan=.false., &
547 2402496 : varname="state%z_ini", msg=msg)
548 :
549 : ! 2-D variables (at midpoints)
550 0 : call shr_assert_in_domain(state%t(:ncol,:), is_nan=.false., &
551 2402496 : varname="state%t", msg=msg)
552 0 : call shr_assert_in_domain(state%u(:ncol,:), is_nan=.false., &
553 2402496 : varname="state%u", msg=msg)
554 0 : call shr_assert_in_domain(state%v(:ncol,:), is_nan=.false., &
555 2402496 : varname="state%v", msg=msg)
556 0 : call shr_assert_in_domain(state%s(:ncol,:), is_nan=.false., &
557 2402496 : varname="state%s", msg=msg)
558 0 : call shr_assert_in_domain(state%omega(:ncol,:), is_nan=.false., &
559 2402496 : varname="state%omega", msg=msg)
560 0 : call shr_assert_in_domain(state%pmid(:ncol,:), is_nan=.false., &
561 2402496 : varname="state%pmid", msg=msg)
562 0 : call shr_assert_in_domain(state%pmiddry(:ncol,:), is_nan=.false., &
563 2402496 : varname="state%pmiddry", msg=msg)
564 0 : call shr_assert_in_domain(state%pdel(:ncol,:), is_nan=.false., &
565 2402496 : varname="state%pdel", msg=msg)
566 0 : call shr_assert_in_domain(state%pdeldry(:ncol,:), is_nan=.false., &
567 2402496 : varname="state%pdeldry", msg=msg)
568 0 : call shr_assert_in_domain(state%rpdel(:ncol,:), is_nan=.false., &
569 2402496 : varname="state%rpdel", msg=msg)
570 0 : call shr_assert_in_domain(state%rpdeldry(:ncol,:), is_nan=.false., &
571 2402496 : varname="state%rpdeldry", msg=msg)
572 0 : call shr_assert_in_domain(state%lnpmid(:ncol,:), is_nan=.false., &
573 2402496 : varname="state%lnpmid", msg=msg)
574 0 : call shr_assert_in_domain(state%lnpmiddry(:ncol,:), is_nan=.false., &
575 2402496 : varname="state%lnpmiddry", msg=msg)
576 0 : call shr_assert_in_domain(state%exner(:ncol,:), is_nan=.false., &
577 2402496 : varname="state%exner", msg=msg)
578 0 : call shr_assert_in_domain(state%zm(:ncol,:), is_nan=.false., &
579 2402496 : varname="state%zm", msg=msg)
580 :
581 : ! 2-D variables (at interfaces)
582 0 : call shr_assert_in_domain(state%pint(:ncol,:), is_nan=.false., &
583 2402496 : varname="state%pint", msg=msg)
584 0 : call shr_assert_in_domain(state%pintdry(:ncol,:), is_nan=.false., &
585 2402496 : varname="state%pintdry", msg=msg)
586 0 : call shr_assert_in_domain(state%lnpint(:ncol,:), is_nan=.false., &
587 2402496 : varname="state%lnpint", msg=msg)
588 0 : call shr_assert_in_domain(state%lnpintdry(:ncol,:), is_nan=.false., &
589 2402496 : varname="state%lnpintdry", msg=msg)
590 0 : call shr_assert_in_domain(state%zi(:ncol,:), is_nan=.false., &
591 2402496 : varname="state%zi", msg=msg)
592 :
593 : ! 3-D variables
594 0 : call shr_assert_in_domain(state%q(:ncol,:,:), is_nan=.false., &
595 2402496 : varname="state%q", msg=msg)
596 :
597 : ! Now run other checks (i.e. values are finite and within a range that
598 : ! is physically meaningful).
599 :
600 2402496 : if (present(name)) then
601 : msg = "Invalid value produced in physics_state by package "// &
602 2402496 : trim(name)//"."
603 : else
604 0 : msg = "Invalid value found in physics_state."
605 : end if
606 :
607 : ! 1-D variables
608 : call shr_assert_in_domain(state%ps(:ncol), lt=posinf_r8, gt=0._r8, &
609 2402496 : varname="state%ps", msg=msg)
610 : call shr_assert_in_domain(state%psdry(:ncol), lt=posinf_r8, gt=0._r8, &
611 2402496 : varname="state%psdry", msg=msg)
612 : call shr_assert_in_domain(state%phis(:ncol), lt=posinf_r8, gt=neginf_r8, &
613 2402496 : varname="state%phis", msg=msg)
614 : call shr_assert_in_domain(state%te_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
615 2402496 : varname="state%te_ini", msg=msg)
616 : call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
617 2402496 : varname="state%te_cur", msg=msg)
618 : call shr_assert_in_domain(state%tw_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
619 2402496 : varname="state%tw_ini", msg=msg)
620 : call shr_assert_in_domain(state%tw_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
621 2402496 : varname="state%tw_cur", msg=msg)
622 : call shr_assert_in_domain(state%temp_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
623 2402496 : varname="state%temp_ini", msg=msg)
624 : call shr_assert_in_domain(state%z_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
625 2402496 : varname="state%z_ini", msg=msg)
626 :
627 : ! 2-D variables (at midpoints)
628 : call shr_assert_in_domain(state%t(:ncol,:), lt=posinf_r8, gt=0._r8, &
629 2402496 : varname="state%t", msg=msg)
630 : call shr_assert_in_domain(state%u(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
631 2402496 : varname="state%u", msg=msg)
632 : call shr_assert_in_domain(state%v(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
633 2402496 : varname="state%v", msg=msg)
634 : call shr_assert_in_domain(state%s(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
635 2402496 : varname="state%s", msg=msg)
636 : call shr_assert_in_domain(state%omega(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
637 2402496 : varname="state%omega", msg=msg)
638 : call shr_assert_in_domain(state%pmid(:ncol,:), lt=posinf_r8, gt=0._r8, &
639 2402496 : varname="state%pmid", msg=msg)
640 : call shr_assert_in_domain(state%pmiddry(:ncol,:), lt=posinf_r8, gt=0._r8, &
641 2402496 : varname="state%pmiddry", msg=msg)
642 : call shr_assert_in_domain(state%pdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
643 2402496 : varname="state%pdel", msg=msg)
644 : call shr_assert_in_domain(state%pdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
645 2402496 : varname="state%pdeldry", msg=msg)
646 : call shr_assert_in_domain(state%rpdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
647 2402496 : varname="state%rpdel", msg=msg)
648 : call shr_assert_in_domain(state%rpdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
649 2402496 : varname="state%rpdeldry", msg=msg)
650 : call shr_assert_in_domain(state%lnpmid(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
651 2402496 : varname="state%lnpmid", msg=msg)
652 : call shr_assert_in_domain(state%lnpmiddry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
653 2402496 : varname="state%lnpmiddry", msg=msg)
654 : call shr_assert_in_domain(state%exner(:ncol,:), lt=posinf_r8, gt=0._r8, &
655 2402496 : varname="state%exner", msg=msg)
656 : call shr_assert_in_domain(state%zm(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
657 2402496 : varname="state%zm", msg=msg)
658 :
659 : ! 2-D variables (at interfaces)
660 : call shr_assert_in_domain(state%pint(:ncol,:), lt=posinf_r8, gt=0._r8, &
661 2402496 : varname="state%pint", msg=msg)
662 : call shr_assert_in_domain(state%pintdry(:ncol,:), lt=posinf_r8, gt=0._r8, &
663 2402496 : varname="state%pintdry", msg=msg)
664 : call shr_assert_in_domain(state%lnpint(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
665 2402496 : varname="state%lnpint", msg=msg)
666 : call shr_assert_in_domain(state%lnpintdry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
667 2402496 : varname="state%lnpintdry", msg=msg)
668 : call shr_assert_in_domain(state%zi(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
669 2402496 : varname="state%zi", msg=msg)
670 :
671 : ! 3-D variables
672 100904832 : do m = 1,pcnst
673 : call shr_assert_in_domain(state%q(:ncol,:,m), lt=posinf_r8, gt=neginf_r8, &
674 100904832 : varname="state%q ("//trim(cnst_name(m))//")", msg=msg)
675 : end do
676 :
677 2402496 : end subroutine physics_state_check
678 :
679 : !===============================================================================
680 :
681 1495368 : subroutine physics_ptend_sum(ptend, ptend_sum, ncol)
682 : !-----------------------------------------------------------------------
683 : ! Add ptend fields to ptend_sum for ptend logical flags = .true.
684 : ! Where ptend logical flags = .false, don't change ptend_sum
685 : !-----------------------------------------------------------------------
686 :
687 : !------------------------------Arguments--------------------------------
688 : type(physics_ptend), intent(in) :: ptend ! New parameterization tendencies
689 : type(physics_ptend), intent(inout) :: ptend_sum ! Sum of incoming ptend_sum and ptend
690 : integer, intent(in) :: ncol ! number of columns
691 :
692 : !---------------------------Local storage-------------------------------
693 : integer :: i,k,m ! column,level,constituent indices
694 : integer :: psetcols ! maximum number of columns
695 : integer :: ierr = 0
696 :
697 : !-----------------------------------------------------------------------
698 1495368 : if (ptend%psetcols /= ptend_sum%psetcols) then
699 0 : call endrun('physics_ptend_sum error: ptend and ptend_sum must have the same value for psetcols')
700 : end if
701 :
702 1495368 : if (ncol > ptend_sum%psetcols) then
703 0 : call endrun('physics_ptend_sum error: ncol must be less than or equal to psetcols')
704 : end if
705 :
706 1495368 : psetcols = ptend_sum%psetcols
707 :
708 1495368 : ptend_sum%top_level = ptend%top_level
709 1495368 : ptend_sum%bot_level = ptend%bot_level
710 :
711 : ! Update u,v fields
712 1495368 : if(ptend%lu) then
713 417960 : if (.not. allocated(ptend_sum%u)) then
714 724464 : allocate(ptend_sum%u(psetcols,pver), stat=ierr)
715 241488 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%u')
716 382034016 : ptend_sum%u=0.0_r8
717 :
718 724464 : allocate(ptend_sum%taux_srf(psetcols), stat=ierr)
719 241488 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_srf')
720 4105296 : ptend_sum%taux_srf=0.0_r8
721 :
722 482976 : allocate(ptend_sum%taux_top(psetcols), stat=ierr)
723 241488 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_top')
724 4105296 : ptend_sum%taux_top=0.0_r8
725 : end if
726 417960 : ptend_sum%lu = .true.
727 :
728 39288240 : do k = ptend%top_level, ptend%bot_level
729 649461240 : do i = 1, ncol
730 649043280 : ptend_sum%u(i,k) = ptend_sum%u(i,k) + ptend%u(i,k)
731 : end do
732 : end do
733 6978960 : do i = 1, ncol
734 6561000 : ptend_sum%taux_srf(i) = ptend_sum%taux_srf(i) + ptend%taux_srf(i)
735 6978960 : ptend_sum%taux_top(i) = ptend_sum%taux_top(i) + ptend%taux_top(i)
736 : end do
737 : end if
738 :
739 1495368 : if(ptend%lv) then
740 417960 : if (.not. allocated(ptend_sum%v)) then
741 724464 : allocate(ptend_sum%v(psetcols,pver), stat=ierr)
742 241488 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%v')
743 382034016 : ptend_sum%v=0.0_r8
744 :
745 724464 : allocate(ptend_sum%tauy_srf(psetcols), stat=ierr)
746 241488 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_srf')
747 4105296 : ptend_sum%tauy_srf=0.0_r8
748 :
749 482976 : allocate(ptend_sum%tauy_top(psetcols), stat=ierr)
750 241488 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_top')
751 4105296 : ptend_sum%tauy_top=0.0_r8
752 : end if
753 417960 : ptend_sum%lv = .true.
754 :
755 39288240 : do k = ptend%top_level, ptend%bot_level
756 649461240 : do i = 1, ncol
757 649043280 : ptend_sum%v(i,k) = ptend_sum%v(i,k) + ptend%v(i,k)
758 : end do
759 : end do
760 6978960 : do i = 1, ncol
761 6561000 : ptend_sum%tauy_srf(i) = ptend_sum%tauy_srf(i) + ptend%tauy_srf(i)
762 6978960 : ptend_sum%tauy_top(i) = ptend_sum%tauy_top(i) + ptend%tauy_top(i)
763 : end do
764 : end if
765 :
766 :
767 1495368 : if(ptend%ls) then
768 900936 : if (.not. allocated(ptend_sum%s)) then
769 900936 : allocate(ptend_sum%s(psetcols,pver), stat=ierr)
770 300312 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%s')
771 475093584 : ptend_sum%s=0.0_r8
772 :
773 900936 : allocate(ptend_sum%hflux_srf(psetcols), stat=ierr)
774 300312 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_srf')
775 5105304 : ptend_sum%hflux_srf=0.0_r8
776 :
777 600624 : allocate(ptend_sum%hflux_top(psetcols), stat=ierr)
778 300312 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_top')
779 5105304 : ptend_sum%hflux_top=0.0_r8
780 : end if
781 900936 : ptend_sum%ls = .true.
782 :
783 84687984 : do k = ptend%top_level, ptend%bot_level
784 1399949784 : do i = 1, ncol
785 1399048848 : ptend_sum%s(i,k) = ptend_sum%s(i,k) + ptend%s(i,k)
786 : end do
787 : end do
788 15043536 : do i = 1, ncol
789 14142600 : ptend_sum%hflux_srf(i) = ptend_sum%hflux_srf(i) + ptend%hflux_srf(i)
790 15043536 : ptend_sum%hflux_top(i) = ptend_sum%hflux_top(i) + ptend%hflux_top(i)
791 : end do
792 : end if
793 :
794 11814336 : if (any(ptend%lq(:))) then
795 :
796 1430352 : if (.not. allocated(ptend_sum%q)) then
797 1907136 : allocate(ptend_sum%q(psetcols,pver,pcnst), stat=ierr)
798 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%q')
799 30925640592 : ptend_sum%q=0.0_r8
800 :
801 1430352 : allocate(ptend_sum%cflx_srf(psetcols,pcnst), stat=ierr)
802 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_srf')
803 332795232 : ptend_sum%cflx_srf=0.0_r8
804 :
805 953568 : allocate(ptend_sum%cflx_top(psetcols,pcnst), stat=ierr)
806 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_top')
807 332795232 : ptend_sum%cflx_top=0.0_r8
808 : end if
809 :
810 60074784 : do m = 1, pcnst
811 60074784 : if(ptend%lq(m)) then
812 18074448 : ptend_sum%lq(m) = .true.
813 1698998112 : do k = ptend%top_level, ptend%bot_level
814 28085590512 : do i = 1,ncol
815 28067516064 : ptend_sum%q(i,k,m) = ptend_sum%q(i,k,m) + ptend%q(i,k,m)
816 : end do
817 : end do
818 301801248 : do i = 1,ncol
819 283726800 : ptend_sum%cflx_srf(i,m) = ptend_sum%cflx_srf(i,m) + ptend%cflx_srf(i,m)
820 301801248 : ptend_sum%cflx_top(i,m) = ptend_sum%cflx_top(i,m) + ptend%cflx_top(i,m)
821 : end do
822 : end if
823 : end do
824 :
825 : end if
826 :
827 1495368 : end subroutine physics_ptend_sum
828 :
829 : !===============================================================================
830 :
831 529416 : subroutine physics_ptend_scale(ptend, fac, ncol)
832 : !-----------------------------------------------------------------------
833 : ! Scale ptend fields for ptend logical flags = .true.
834 : ! Where ptend logical flags = .false, don't change ptend.
835 : !
836 : ! Assumes that input ptend is valid (e.g. that
837 : ! ptend%lu .eqv. allocated(ptend%u)), and therefore
838 : ! does not check allocation status of individual arrays.
839 : !-----------------------------------------------------------------------
840 :
841 : !------------------------------Arguments--------------------------------
842 : type(physics_ptend), intent(inout) :: ptend ! Incoming ptend
843 : real(r8), intent(in) :: fac ! Factor to multiply ptend by.
844 : integer, intent(in) :: ncol ! number of columns
845 :
846 : !---------------------------Local storage-------------------------------
847 : integer :: m ! constituent index
848 :
849 : !-----------------------------------------------------------------------
850 :
851 : ! Update u,v fields
852 529416 : if (ptend%lu) &
853 : call multiply_tendency(ptend%u, &
854 176472 : ptend%taux_srf, ptend%taux_top)
855 :
856 529416 : if (ptend%lv) &
857 : call multiply_tendency(ptend%v, &
858 176472 : ptend%tauy_srf, ptend%tauy_top)
859 :
860 : ! Heat
861 529416 : if (ptend%ls) &
862 : call multiply_tendency(ptend%s, &
863 529416 : ptend%hflux_srf, ptend%hflux_top)
864 :
865 : ! Update constituents
866 22235472 : do m = 1, pcnst
867 21706056 : if (ptend%lq(m)) &
868 : call multiply_tendency(ptend%q(:,:,m), &
869 11647152 : ptend%cflx_srf(:,m), ptend%cflx_top(:,m))
870 : end do
871 :
872 :
873 : contains
874 :
875 12000096 : subroutine multiply_tendency(tend_arr, flx_srf, flx_top)
876 : real(r8), intent(inout) :: tend_arr(:,:) ! Tendency array (pcols, plev)
877 : real(r8), intent(inout) :: flx_srf(:) ! Surface flux (or stress)
878 : real(r8), intent(inout) :: flx_top(:) ! Top-of-model flux (or stress)
879 :
880 : integer :: k
881 :
882 1128009024 : do k = ptend%top_level, ptend%bot_level
883 18646753824 : tend_arr(:ncol,k) = tend_arr(:ncol,k) * fac
884 : end do
885 200373696 : flx_srf(:ncol) = flx_srf(:ncol) * fac
886 200373696 : flx_top(:ncol) = flx_top(:ncol) * fac
887 :
888 12000096 : end subroutine multiply_tendency
889 :
890 : end subroutine physics_ptend_scale
891 :
892 : !===============================================================================
893 :
894 0 : subroutine physics_ptend_copy(ptend, ptend_cp)
895 :
896 : !-----------------------------------------------------------------------
897 : ! Copy a physics_ptend object. Allocate ptend_cp internally before copy.
898 : !-----------------------------------------------------------------------
899 :
900 : type(physics_ptend), intent(in) :: ptend ! ptend source
901 : type(physics_ptend), intent(out) :: ptend_cp ! copy of ptend
902 :
903 : !-----------------------------------------------------------------------
904 :
905 0 : ptend_cp%name = ptend%name
906 :
907 0 : ptend_cp%ls = ptend%ls
908 0 : ptend_cp%lu = ptend%lu
909 0 : ptend_cp%lv = ptend%lv
910 0 : ptend_cp%lq = ptend%lq
911 :
912 0 : call physics_ptend_alloc(ptend_cp, ptend%psetcols)
913 :
914 0 : ptend_cp%top_level = ptend%top_level
915 0 : ptend_cp%bot_level = ptend%bot_level
916 :
917 0 : if (ptend_cp%ls) then
918 0 : ptend_cp%s = ptend%s
919 0 : ptend_cp%hflux_srf = ptend%hflux_srf
920 0 : ptend_cp%hflux_top = ptend%hflux_top
921 : end if
922 :
923 0 : if (ptend_cp%lu) then
924 0 : ptend_cp%u = ptend%u
925 0 : ptend_cp%taux_srf = ptend%taux_srf
926 0 : ptend_cp%taux_top = ptend%taux_top
927 : end if
928 :
929 0 : if (ptend_cp%lv) then
930 0 : ptend_cp%v = ptend%v
931 0 : ptend_cp%tauy_srf = ptend%tauy_srf
932 0 : ptend_cp%tauy_top = ptend%tauy_top
933 : end if
934 :
935 0 : if (any(ptend_cp%lq(:))) then
936 0 : ptend_cp%q = ptend%q
937 0 : ptend_cp%cflx_srf = ptend%cflx_srf
938 0 : ptend_cp%cflx_top = ptend%cflx_top
939 : end if
940 :
941 0 : end subroutine physics_ptend_copy
942 :
943 : !===============================================================================
944 :
945 2099088 : subroutine physics_ptend_reset(ptend)
946 : !-----------------------------------------------------------------------
947 : ! Reset the parameterization tendency structure to "empty"
948 : !-----------------------------------------------------------------------
949 :
950 : !------------------------------Arguments--------------------------------
951 : type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies
952 : !-----------------------------------------------------------------------
953 :
954 2099088 : if(ptend%ls) then
955 2101187088 : ptend%s = 0._r8
956 22579128 : ptend%hflux_srf = 0._r8
957 22579128 : ptend%hflux_top = 0._r8
958 : endif
959 2099088 : if(ptend%lu) then
960 754272288 : ptend%u = 0._r8
961 8105328 : ptend%taux_srf = 0._r8
962 8105328 : ptend%taux_top = 0._r8
963 : endif
964 2099088 : if(ptend%lv) then
965 754272288 : ptend%v = 0._r8
966 8105328 : ptend%tauy_srf = 0._r8
967 8105328 : ptend%tauy_top = 0._r8
968 : endif
969 22622472 : if(any (ptend%lq(:))) then
970 >11607*10^7 : ptend%q = 0._r8
971 1249062624 : ptend%cflx_srf = 0._r8
972 1249062624 : ptend%cflx_top = 0._r8
973 : end if
974 :
975 2099088 : ptend%top_level = 1
976 2099088 : ptend%bot_level = pver
977 :
978 2099088 : return
979 : end subroutine physics_ptend_reset
980 :
981 : !===============================================================================
982 115598448 : subroutine physics_ptend_init(ptend, psetcols, name, ls, lu, lv, lq)
983 : !-----------------------------------------------------------------------
984 : ! Allocate the fields in the structure which are specified.
985 : ! Initialize the parameterization tendency structure to "empty"
986 : !-----------------------------------------------------------------------
987 :
988 : !------------------------------Arguments--------------------------------
989 : type(physics_ptend), intent(out) :: ptend ! Parameterization tendencies
990 : integer, intent(in) :: psetcols ! maximum number of columns
991 : character(len=*) :: name ! optional name of parameterization which produced tendencies.
992 : logical, optional :: ls ! if true, then fields to support dsdt are allocated
993 : logical, optional :: lu ! if true, then fields to support dudt are allocated
994 : logical, optional :: lv ! if true, then fields to support dvdt are allocated
995 : logical, dimension(pcnst),optional :: lq ! if true, then fields to support dqdt are allocated
996 :
997 : !-----------------------------------------------------------------------
998 :
999 2752344 : if (allocated(ptend%s)) then
1000 0 : call endrun(' physics_ptend_init: ptend should not be allocated before calling this routine')
1001 : end if
1002 :
1003 2752344 : ptend%name = name
1004 2752344 : ptend%psetcols = psetcols
1005 :
1006 : ! If no fields being stored, initialize all values to appropriate nulls and return
1007 2752344 : if (.not. present(ls) .and. .not. present(lu) .and. .not. present(lv) .and. .not. present(lq) ) then
1008 653256 : ptend%ls = .false.
1009 653256 : ptend%lu = .false.
1010 653256 : ptend%lv = .false.
1011 27436752 : ptend%lq(:) = .false.
1012 653256 : ptend%top_level = 1
1013 653256 : ptend%bot_level = pver
1014 653256 : return
1015 : end if
1016 :
1017 2099088 : if (present(ls)) then
1018 1328184 : ptend%ls = ls
1019 : else
1020 770904 : ptend%ls = .false.
1021 : end if
1022 :
1023 2099088 : if (present(lu)) then
1024 476784 : ptend%lu = lu
1025 : else
1026 1622304 : ptend%lu = .false.
1027 : end if
1028 :
1029 2099088 : if (present(lv)) then
1030 476784 : ptend%lv = lv
1031 : else
1032 1622304 : ptend%lv = .false.
1033 : end if
1034 :
1035 2099088 : if (present(lq)) then
1036 75158496 : ptend%lq(:) = lq(:)
1037 : else
1038 13003200 : ptend%lq(:) = .false.
1039 : end if
1040 :
1041 2099088 : call physics_ptend_alloc(ptend, psetcols)
1042 :
1043 2099088 : call physics_ptend_reset(ptend)
1044 :
1045 2099088 : return
1046 2752344 : end subroutine physics_ptend_init
1047 :
1048 : !===============================================================================
1049 :
1050 6192 : subroutine physics_state_set_grid(lchnk, phys_state)
1051 : !-----------------------------------------------------------------------
1052 : ! Set the grid components of the physics_state object
1053 : !-----------------------------------------------------------------------
1054 :
1055 : integer, intent(in) :: lchnk
1056 : type(physics_state), intent(inout) :: phys_state
1057 :
1058 : ! local variables
1059 : integer :: i, ncol
1060 : real(r8) :: rlon(pcols)
1061 : real(r8) :: rlat(pcols)
1062 :
1063 : !-----------------------------------------------------------------------
1064 : ! get_ncols_p requires a state which does not have sub-columns
1065 6192 : if (phys_state%psetcols .ne. pcols) then
1066 0 : call endrun('physics_state_set_grid: cannot pass in a state which has sub-columns')
1067 : end if
1068 :
1069 6192 : ncol = get_ncols_p(lchnk)
1070 :
1071 6192 : if(ncol<=0) then
1072 0 : write(iulog,*) lchnk, ncol
1073 0 : call endrun('physics_state_set_grid')
1074 : end if
1075 :
1076 6192 : call get_rlon_all_p(lchnk, ncol, rlon)
1077 6192 : call get_rlat_all_p(lchnk, ncol, rlat)
1078 6192 : phys_state%ncol = ncol
1079 6192 : phys_state%lchnk = lchnk
1080 103392 : do i=1,ncol
1081 97200 : phys_state%lat(i) = rlat(i)
1082 103392 : phys_state%lon(i) = rlon(i)
1083 : end do
1084 6192 : call init_geo_unique(phys_state,ncol)
1085 :
1086 6192 : end subroutine physics_state_set_grid
1087 :
1088 :
1089 6192 : subroutine init_geo_unique(phys_state,ncol)
1090 : integer, intent(in) :: ncol
1091 : type(physics_state), intent(inout) :: phys_state
1092 : logical :: match
1093 : integer :: i, j, ulatcnt, uloncnt
1094 :
1095 105264 : phys_state%ulat=-999._r8
1096 105264 : phys_state%ulon=-999._r8
1097 105264 : phys_state%latmapback=0
1098 105264 : phys_state%lonmapback=0
1099 : match=.false.
1100 6192 : ulatcnt=0
1101 6192 : uloncnt=0
1102 6192 : match=.false.
1103 103392 : do i=1,ncol
1104 807210 : do j=1,ulatcnt
1105 807210 : if(phys_state%lat(i) .eq. phys_state%ulat(j)) then
1106 1858 : match=.true.
1107 1858 : phys_state%latmapback(i)=j
1108 : end if
1109 : end do
1110 97200 : if(.not. match) then
1111 95342 : ulatcnt=ulatcnt+1
1112 95342 : phys_state%ulat(ulatcnt)=phys_state%lat(i)
1113 95342 : phys_state%latmapback(i)=ulatcnt
1114 : end if
1115 :
1116 97200 : match=.false.
1117 597614 : do j=1,uloncnt
1118 597614 : if(phys_state%lon(i) .eq. phys_state%ulon(j)) then
1119 38438 : match=.true.
1120 38438 : phys_state%lonmapback(i)=j
1121 : end if
1122 : end do
1123 97200 : if(.not. match) then
1124 58762 : uloncnt=uloncnt+1
1125 58762 : phys_state%ulon(uloncnt)=phys_state%lon(i)
1126 58762 : phys_state%lonmapback(i)=uloncnt
1127 : end if
1128 103392 : match=.false.
1129 :
1130 : end do
1131 6192 : phys_state%uloncnt=uloncnt
1132 6192 : phys_state%ulatcnt=ulatcnt
1133 :
1134 6192 : call get_gcol_all_p(phys_state%lchnk,pcols,phys_state%cid)
1135 :
1136 :
1137 6192 : end subroutine init_geo_unique
1138 :
1139 : !===============================================================================
1140 0 : subroutine physics_cnst_limit(state)
1141 : type(physics_state), intent(inout) :: state
1142 :
1143 : integer :: i,k, ncol
1144 :
1145 : real(r8) :: mmrSum_O_O2_H ! Sum of mass mixing ratios for O, O2, and H
1146 : real(r8), parameter :: mmrMin=1.e-20_r8 ! lower limit of o2, o, and h mixing ratios
1147 : real(r8), parameter :: N2mmrMin=1.e-6_r8 ! lower limit of N2 mass mixing ratio
1148 : real(r8), parameter :: H2lim=6.e-5_r8 ! H2 limiter: 10x global H2 MMR (Roble, 1995)
1149 : integer :: ixo, ixo2, ixh, ixh2
1150 :
1151 0 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
1152 0 : call cnst_get_ind('O', ixo)
1153 0 : call cnst_get_ind('O2', ixo2)
1154 0 : call cnst_get_ind('H', ixh)
1155 0 : call cnst_get_ind('H2', ixh2)
1156 :
1157 0 : ncol = state%ncol
1158 :
1159 : !------------------------------------------------------------
1160 : ! Ensure N2 = 1-(O2 + O + H) mmr is greater than 0
1161 : ! Check for unusually large H2 values and set to lower value.
1162 : !------------------------------------------------------------
1163 :
1164 0 : do k=1,pver
1165 0 : do i=1,ncol
1166 :
1167 0 : if (state%q(i,k,ixo) < mmrMin) state%q(i,k,ixo) = mmrMin
1168 0 : if (state%q(i,k,ixo2) < mmrMin) state%q(i,k,ixo2) = mmrMin
1169 :
1170 0 : mmrSum_O_O2_H = state%q(i,k,ixo)+state%q(i,k,ixo2)+state%q(i,k,ixh)
1171 :
1172 0 : if ((1._r8-mmrMin-mmrSum_O_O2_H) < 0._r8) then
1173 :
1174 0 : state%q(i,k,ixo) = state%q(i,k,ixo) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
1175 :
1176 0 : state%q(i,k,ixo2) = state%q(i,k,ixo2) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
1177 :
1178 0 : state%q(i,k,ixh) = state%q(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
1179 :
1180 : endif
1181 :
1182 0 : if(state%q(i,k,ixh2) > H2lim) then
1183 0 : state%q(i,k,ixh2) = H2lim
1184 : endif
1185 :
1186 : end do
1187 : end do
1188 :
1189 : end if
1190 0 : end subroutine physics_cnst_limit
1191 :
1192 : !===============================================================================
1193 0 : subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt)
1194 : use air_composition, only: dry_air_species_num,thermodynamic_active_species_num
1195 : use air_composition, only: thermodynamic_active_species_idx
1196 : use dycore, only: dycore_is
1197 : !-----------------------------------------------------------------------
1198 : !
1199 : ! Purpose: Adjust the dry mass in each layer back to the value of physics input state
1200 : !
1201 : ! Method: Conserve the integrated mass, momentum and total energy in each layer
1202 : ! by scaling the specific mass of consituents, specific momentum (velocity)
1203 : ! and specific total energy by the relative change in layer mass. Solve for
1204 : ! the new temperature by subtracting the new kinetic energy from total energy
1205 : ! and inverting the hydrostatic equation
1206 : !
1207 : ! The mass in each layer is modified, changing the relationship of the layer
1208 : ! interfaces and midpoints to the surface pressure. The result is no longer in
1209 : ! the original hybrid coordinate.
1210 : !
1211 : ! This procedure cannot be applied to the "eul" or "sld" dycores because they
1212 : ! require the hybrid coordinate.
1213 : !
1214 : ! Author: Byron Boville
1215 :
1216 : ! !REVISION HISTORY:
1217 : ! 03.03.28 Boville Created, partly from code by Lin in p_d_adjust
1218 : !
1219 : !-----------------------------------------------------------------------
1220 :
1221 : implicit none
1222 : !
1223 : ! Arguments
1224 : !
1225 : type(physics_state), intent(inout) :: state
1226 : type(physics_tend ), intent(inout) :: tend
1227 : real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity
1228 : real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid
1229 : real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice
1230 : real(r8), intent(in ) :: dt ! model physics timestep
1231 : !
1232 : !---------------------------Local workspace-----------------------------
1233 : !
1234 : integer :: lchnk ! chunk identifier
1235 : integer :: ncol ! number of atmospheric columns
1236 : integer :: k,m ! Longitude, level indices
1237 : real(r8) :: fdq(pcols) ! mass adjustment factor
1238 : real(r8) :: te(pcols) ! total energy in a layer
1239 : real(r8) :: utmp(pcols) ! temp variable for recalculating the initial u values
1240 : real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values
1241 :
1242 : real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer
1243 :
1244 : real(r8) :: tot_water (pcols,2) ! total water (initial, present)
1245 : real(r8) :: tot_water_chg(pcols) ! total water change
1246 :
1247 :
1248 : real(r8),allocatable :: cpairv_loc(:,:)
1249 : integer :: m_cnst
1250 : !
1251 : !-----------------------------------------------------------------------
1252 :
1253 0 : if (state%psetcols .ne. pcols) then
1254 0 : call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns')
1255 : end if
1256 :
1257 0 : lchnk = state%lchnk
1258 0 : ncol = state%ncol
1259 :
1260 : ! adjust dry mass in each layer back to input value, while conserving
1261 : ! constituents, momentum, and total energy
1262 0 : state%ps(:ncol) = state%pint(:ncol,1)
1263 :
1264 : !
1265 : ! original code for backwards compatability with FV and EUL
1266 : !
1267 0 : if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then
1268 0 : do k = 1, pver
1269 :
1270 : ! adjusment factor is just change in water vapor
1271 0 : fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k)
1272 :
1273 : ! adjust constituents to conserve mass in each layer
1274 0 : do m = 1, pcnst
1275 0 : state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol)
1276 : end do
1277 : ! compute new total pressure variables
1278 0 : state%pdel (:ncol,k ) = state%pdel(:ncol,k ) * fdq(:ncol)
1279 0 : state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)
1280 0 : state%pint (:ncol,k+1) = state%pint(:ncol,k ) + state%pdel(:ncol,k)
1281 0 : state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1))
1282 0 : state%rpdel (:ncol,k ) = 1._r8/ state%pdel(:ncol,k )
1283 : end do
1284 : else
1285 0 : do k = 1, pver
1286 0 : tot_water(:ncol,1) = qini(:ncol,k) +liqini(:ncol,k)+iceini(:ncol,k) !initial total H2O
1287 0 : tot_water(:ncol,2) = 0.0_r8
1288 0 : do m_cnst=dry_air_species_num+1,thermodynamic_active_species_num
1289 0 : m = thermodynamic_active_species_idx(m_cnst)
1290 0 : tot_water(:ncol,2) = tot_water(:ncol,2)+state%q(:ncol,k,m)
1291 : end do
1292 0 : fdq(:ncol) = 1._r8 + tot_water(:ncol,2) - tot_water(:ncol,1)
1293 : ! adjust constituents to conserve mass in each layer
1294 0 : do m = 1, pcnst
1295 0 : state%q(:ncol,k,m) = state%q(:ncol,k,m) / fdq(:ncol)
1296 : end do
1297 : ! compute new total pressure variables
1298 0 : state%pdel (:ncol,k ) = state%pdel(:ncol,k ) * fdq(:ncol)
1299 0 : state%ps(:ncol) = state%ps(:ncol) + state%pdel(:ncol,k)
1300 0 : state%pint (:ncol,k+1) = state%pint(:ncol,k ) + state%pdel(:ncol,k)
1301 0 : state%lnpint(:ncol,k+1) = log(state%pint(:ncol,k+1))
1302 0 : state%rpdel (:ncol,k ) = 1._r8/ state%pdel(:ncol,k )
1303 : !note that mid-level variables (e.g. pmid) are not recomputed
1304 : end do
1305 : endif
1306 0 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
1307 0 : zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8
1308 : else
1309 0 : zvirv(:,:) = zvir
1310 : endif
1311 :
1312 0 : end subroutine physics_dme_adjust
1313 :
1314 : !-----------------------------------------------------------------------
1315 :
1316 : !===============================================================================
1317 653256 : subroutine physics_state_copy(state_in, state_out)
1318 :
1319 : use ppgrid, only: pver, pverp
1320 : use constituents, only: pcnst
1321 :
1322 : implicit none
1323 :
1324 : !
1325 : ! Arguments
1326 : !
1327 : type(physics_state), intent(in) :: state_in
1328 : type(physics_state), intent(out) :: state_out
1329 :
1330 : !
1331 : ! Local variables
1332 : !
1333 : integer i, k, m, ncol
1334 :
1335 : ! Allocate state_out with same subcol dimension as state_in
1336 653256 : call physics_state_alloc ( state_out, state_in%lchnk, state_in%psetcols)
1337 :
1338 653256 : ncol = state_in%ncol
1339 :
1340 653256 : state_out%psetcols = state_in%psetcols
1341 653256 : state_out%ngrdcol = state_in%ngrdcol
1342 653256 : state_out%lchnk = state_in%lchnk
1343 653256 : state_out%ncol = state_in%ncol
1344 653256 : state_out%count = state_in%count
1345 :
1346 10907856 : do i = 1, ncol
1347 10254600 : state_out%lat(i) = state_in%lat(i)
1348 10254600 : state_out%lon(i) = state_in%lon(i)
1349 10254600 : state_out%ps(i) = state_in%ps(i)
1350 10907856 : state_out%phis(i) = state_in%phis(i)
1351 : end do
1352 22468968 : state_out%te_ini(:ncol,:) = state_in%te_ini(:ncol,:)
1353 22468968 : state_out%te_cur(:ncol,:) = state_in%te_cur(:ncol,:)
1354 22468968 : state_out%tw_ini(:ncol,:) = state_in%tw_ini(:ncol,:)
1355 22468968 : state_out%tw_cur(:ncol,:) = state_in%tw_cur(:ncol,:)
1356 :
1357 61406064 : do k = 1, pver
1358 1015083864 : do i = 1, ncol
1359 953677800 : state_out%temp_ini(i,k) = state_in%temp_ini(i,k)
1360 953677800 : state_out%z_ini(i,k) = state_in%z_ini(i,k)
1361 953677800 : state_out%t(i,k) = state_in%t(i,k)
1362 953677800 : state_out%u(i,k) = state_in%u(i,k)
1363 953677800 : state_out%v(i,k) = state_in%v(i,k)
1364 953677800 : state_out%s(i,k) = state_in%s(i,k)
1365 953677800 : state_out%omega(i,k) = state_in%omega(i,k)
1366 953677800 : state_out%pmid(i,k) = state_in%pmid(i,k)
1367 953677800 : state_out%pdel(i,k) = state_in%pdel(i,k)
1368 953677800 : state_out%rpdel(i,k) = state_in%rpdel(i,k)
1369 953677800 : state_out%lnpmid(i,k) = state_in%lnpmid(i,k)
1370 953677800 : state_out%exner(i,k) = state_in%exner(i,k)
1371 1014430608 : state_out%zm(i,k) = state_in%zm(i,k)
1372 : end do
1373 : end do
1374 :
1375 62059320 : do k = 1, pverp
1376 1025991720 : do i = 1, ncol
1377 963932400 : state_out%pint(i,k) = state_in%pint(i,k)
1378 963932400 : state_out%lnpint(i,k) = state_in%lnpint(i,k)
1379 1025338464 : state_out%zi(i,k) = state_in% zi(i,k)
1380 : end do
1381 : end do
1382 :
1383 :
1384 10907856 : do i = 1, ncol
1385 10907856 : state_out%psdry(i) = state_in%psdry(i)
1386 : end do
1387 61406064 : do k = 1, pver
1388 1015083864 : do i = 1, ncol
1389 953677800 : state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k)
1390 953677800 : state_out%pmiddry(i,k) = state_in%pmiddry(i,k)
1391 953677800 : state_out%pdeldry(i,k) = state_in%pdeldry(i,k)
1392 1014430608 : state_out%rpdeldry(i,k) = state_in%rpdeldry(i,k)
1393 : end do
1394 : end do
1395 62059320 : do k = 1, pverp
1396 1025991720 : do i = 1, ncol
1397 963932400 : state_out%pintdry(i,k) = state_in%pintdry(i,k)
1398 1025338464 : state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k)
1399 : end do
1400 : end do
1401 :
1402 27436752 : do m = 1, pcnst
1403 2518301880 : do k = 1, pver
1404 41618438424 : do i = 1, ncol
1405 41591654928 : state_out%q(i,k,m) = state_in%q(i,k,m)
1406 : end do
1407 : end do
1408 : end do
1409 :
1410 653256 : end subroutine physics_state_copy
1411 : !===============================================================================
1412 :
1413 0 : subroutine physics_tend_init(tend)
1414 :
1415 : implicit none
1416 :
1417 : !
1418 : ! Arguments
1419 : !
1420 : type(physics_tend), intent(inout) :: tend
1421 :
1422 : !
1423 : ! Local variables
1424 : !
1425 :
1426 0 : if (.not. allocated(tend%dtdt)) then
1427 0 : call endrun('physics_tend_init: tend must be allocated before it can be initialized')
1428 : end if
1429 :
1430 0 : tend%dtdt = 0._r8
1431 0 : tend%dudt = 0._r8
1432 0 : tend%dvdt = 0._r8
1433 0 : tend%flx_net = 0._r8
1434 0 : tend%te_tnd = 0._r8
1435 0 : tend%tw_tnd = 0._r8
1436 :
1437 0 : end subroutine physics_tend_init
1438 :
1439 : !===============================================================================
1440 :
1441 0 : subroutine set_state_pdry (state,pdeld_calc)
1442 :
1443 : use ppgrid, only: pver
1444 : implicit none
1445 :
1446 : type(physics_state), intent(inout) :: state
1447 : logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default]
1448 : ! .false. don't calculate pdeld
1449 : integer ncol
1450 : integer k
1451 : logical do_pdeld_calc
1452 :
1453 0 : if ( present(pdeld_calc) ) then
1454 0 : do_pdeld_calc = pdeld_calc
1455 : else
1456 : do_pdeld_calc = .true.
1457 : endif
1458 :
1459 0 : ncol = state%ncol
1460 :
1461 :
1462 0 : state%psdry(:ncol) = state%pint(:ncol,1)
1463 0 : state%pintdry(:ncol,1) = state%pint(:ncol,1)
1464 :
1465 0 : if (do_pdeld_calc) then
1466 0 : do k = 1, pver
1467 0 : state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-state%q(:ncol,k,1))
1468 : end do
1469 : endif
1470 0 : do k = 1, pver
1471 0 : state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k)
1472 0 : state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8
1473 0 : state%psdry(:ncol) = state%psdry(:ncol) + state%pdeldry(:ncol,k)
1474 : end do
1475 :
1476 0 : state%rpdeldry(:ncol,:) = 1._r8/state%pdeldry(:ncol,:)
1477 0 : state%lnpmiddry(:ncol,:) = log(state%pmiddry(:ncol,:))
1478 0 : state%lnpintdry(:ncol,:) = log(state%pintdry(:ncol,:))
1479 :
1480 0 : end subroutine set_state_pdry
1481 :
1482 : !===============================================================================
1483 :
1484 235296 : subroutine set_wet_to_dry (state)
1485 :
1486 : use constituents, only: pcnst, cnst_type
1487 :
1488 : type(physics_state), intent(inout) :: state
1489 :
1490 : integer m, ncol
1491 :
1492 235296 : ncol = state%ncol
1493 :
1494 9882432 : do m = 1,pcnst
1495 9882432 : if (cnst_type(m).eq.'dry') then
1496 10968678720 : state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:)
1497 : endif
1498 : end do
1499 :
1500 235296 : end subroutine set_wet_to_dry
1501 :
1502 : !===============================================================================
1503 :
1504 117648 : subroutine set_dry_to_wet (state)
1505 :
1506 : use constituents, only: pcnst, cnst_type
1507 :
1508 : type(physics_state), intent(inout) :: state
1509 :
1510 : integer m, ncol
1511 :
1512 117648 : ncol = state%ncol
1513 :
1514 4941216 : do m = 1,pcnst
1515 4941216 : if (cnst_type(m).eq.'dry') then
1516 5484339360 : state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:)
1517 : endif
1518 : end do
1519 :
1520 117648 : end subroutine set_dry_to_wet
1521 :
1522 : !===============================================================================
1523 :
1524 659448 : subroutine physics_state_alloc(state,lchnk,psetcols)
1525 :
1526 : use infnan, only: inf, assignment(=)
1527 :
1528 : ! allocate the individual state components
1529 :
1530 : type(physics_state), intent(inout) :: state
1531 : integer,intent(in) :: lchnk
1532 :
1533 : integer, intent(in) :: psetcols
1534 :
1535 : integer :: ierr=0
1536 :
1537 659448 : state%lchnk = lchnk
1538 659448 : state%psetcols = psetcols
1539 659448 : state%ngrdcol = get_ncols_p(lchnk) ! Number of grid columns
1540 :
1541 : !----------------------------------
1542 : ! Following variables will be overwritten by sub-column generator, if sub-columns are being used
1543 :
1544 : ! state%ncol - is initialized in physics_state_set_grid, if not using sub-columns
1545 :
1546 : !----------------------------------
1547 :
1548 1978344 : allocate(state%lat(psetcols), stat=ierr)
1549 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lat')
1550 :
1551 1318896 : allocate(state%lon(psetcols), stat=ierr)
1552 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lon')
1553 :
1554 1318896 : allocate(state%ps(psetcols), stat=ierr)
1555 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ps')
1556 :
1557 1318896 : allocate(state%psdry(psetcols), stat=ierr)
1558 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%psdry')
1559 :
1560 1318896 : allocate(state%phis(psetcols), stat=ierr)
1561 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%phis')
1562 :
1563 1318896 : allocate(state%ulat(psetcols), stat=ierr)
1564 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulat')
1565 :
1566 1318896 : allocate(state%ulon(psetcols), stat=ierr)
1567 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulon')
1568 :
1569 1978344 : allocate(state%t(psetcols,pver), stat=ierr)
1570 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%t')
1571 :
1572 1318896 : allocate(state%u(psetcols,pver), stat=ierr)
1573 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%u')
1574 :
1575 1318896 : allocate(state%v(psetcols,pver), stat=ierr)
1576 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%v')
1577 :
1578 1318896 : allocate(state%s(psetcols,pver), stat=ierr)
1579 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%s')
1580 :
1581 1318896 : allocate(state%omega(psetcols,pver), stat=ierr)
1582 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%omega')
1583 :
1584 1318896 : allocate(state%pmid(psetcols,pver), stat=ierr)
1585 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmid')
1586 :
1587 1318896 : allocate(state%pmiddry(psetcols,pver), stat=ierr)
1588 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmiddry')
1589 :
1590 1318896 : allocate(state%pdel(psetcols,pver), stat=ierr)
1591 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdel')
1592 :
1593 1318896 : allocate(state%pdeldry(psetcols,pver), stat=ierr)
1594 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdeldry')
1595 :
1596 1318896 : allocate(state%rpdel(psetcols,pver), stat=ierr)
1597 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdel')
1598 :
1599 1318896 : allocate(state%rpdeldry(psetcols,pver), stat=ierr)
1600 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdeldry')
1601 :
1602 1318896 : allocate(state%lnpmid(psetcols,pver), stat=ierr)
1603 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmid')
1604 :
1605 1318896 : allocate(state%lnpmiddry(psetcols,pver), stat=ierr)
1606 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmiddry')
1607 :
1608 1318896 : allocate(state%exner(psetcols,pver), stat=ierr)
1609 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%exner')
1610 :
1611 1318896 : allocate(state%zm(psetcols,pver), stat=ierr)
1612 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zm')
1613 :
1614 2637792 : allocate(state%q(psetcols,pver,pcnst), stat=ierr)
1615 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%q')
1616 :
1617 1978344 : allocate(state%pint(psetcols,pver+1), stat=ierr)
1618 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pint')
1619 :
1620 1318896 : allocate(state%pintdry(psetcols,pver+1), stat=ierr)
1621 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pintdry')
1622 :
1623 1318896 : allocate(state%lnpint(psetcols,pver+1), stat=ierr)
1624 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpint')
1625 :
1626 1318896 : allocate(state%lnpintdry(psetcols,pver+1), stat=ierr)
1627 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpintdry')
1628 :
1629 1318896 : allocate(state%zi(psetcols,pver+1), stat=ierr)
1630 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zi')
1631 :
1632 1978344 : allocate(state%te_ini(psetcols,2), stat=ierr)
1633 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_ini')
1634 :
1635 1318896 : allocate(state%te_cur(psetcols,2), stat=ierr)
1636 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur')
1637 :
1638 1318896 : allocate(state%tw_ini(psetcols,2), stat=ierr)
1639 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini')
1640 :
1641 1318896 : allocate(state%tw_cur(psetcols,2), stat=ierr)
1642 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur')
1643 :
1644 1318896 : allocate(state%temp_ini(psetcols,pver), stat=ierr)
1645 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%temp_ini')
1646 :
1647 1318896 : allocate(state%z_ini(psetcols,pver), stat=ierr)
1648 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%z_ini')
1649 :
1650 1978344 : allocate(state%latmapback(psetcols), stat=ierr)
1651 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%latmapback')
1652 :
1653 1318896 : allocate(state%lonmapback(psetcols), stat=ierr)
1654 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lonmapback')
1655 :
1656 1318896 : allocate(state%cid(psetcols), stat=ierr)
1657 659448 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid')
1658 :
1659 659448 : state%lat(:) = inf
1660 659448 : state%lon(:) = inf
1661 659448 : state%ulat(:) = inf
1662 659448 : state%ulon(:) = inf
1663 659448 : state%ps(:) = inf
1664 659448 : state%psdry(:) = inf
1665 659448 : state%phis(:) = inf
1666 659448 : state%t(:,:) = inf
1667 659448 : state%u(:,:) = inf
1668 659448 : state%v(:,:) = inf
1669 659448 : state%s(:,:) = inf
1670 659448 : state%omega(:,:) = inf
1671 659448 : state%pmid(:,:) = inf
1672 659448 : state%pmiddry(:,:) = inf
1673 659448 : state%pdel(:,:) = inf
1674 659448 : state%pdeldry(:,:) = inf
1675 659448 : state%rpdel(:,:) = inf
1676 659448 : state%rpdeldry(:,:) = inf
1677 659448 : state%lnpmid(:,:) = inf
1678 659448 : state%lnpmiddry(:,:) = inf
1679 659448 : state%exner(:,:) = inf
1680 659448 : state%zm(:,:) = inf
1681 659448 : state%q(:,:,:) = inf
1682 :
1683 659448 : state%pint(:,:) = inf
1684 659448 : state%pintdry(:,:) = inf
1685 659448 : state%lnpint(:,:) = inf
1686 659448 : state%lnpintdry(:,:) = inf
1687 659448 : state%zi(:,:) = inf
1688 :
1689 659448 : state%te_ini(:,:) = inf
1690 659448 : state%te_cur(:,:) = inf
1691 659448 : state%tw_ini(:,:) = inf
1692 659448 : state%tw_cur(:,:) = inf
1693 659448 : state%temp_ini(:,:) = inf
1694 659448 : state%z_ini(:,:) = inf
1695 :
1696 659448 : end subroutine physics_state_alloc
1697 :
1698 : !===============================================================================
1699 :
1700 241488 : subroutine physics_state_dealloc(state)
1701 :
1702 : ! deallocate the individual state components
1703 :
1704 : type(physics_state), intent(inout) :: state
1705 : integer :: ierr = 0
1706 :
1707 241488 : deallocate(state%lat, stat=ierr)
1708 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lat')
1709 :
1710 241488 : deallocate(state%lon, stat=ierr)
1711 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lon')
1712 :
1713 241488 : deallocate(state%ps, stat=ierr)
1714 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ps')
1715 :
1716 241488 : deallocate(state%psdry, stat=ierr)
1717 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%psdry')
1718 :
1719 241488 : deallocate(state%phis, stat=ierr)
1720 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%phis')
1721 :
1722 241488 : deallocate(state%ulat, stat=ierr)
1723 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulat')
1724 :
1725 241488 : deallocate(state%ulon, stat=ierr)
1726 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulon')
1727 :
1728 241488 : deallocate(state%t, stat=ierr)
1729 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%t')
1730 :
1731 241488 : deallocate(state%u, stat=ierr)
1732 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%u')
1733 :
1734 241488 : deallocate(state%v, stat=ierr)
1735 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%v')
1736 :
1737 241488 : deallocate(state%s, stat=ierr)
1738 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%s')
1739 :
1740 241488 : deallocate(state%omega, stat=ierr)
1741 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%omega')
1742 :
1743 241488 : deallocate(state%pmid, stat=ierr)
1744 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmid')
1745 :
1746 241488 : deallocate(state%pmiddry, stat=ierr)
1747 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmiddry')
1748 :
1749 241488 : deallocate(state%pdel, stat=ierr)
1750 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdel')
1751 :
1752 241488 : deallocate(state%pdeldry, stat=ierr)
1753 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdeldry')
1754 :
1755 241488 : deallocate(state%rpdel, stat=ierr)
1756 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdel')
1757 :
1758 241488 : deallocate(state%rpdeldry, stat=ierr)
1759 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdeldry')
1760 :
1761 241488 : deallocate(state%lnpmid, stat=ierr)
1762 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmid')
1763 :
1764 241488 : deallocate(state%lnpmiddry, stat=ierr)
1765 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmiddry')
1766 :
1767 241488 : deallocate(state%exner, stat=ierr)
1768 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%exner')
1769 :
1770 241488 : deallocate(state%zm, stat=ierr)
1771 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zm')
1772 :
1773 241488 : deallocate(state%q, stat=ierr)
1774 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%q')
1775 :
1776 241488 : deallocate(state%pint, stat=ierr)
1777 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pint')
1778 :
1779 241488 : deallocate(state%pintdry, stat=ierr)
1780 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pintdry')
1781 :
1782 241488 : deallocate(state%lnpint, stat=ierr)
1783 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpint')
1784 :
1785 241488 : deallocate(state%lnpintdry, stat=ierr)
1786 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpintdry')
1787 :
1788 241488 : deallocate(state%zi, stat=ierr)
1789 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zi')
1790 :
1791 241488 : deallocate(state%te_ini, stat=ierr)
1792 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_ini')
1793 :
1794 241488 : deallocate(state%te_cur, stat=ierr)
1795 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur')
1796 :
1797 241488 : deallocate(state%tw_ini, stat=ierr)
1798 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini')
1799 :
1800 241488 : deallocate(state%tw_cur, stat=ierr)
1801 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_cur')
1802 :
1803 241488 : deallocate(state%temp_ini, stat=ierr)
1804 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%temp_ini')
1805 :
1806 241488 : deallocate(state%z_ini, stat=ierr)
1807 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%z_ini')
1808 :
1809 241488 : deallocate(state%latmapback, stat=ierr)
1810 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%latmapback')
1811 :
1812 241488 : deallocate(state%lonmapback, stat=ierr)
1813 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback')
1814 :
1815 241488 : deallocate(state%cid, stat=ierr)
1816 241488 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%cid')
1817 :
1818 241488 : end subroutine physics_state_dealloc
1819 :
1820 : !===============================================================================
1821 :
1822 6192 : subroutine physics_tend_alloc(tend,psetcols)
1823 :
1824 : use infnan, only : inf, assignment(=)
1825 : ! allocate the individual tend components
1826 :
1827 : type(physics_tend), intent(inout) :: tend
1828 :
1829 : integer, intent(in) :: psetcols
1830 :
1831 : integer :: ierr = 0
1832 :
1833 6192 : tend%psetcols = psetcols
1834 :
1835 18576 : allocate(tend%dtdt(psetcols,pver), stat=ierr)
1836 6192 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt')
1837 :
1838 12384 : allocate(tend%dudt(psetcols,pver), stat=ierr)
1839 6192 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dudt')
1840 :
1841 12384 : allocate(tend%dvdt(psetcols,pver), stat=ierr)
1842 6192 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dvdt')
1843 :
1844 18576 : allocate(tend%flx_net(psetcols), stat=ierr)
1845 6192 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%flx_net')
1846 :
1847 12384 : allocate(tend%te_tnd(psetcols), stat=ierr)
1848 6192 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_tnd')
1849 :
1850 12384 : allocate(tend%tw_tnd(psetcols), stat=ierr)
1851 6192 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd')
1852 :
1853 6192 : tend%dtdt(:,:) = inf
1854 6192 : tend%dudt(:,:) = inf
1855 6192 : tend%dvdt(:,:) = inf
1856 6192 : tend%flx_net(:) = inf
1857 6192 : tend%te_tnd(:) = inf
1858 6192 : tend%tw_tnd(:) = inf
1859 :
1860 6192 : end subroutine physics_tend_alloc
1861 :
1862 : !===============================================================================
1863 :
1864 0 : subroutine physics_tend_dealloc(tend)
1865 :
1866 : ! deallocate the individual tend components
1867 :
1868 : type(physics_tend), intent(inout) :: tend
1869 : integer :: ierr = 0
1870 :
1871 0 : deallocate(tend%dtdt, stat=ierr)
1872 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt')
1873 :
1874 0 : deallocate(tend%dudt, stat=ierr)
1875 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dudt')
1876 :
1877 0 : deallocate(tend%dvdt, stat=ierr)
1878 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dvdt')
1879 :
1880 0 : deallocate(tend%flx_net, stat=ierr)
1881 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%flx_net')
1882 :
1883 0 : deallocate(tend%te_tnd, stat=ierr)
1884 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_tnd')
1885 :
1886 0 : deallocate(tend%tw_tnd, stat=ierr)
1887 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%tw_tnd')
1888 0 : end subroutine physics_tend_dealloc
1889 :
1890 : !===============================================================================
1891 :
1892 2099088 : subroutine physics_ptend_alloc(ptend,psetcols)
1893 :
1894 : ! allocate the individual ptend components
1895 :
1896 : type(physics_ptend), intent(inout) :: ptend
1897 :
1898 : integer, intent(in) :: psetcols
1899 :
1900 : integer :: ierr = 0
1901 :
1902 2099088 : ptend%psetcols = psetcols
1903 :
1904 2099088 : if (ptend%ls) then
1905 3984552 : allocate(ptend%s(psetcols,pver), stat=ierr)
1906 1328184 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%s')
1907 :
1908 3984552 : allocate(ptend%hflux_srf(psetcols), stat=ierr)
1909 1328184 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_srf')
1910 :
1911 2656368 : allocate(ptend%hflux_top(psetcols), stat=ierr)
1912 1328184 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_top')
1913 : end if
1914 :
1915 2099088 : if (ptend%lu) then
1916 1430352 : allocate(ptend%u(psetcols,pver), stat=ierr)
1917 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%u')
1918 :
1919 1430352 : allocate(ptend%taux_srf(psetcols), stat=ierr)
1920 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_srf')
1921 :
1922 953568 : allocate(ptend%taux_top(psetcols), stat=ierr)
1923 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_top')
1924 : end if
1925 :
1926 2099088 : if (ptend%lv) then
1927 1430352 : allocate(ptend%v(psetcols,pver), stat=ierr)
1928 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%v')
1929 :
1930 1430352 : allocate(ptend%tauy_srf(psetcols), stat=ierr)
1931 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_srf')
1932 :
1933 953568 : allocate(ptend%tauy_top(psetcols), stat=ierr)
1934 476784 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_top')
1935 : end if
1936 :
1937 22622472 : if (any(ptend%lq)) then
1938 7157952 : allocate(ptend%q(psetcols,pver,pcnst), stat=ierr)
1939 1789488 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%q')
1940 :
1941 5368464 : allocate(ptend%cflx_srf(psetcols,pcnst), stat=ierr)
1942 1789488 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_srf')
1943 :
1944 3578976 : allocate(ptend%cflx_top(psetcols,pcnst), stat=ierr)
1945 1789488 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_top')
1946 : end if
1947 :
1948 2099088 : end subroutine physics_ptend_alloc
1949 :
1950 : !===============================================================================
1951 :
1952 2513952 : subroutine physics_ptend_dealloc(ptend)
1953 :
1954 : ! deallocate the individual ptend components
1955 :
1956 : type(physics_ptend), intent(inout) :: ptend
1957 : integer :: ierr = 0
1958 :
1959 2513952 : ptend%psetcols = 0
1960 :
1961 2513952 : if (allocated(ptend%s)) deallocate(ptend%s, stat=ierr)
1962 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%s')
1963 :
1964 2513952 : if (allocated(ptend%hflux_srf)) deallocate(ptend%hflux_srf, stat=ierr)
1965 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_srf')
1966 :
1967 2513952 : if (allocated(ptend%hflux_top)) deallocate(ptend%hflux_top, stat=ierr)
1968 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_top')
1969 :
1970 2513952 : if (allocated(ptend%u)) deallocate(ptend%u, stat=ierr)
1971 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%u')
1972 :
1973 2513952 : if (allocated(ptend%taux_srf)) deallocate(ptend%taux_srf, stat=ierr)
1974 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_srf')
1975 :
1976 2513952 : if (allocated(ptend%taux_top)) deallocate(ptend%taux_top, stat=ierr)
1977 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_top')
1978 :
1979 2513952 : if (allocated(ptend%v)) deallocate(ptend%v, stat=ierr)
1980 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%v')
1981 :
1982 2513952 : if (allocated(ptend%tauy_srf)) deallocate(ptend%tauy_srf, stat=ierr)
1983 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_srf')
1984 :
1985 2513952 : if (allocated(ptend%tauy_top)) deallocate(ptend%tauy_top, stat=ierr)
1986 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_top')
1987 :
1988 2513952 : if (allocated(ptend%q)) deallocate(ptend%q, stat=ierr)
1989 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%q')
1990 :
1991 2513952 : if (allocated(ptend%cflx_srf)) deallocate(ptend%cflx_srf, stat=ierr)
1992 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_srf')
1993 :
1994 2513952 : if(allocated(ptend%cflx_top)) deallocate(ptend%cflx_top, stat=ierr)
1995 2513952 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_top')
1996 :
1997 2513952 : end subroutine physics_ptend_dealloc
1998 :
1999 0 : end module physics_types
|