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