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 : public physics_state_copy ! copy a physics_state object
36 : public physics_ptend_copy ! copy a physics_ptend object
37 : public physics_ptend_sum ! accumulate physics_ptend objects
38 : public physics_ptend_scale ! Multiply physics_ptend objects by a constant factor.
39 : public physics_tend_init ! initialize a physics_tend object
40 :
41 : public set_state_pdry ! calculate dry air masses in state variable
42 : public set_wet_to_dry
43 : public set_dry_to_wet
44 : public physics_type_alloc
45 :
46 : public physics_state_alloc ! allocate individual components within state
47 : public physics_state_dealloc ! deallocate individual components within state
48 : public physics_tend_alloc ! allocate individual components within tend
49 : public physics_tend_dealloc ! deallocate individual components within tend
50 : public physics_ptend_alloc ! allocate individual components within tend
51 : public physics_ptend_dealloc ! deallocate individual components within tend
52 :
53 : public physics_cnst_limit ! apply limiters to constituents (waccmx)
54 : !-------------------------------------------------------------------------------
55 : integer, parameter, public :: phys_te_idx = 1
56 : integer ,parameter, public :: dyn_te_idx = 2
57 :
58 : type physics_state
59 : integer :: &
60 : lchnk, &! chunk index
61 : ngrdcol, &! -- Grid -- number of active columns (on the grid)
62 : psetcols=0, &! -- -- max number of columns set - if subcols = pcols*psubcols, else = pcols
63 : ncol=0 ! -- -- sum of nsubcol for all ngrdcols - number of active columns
64 : real(r8), dimension(:), allocatable :: &
65 : lat, &! latitude (radians)
66 : lon, &! longitude (radians)
67 : ps, &! surface pressure
68 : psdry, &! dry surface pressure
69 : phis, &! surface geopotential
70 : ulat, &! unique latitudes (radians)
71 : ulon ! unique longitudes (radians)
72 : real(r8), dimension(:,:),allocatable :: &
73 : t, &! temperature (K)
74 : u, &! zonal wind (m/s)
75 : v, &! meridional wind (m/s)
76 : s, &! dry static energy
77 : omega, &! vertical pressure velocity (Pa/s)
78 : pmid, &! midpoint pressure (Pa)
79 : pmiddry, &! midpoint pressure dry (Pa)
80 : pdel, &! layer thickness (Pa)
81 : pdeldry, &! layer thickness dry (Pa)
82 : rpdel, &! reciprocal of layer thickness (Pa)
83 : rpdeldry,&! recipricol layer thickness dry (Pa)
84 : lnpmid, &! ln(pmid)
85 : lnpmiddry,&! log midpoint pressure dry (Pa)
86 : exner, &! inverse exner function w.r.t. surface pressure (ps/p)^(R/cp)
87 : zm ! geopotential height above surface at midpoints (m)
88 :
89 : real(r8), dimension(:,:,:),allocatable :: &
90 : q ! constituent mixing ratio (kg/kg moist or dry air depending on type)
91 :
92 : real(r8), dimension(:,:),allocatable :: &
93 : pint, &! interface pressure (Pa)
94 : pintdry, &! interface pressure dry (Pa)
95 : lnpint, &! ln(pint)
96 : lnpintdry,&! log interface pressure dry (Pa)
97 : zi ! geopotential height above surface at interfaces (m)
98 :
99 : real(r8), dimension(:,:),allocatable :: &
100 : ! Second dimension is (phys_te_idx) CAM physics total energy and
101 : ! (dyn_te_idx) dycore total energy computed in physics
102 : te_ini, &! vertically integrated total (kinetic + static) energy of initial state
103 : te_cur ! vertically integrated total (kinetic + static) energy of current state
104 : real(r8), dimension(:), allocatable :: &
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 1024 : 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 7728 : allocate(phys_state(begchunk:endchunk), stat=ierr)
186 1024 : 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 7728 : allocate(phys_tend(begchunk:endchunk), stat=ierr)
196 1024 : 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 1024 : end subroutine physics_type_alloc
206 : !===============================================================================
207 1833544 : 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, thermodynamic_active_species_num, thermodynamic_active_species_idx
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 : logical :: derive_new_geopotential ! derive new geopotential fields?
235 :
236 3667088 : real(r8) :: zvirv(state%psetcols,pver) ! Local zvir array pointer
237 :
238 1833544 : real(r8),allocatable :: cpairv_loc(:,:)
239 1833544 : 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 1833544 : if(single_column.and.scm_crm_mode) return
256 :
257 :
258 : !-----------------------------------------------------------------------
259 : ! If no fields are set, then return
260 4769896 : if (.not. (any(ptend%lq(:)) .or. ptend%ls .or. ptend%lu .or. ptend%lv)) then
261 656992 : ptend%name = "none"
262 656992 : ptend%psetcols = 0
263 656992 : return
264 : end if
265 :
266 : !-----------------------------------------------------------------------
267 : ! Check that the state/tend/ptend are all dimensioned with the same number of columns
268 1176552 : 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 1176552 : if (present(tend)) then
274 613416 : 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 1176552 : call phys_getopts(state_debug_checks_out=state_debug_checks)
283 :
284 1176552 : ncol = state%ncol
285 :
286 : ! Update u,v fields
287 1176552 : if(ptend%lu) then
288 8959896 : do k = ptend%top_level, ptend%bot_level
289 133724448 : state%u (:ncol,k) = state%u (:ncol,k) + ptend%u(:ncol,k) * dt
290 8628048 : if (present(tend)) &
291 105690504 : tend%dudt(:ncol,k) = tend%dudt(:ncol,k) + ptend%u(:ncol,k)
292 : end do
293 : end if
294 :
295 1176552 : if(ptend%lv) then
296 8959896 : do k = ptend%top_level, ptend%bot_level
297 133724448 : state%v (:ncol,k) = state%v (:ncol,k) + ptend%v(:ncol,k) * dt
298 8628048 : if (present(tend)) &
299 105690504 : 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 1176552 : call cnst_get_ind('CLDICE', ixcldice, abort=.false.)
305 1176552 : 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 1176552 : call cnst_get_ind('NUMICE', ixnumice, abort=.false.)
309 1176552 : call cnst_get_ind('NUMLIQ', ixnumliq, abort=.false.)
310 1176552 : call cnst_get_ind('NUMRAI', ixnumrain, abort=.false.)
311 1176552 : call cnst_get_ind('NUMSNO', ixnumsnow, abort=.false.)
312 :
313 4706208 : do m = 1, pcnst
314 4706208 : if(ptend%lq(m)) then
315 55931472 : do k = ptend%top_level, ptend%bot_level
316 836836272 : 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 2071536 : m /= ixnumrain .and. m /= ixnumsnow ) then
323 2071536 : 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 1176552 : 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 1176552 : if (ixcldliq > 1) then
356 1176552 : 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 2001144 : if ( any(ptend%name == cldlim_names) ) &
362 70392 : call state_cnst_min_nz(1.e-36_r8, ixcldliq, ixnumliq)
363 : end if
364 : end if
365 :
366 1176552 : if (ixcldice > 1) then
367 1176552 : 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 1789968 : if ( any(ptend%name == cldlim_names) ) &
373 70392 : 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 1176552 : 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 1176552 : allocate(cpairv_loc(state%psetcols,pver))
389 1176552 : if (state%psetcols == pcols) then
390 521212536 : 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 1176552 : allocate(rairv_loc(state%psetcols,pver))
397 1176552 : if (state%psetcols == pcols) then
398 521212536 : 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 1176552 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
406 0 : zvirv(:,:) = shr_const_rwv / rairv_loc(:,:) - 1._r8
407 : else
408 521212536 : 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 1176552 : if(ptend%ls) then
416 27965736 : do k = ptend%top_level, ptend%bot_level
417 417382368 : state%t(:ncol,k) = state%t(:ncol,k) + ptend%s(:ncol,k)*dt/cpairv_loc(:ncol,k)
418 26929968 : if (present(tend)) &
419 248223384 : 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 species tendency not 0.
424 1176552 : derive_new_geopotential = .false.
425 1176552 : if(ptend%ls) then
426 : ! Heating tendency not 0
427 1035768 : derive_new_geopotential = .true.
428 : else
429 : ! Check all water species and if there are nonzero tendencies
430 281568 : const_water_loop: do m = dry_air_species_num + 1, thermodynamic_active_species_num
431 281568 : if(ptend%lq(thermodynamic_active_species_idx(m))) then
432 : ! does water species have tendency?
433 140784 : derive_new_geopotential = .true.
434 140784 : exit const_water_loop
435 : endif
436 : enddo const_water_loop
437 : endif
438 :
439 1176552 : if (derive_new_geopotential) then
440 : call geopotential_t ( &
441 : state%lnpint, state%lnpmid, state%pint , state%pmid , state%pdel , state%rpdel , &
442 0 : state%t , state%q(:,:,:), rairv_loc(:,:), gravit , zvirv , &
443 1176552 : state%zi , state%zm , ncol )
444 : ! update dry static energy for use in next process
445 31766904 : do k = ptend%top_level, ptend%bot_level
446 0 : state%s(:ncol,k) = state%t(:ncol,k)*cpairv_loc(:ncol,k) &
447 475290504 : + gravit*state%zm(:ncol,k) + state%phis(:ncol)
448 : end do
449 : end if
450 :
451 1176552 : if (state_debug_checks) call physics_state_check(state, ptend%name)
452 :
453 1176552 : deallocate(cpairv_loc, rairv_loc)
454 :
455 : ! Deallocate ptend
456 1176552 : call physics_ptend_dealloc(ptend)
457 :
458 1176552 : ptend%name = "none"
459 4706208 : ptend%lq(:) = .false.
460 1176552 : ptend%ls = .false.
461 1176552 : ptend%lu = .false.
462 1176552 : ptend%lv = .false.
463 3010096 : ptend%psetcols = 0
464 :
465 : contains
466 :
467 140784 : subroutine state_cnst_min_nz(lim, qix, numix)
468 : ! Small utility function for setting minimum nonzero
469 : ! constituent concentrations.
470 :
471 : ! Lower limit and constituent index
472 : real(r8), intent(in) :: lim
473 : integer, intent(in) :: qix
474 : ! Number concentration that goes with qix.
475 : ! Ignored if <= 0 (and therefore constituent is not present).
476 : integer, intent(in) :: numix
477 :
478 140784 : if (numix > 0) then
479 : ! Where q is too small, zero mass and number
480 : ! concentration.
481 0 : where (state%q(:ncol,:,qix) < lim)
482 0 : state%q(:ncol,:,qix) = 0._r8
483 0 : state%q(:ncol,:,numix) = 0._r8
484 : end where
485 : else
486 : ! If no number index, just do mass.
487 57013152 : where (state%q(:ncol,:,qix) < lim)
488 281568 : state%q(:ncol,:,qix) = 0._r8
489 : end where
490 : end if
491 :
492 1833544 : end subroutine state_cnst_min_nz
493 :
494 :
495 : end subroutine physics_update
496 :
497 : !===============================================================================
498 :
499 1381024 : subroutine physics_state_check(state, name)
500 : !-----------------------------------------------------------------------
501 : ! Check a physics_state object for invalid data (e.g NaNs, negative
502 : ! temperatures).
503 : !-----------------------------------------------------------------------
504 : use shr_infnan_mod, only: assignment(=), &
505 : shr_infnan_posinf, shr_infnan_neginf
506 : use shr_assert_mod, only: shr_assert_in_domain
507 : use constituents, only: pcnst
508 :
509 : !------------------------------Arguments--------------------------------
510 : ! State to check.
511 : type(physics_state), intent(in) :: state
512 : ! Name of the package responsible for this state.
513 : character(len=*), intent(in), optional :: name
514 :
515 : !---------------------------Local storage-------------------------------
516 : ! Shortened name for ncol.
517 : integer :: ncol
518 : ! Double precision positive/negative infinity.
519 : real(r8) :: posinf_r8, neginf_r8
520 : ! Canned message.
521 : character(len=64) :: msg
522 : ! Constituent index
523 : integer :: m
524 :
525 : !-----------------------------------------------------------------------
526 :
527 1381024 : ncol = state%ncol
528 :
529 1381024 : posinf_r8 = shr_infnan_posinf
530 1381024 : neginf_r8 = shr_infnan_neginf
531 :
532 : ! It may be reasonable to check some of the integer components of the
533 : ! state as well, but this is not yet implemented.
534 :
535 : ! Check for NaN first to avoid any IEEE exceptions.
536 :
537 1381024 : if (present(name)) then
538 : msg = "NaN produced in physics_state by package "// &
539 1381024 : trim(name)//"."
540 : else
541 0 : msg = "NaN found in physics_state."
542 : end if
543 :
544 : ! 1-D variables
545 0 : call shr_assert_in_domain(state%ps(:ncol), is_nan=.false., &
546 1381024 : varname="state%ps", msg=msg)
547 0 : call shr_assert_in_domain(state%psdry(:ncol), is_nan=.false., &
548 1381024 : varname="state%psdry", msg=msg)
549 0 : call shr_assert_in_domain(state%phis(:ncol), is_nan=.false., &
550 1381024 : varname="state%phis", msg=msg)
551 0 : call shr_assert_in_domain(state%te_ini(:ncol,:), is_nan=.false., &
552 1381024 : varname="state%te_ini", msg=msg)
553 0 : call shr_assert_in_domain(state%te_cur(:ncol,:), is_nan=.false., &
554 1381024 : varname="state%te_cur", msg=msg)
555 0 : call shr_assert_in_domain(state%tw_ini(:ncol), is_nan=.false., &
556 1381024 : varname="state%tw_ini", msg=msg)
557 0 : call shr_assert_in_domain(state%tw_cur(:ncol), is_nan=.false., &
558 1381024 : varname="state%tw_cur", msg=msg)
559 0 : call shr_assert_in_domain(state%temp_ini(:ncol,:), is_nan=.false., &
560 1381024 : varname="state%temp_ini", msg=msg)
561 0 : call shr_assert_in_domain(state%z_ini(:ncol,:), is_nan=.false., &
562 1381024 : varname="state%z_ini", msg=msg)
563 :
564 : ! 2-D variables (at midpoints)
565 0 : call shr_assert_in_domain(state%t(:ncol,:), is_nan=.false., &
566 1381024 : varname="state%t", msg=msg)
567 0 : call shr_assert_in_domain(state%u(:ncol,:), is_nan=.false., &
568 1381024 : varname="state%u", msg=msg)
569 0 : call shr_assert_in_domain(state%v(:ncol,:), is_nan=.false., &
570 1381024 : varname="state%v", msg=msg)
571 0 : call shr_assert_in_domain(state%s(:ncol,:), is_nan=.false., &
572 1381024 : varname="state%s", msg=msg)
573 0 : call shr_assert_in_domain(state%omega(:ncol,:), is_nan=.false., &
574 1381024 : varname="state%omega", msg=msg)
575 0 : call shr_assert_in_domain(state%pmid(:ncol,:), is_nan=.false., &
576 1381024 : varname="state%pmid", msg=msg)
577 0 : call shr_assert_in_domain(state%pmiddry(:ncol,:), is_nan=.false., &
578 1381024 : varname="state%pmiddry", msg=msg)
579 0 : call shr_assert_in_domain(state%pdel(:ncol,:), is_nan=.false., &
580 1381024 : varname="state%pdel", msg=msg)
581 0 : call shr_assert_in_domain(state%pdeldry(:ncol,:), is_nan=.false., &
582 1381024 : varname="state%pdeldry", msg=msg)
583 0 : call shr_assert_in_domain(state%rpdel(:ncol,:), is_nan=.false., &
584 1381024 : varname="state%rpdel", msg=msg)
585 0 : call shr_assert_in_domain(state%rpdeldry(:ncol,:), is_nan=.false., &
586 1381024 : varname="state%rpdeldry", msg=msg)
587 0 : call shr_assert_in_domain(state%lnpmid(:ncol,:), is_nan=.false., &
588 1381024 : varname="state%lnpmid", msg=msg)
589 0 : call shr_assert_in_domain(state%lnpmiddry(:ncol,:), is_nan=.false., &
590 1381024 : varname="state%lnpmiddry", msg=msg)
591 0 : call shr_assert_in_domain(state%exner(:ncol,:), is_nan=.false., &
592 1381024 : varname="state%exner", msg=msg)
593 0 : call shr_assert_in_domain(state%zm(:ncol,:), is_nan=.false., &
594 1381024 : varname="state%zm", msg=msg)
595 :
596 : ! 2-D variables (at interfaces)
597 0 : call shr_assert_in_domain(state%pint(:ncol,:), is_nan=.false., &
598 1381024 : varname="state%pint", msg=msg)
599 0 : call shr_assert_in_domain(state%pintdry(:ncol,:), is_nan=.false., &
600 1381024 : varname="state%pintdry", msg=msg)
601 0 : call shr_assert_in_domain(state%lnpint(:ncol,:), is_nan=.false., &
602 1381024 : varname="state%lnpint", msg=msg)
603 0 : call shr_assert_in_domain(state%lnpintdry(:ncol,:), is_nan=.false., &
604 1381024 : varname="state%lnpintdry", msg=msg)
605 0 : call shr_assert_in_domain(state%zi(:ncol,:), is_nan=.false., &
606 1381024 : varname="state%zi", msg=msg)
607 :
608 : ! 3-D variables
609 0 : call shr_assert_in_domain(state%q(:ncol,:,:), is_nan=.false., &
610 1381024 : varname="state%q", msg=msg)
611 :
612 : ! Now run other checks (i.e. values are finite and within a range that
613 : ! is physically meaningful).
614 :
615 1381024 : if (present(name)) then
616 : msg = "Invalid value produced in physics_state by package "// &
617 1381024 : trim(name)//"."
618 : else
619 0 : msg = "Invalid value found in physics_state."
620 : end if
621 :
622 : ! 1-D variables
623 0 : call shr_assert_in_domain(state%ps(:ncol), lt=posinf_r8, gt=0._r8, &
624 1381024 : varname="state%ps", msg=msg)
625 0 : call shr_assert_in_domain(state%psdry(:ncol), lt=posinf_r8, gt=0._r8, &
626 1381024 : varname="state%psdry", msg=msg)
627 0 : call shr_assert_in_domain(state%phis(:ncol), lt=posinf_r8, gt=neginf_r8, &
628 1381024 : varname="state%phis", msg=msg)
629 0 : call shr_assert_in_domain(state%te_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
630 1381024 : varname="state%te_ini", msg=msg)
631 0 : call shr_assert_in_domain(state%te_cur(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
632 1381024 : varname="state%te_cur", msg=msg)
633 0 : call shr_assert_in_domain(state%tw_ini(:ncol), lt=posinf_r8, gt=neginf_r8, &
634 1381024 : varname="state%tw_ini", msg=msg)
635 0 : call shr_assert_in_domain(state%tw_cur(:ncol), lt=posinf_r8, gt=neginf_r8, &
636 1381024 : varname="state%tw_cur", msg=msg)
637 0 : call shr_assert_in_domain(state%temp_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
638 1381024 : varname="state%temp_ini", msg=msg)
639 0 : call shr_assert_in_domain(state%z_ini(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
640 1381024 : varname="state%z_ini", msg=msg)
641 :
642 : ! 2-D variables (at midpoints)
643 0 : call shr_assert_in_domain(state%t(:ncol,:), lt=posinf_r8, gt=0._r8, &
644 1381024 : varname="state%t", msg=msg)
645 0 : call shr_assert_in_domain(state%u(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
646 1381024 : varname="state%u", msg=msg)
647 0 : call shr_assert_in_domain(state%v(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
648 1381024 : varname="state%v", msg=msg)
649 0 : call shr_assert_in_domain(state%s(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
650 1381024 : varname="state%s", msg=msg)
651 0 : call shr_assert_in_domain(state%omega(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
652 1381024 : varname="state%omega", msg=msg)
653 0 : call shr_assert_in_domain(state%pmid(:ncol,:), lt=posinf_r8, gt=0._r8, &
654 1381024 : varname="state%pmid", msg=msg)
655 0 : call shr_assert_in_domain(state%pmiddry(:ncol,:), lt=posinf_r8, gt=0._r8, &
656 1381024 : varname="state%pmiddry", msg=msg)
657 0 : call shr_assert_in_domain(state%pdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
658 1381024 : varname="state%pdel", msg=msg)
659 0 : call shr_assert_in_domain(state%pdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
660 1381024 : varname="state%pdeldry", msg=msg)
661 0 : call shr_assert_in_domain(state%rpdel(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
662 1381024 : varname="state%rpdel", msg=msg)
663 0 : call shr_assert_in_domain(state%rpdeldry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
664 1381024 : varname="state%rpdeldry", msg=msg)
665 0 : call shr_assert_in_domain(state%lnpmid(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
666 1381024 : varname="state%lnpmid", msg=msg)
667 0 : call shr_assert_in_domain(state%lnpmiddry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
668 1381024 : varname="state%lnpmiddry", msg=msg)
669 0 : call shr_assert_in_domain(state%exner(:ncol,:), lt=posinf_r8, gt=0._r8, &
670 1381024 : varname="state%exner", msg=msg)
671 0 : call shr_assert_in_domain(state%zm(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
672 1381024 : varname="state%zm", msg=msg)
673 :
674 : ! 2-D variables (at interfaces)
675 0 : call shr_assert_in_domain(state%pint(:ncol,:), lt=posinf_r8, gt=0._r8, &
676 1381024 : varname="state%pint", msg=msg)
677 0 : call shr_assert_in_domain(state%pintdry(:ncol,:), lt=posinf_r8, gt=0._r8, &
678 1381024 : varname="state%pintdry", msg=msg)
679 0 : call shr_assert_in_domain(state%lnpint(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
680 1381024 : varname="state%lnpint", msg=msg)
681 0 : call shr_assert_in_domain(state%lnpintdry(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
682 1381024 : varname="state%lnpintdry", msg=msg)
683 0 : call shr_assert_in_domain(state%zi(:ncol,:), lt=posinf_r8, gt=neginf_r8, &
684 1381024 : varname="state%zi", msg=msg)
685 :
686 : ! 3-D variables
687 5524096 : do m = 1,pcnst
688 0 : call shr_assert_in_domain(state%q(:ncol,:,m), lt=posinf_r8, gt=neginf_r8, &
689 5524096 : varname="state%q ("//trim(cnst_name(m))//")", msg=msg)
690 : end do
691 :
692 1381024 : end subroutine physics_state_check
693 :
694 : !===============================================================================
695 :
696 703920 : subroutine physics_ptend_sum(ptend, ptend_sum, ncol)
697 : !-----------------------------------------------------------------------
698 : ! Add ptend fields to ptend_sum for ptend logical flags = .true.
699 : ! Where ptend logical flags = .false, don't change ptend_sum
700 : !-----------------------------------------------------------------------
701 :
702 : !------------------------------Arguments--------------------------------
703 : type(physics_ptend), intent(in) :: ptend ! New parameterization tendencies
704 : type(physics_ptend), intent(inout) :: ptend_sum ! Sum of incoming ptend_sum and ptend
705 : integer, intent(in) :: ncol ! number of columns
706 :
707 : !---------------------------Local storage-------------------------------
708 : integer :: i,k,m ! column,level,constituent indices
709 : integer :: psetcols ! maximum number of columns
710 : integer :: ierr = 0
711 :
712 : !-----------------------------------------------------------------------
713 703920 : if (ptend%psetcols /= ptend_sum%psetcols) then
714 0 : call endrun('physics_ptend_sum error: ptend and ptend_sum must have the same value for psetcols')
715 : end if
716 :
717 703920 : if (ncol > ptend_sum%psetcols) then
718 0 : call endrun('physics_ptend_sum error: ncol must be less than or equal to psetcols')
719 : end if
720 :
721 703920 : psetcols = ptend_sum%psetcols
722 :
723 703920 : ptend_sum%top_level = ptend%top_level
724 703920 : ptend_sum%bot_level = ptend%bot_level
725 :
726 : ! Update u,v fields
727 703920 : if(ptend%lu) then
728 70392 : if (.not. allocated(ptend_sum%u)) then
729 70392 : allocate(ptend_sum%u(psetcols,pver), stat=ierr)
730 70392 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%u')
731 31183656 : ptend_sum%u=0.0_r8
732 :
733 70392 : allocate(ptend_sum%taux_srf(psetcols), stat=ierr)
734 70392 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_srf')
735 1196664 : ptend_sum%taux_srf=0.0_r8
736 :
737 70392 : allocate(ptend_sum%taux_top(psetcols), stat=ierr)
738 70392 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%taux_top')
739 1196664 : ptend_sum%taux_top=0.0_r8
740 : end if
741 70392 : ptend_sum%lu = .true.
742 :
743 1900584 : do k = ptend%top_level, ptend%bot_level
744 28436184 : do i = 1, ncol
745 28365792 : ptend_sum%u(i,k) = ptend_sum%u(i,k) + ptend%u(i,k)
746 : end do
747 : end do
748 1090992 : do i = 1, ncol
749 1020600 : ptend_sum%taux_srf(i) = ptend_sum%taux_srf(i) + ptend%taux_srf(i)
750 1090992 : ptend_sum%taux_top(i) = ptend_sum%taux_top(i) + ptend%taux_top(i)
751 : end do
752 : end if
753 :
754 703920 : if(ptend%lv) then
755 70392 : if (.not. allocated(ptend_sum%v)) then
756 70392 : allocate(ptend_sum%v(psetcols,pver), stat=ierr)
757 70392 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%v')
758 31183656 : ptend_sum%v=0.0_r8
759 :
760 70392 : allocate(ptend_sum%tauy_srf(psetcols), stat=ierr)
761 70392 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_srf')
762 1196664 : ptend_sum%tauy_srf=0.0_r8
763 :
764 70392 : allocate(ptend_sum%tauy_top(psetcols), stat=ierr)
765 70392 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%tauy_top')
766 1196664 : ptend_sum%tauy_top=0.0_r8
767 : end if
768 70392 : ptend_sum%lv = .true.
769 :
770 1900584 : do k = ptend%top_level, ptend%bot_level
771 28436184 : do i = 1, ncol
772 28365792 : ptend_sum%v(i,k) = ptend_sum%v(i,k) + ptend%v(i,k)
773 : end do
774 : end do
775 1090992 : do i = 1, ncol
776 1020600 : ptend_sum%tauy_srf(i) = ptend_sum%tauy_srf(i) + ptend%tauy_srf(i)
777 1090992 : ptend_sum%tauy_top(i) = ptend_sum%tauy_top(i) + ptend%tauy_top(i)
778 : end do
779 : end if
780 :
781 :
782 703920 : if(ptend%ls) then
783 492744 : if (.not. allocated(ptend_sum%s)) then
784 211176 : allocate(ptend_sum%s(psetcols,pver), stat=ierr)
785 211176 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%s')
786 93550968 : ptend_sum%s=0.0_r8
787 :
788 211176 : allocate(ptend_sum%hflux_srf(psetcols), stat=ierr)
789 211176 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_srf')
790 3589992 : ptend_sum%hflux_srf=0.0_r8
791 :
792 211176 : allocate(ptend_sum%hflux_top(psetcols), stat=ierr)
793 211176 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%hflux_top')
794 3589992 : ptend_sum%hflux_top=0.0_r8
795 : end if
796 492744 : ptend_sum%ls = .true.
797 :
798 13304088 : do k = ptend%top_level, ptend%bot_level
799 199053288 : do i = 1, ncol
800 198560544 : ptend_sum%s(i,k) = ptend_sum%s(i,k) + ptend%s(i,k)
801 : end do
802 : end do
803 7636944 : do i = 1, ncol
804 7144200 : ptend_sum%hflux_srf(i) = ptend_sum%hflux_srf(i) + ptend%hflux_srf(i)
805 7636944 : ptend_sum%hflux_top(i) = ptend_sum%hflux_top(i) + ptend%hflux_top(i)
806 : end do
807 : end if
808 :
809 1126272 : if (any(ptend%lq(:))) then
810 :
811 633528 : if (.not. allocated(ptend_sum%q)) then
812 211176 : allocate(ptend_sum%q(psetcols,pver,pcnst), stat=ierr)
813 211176 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%q')
814 280864080 : ptend_sum%q=0.0_r8
815 :
816 211176 : allocate(ptend_sum%cflx_srf(psetcols,pcnst), stat=ierr)
817 211176 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_srf')
818 10981152 : ptend_sum%cflx_srf=0.0_r8
819 :
820 211176 : allocate(ptend_sum%cflx_top(psetcols,pcnst), stat=ierr)
821 211176 : if ( ierr /= 0 ) call endrun('physics_ptend_sum error: allocation error for ptend_sum%cflx_top')
822 10981152 : ptend_sum%cflx_top=0.0_r8
823 : end if
824 :
825 2534112 : do m = 1, pcnst
826 2534112 : if(ptend%lq(m)) then
827 1196664 : ptend_sum%lq(m) = .true.
828 32309928 : do k = ptend%top_level, ptend%bot_level
829 483415128 : do i = 1,ncol
830 482218464 : ptend_sum%q(i,k,m) = ptend_sum%q(i,k,m) + ptend%q(i,k,m)
831 : end do
832 : end do
833 18546864 : do i = 1,ncol
834 17350200 : ptend_sum%cflx_srf(i,m) = ptend_sum%cflx_srf(i,m) + ptend%cflx_srf(i,m)
835 18546864 : ptend_sum%cflx_top(i,m) = ptend_sum%cflx_top(i,m) + ptend%cflx_top(i,m)
836 : end do
837 : end if
838 : end do
839 :
840 : end if
841 :
842 703920 : end subroutine physics_ptend_sum
843 :
844 : !===============================================================================
845 :
846 0 : subroutine physics_ptend_scale(ptend, fac, ncol)
847 : !-----------------------------------------------------------------------
848 : ! Scale ptend fields for ptend logical flags = .true.
849 : ! Where ptend logical flags = .false, don't change ptend.
850 : !
851 : ! Assumes that input ptend is valid (e.g. that
852 : ! ptend%lu .eqv. allocated(ptend%u)), and therefore
853 : ! does not check allocation status of individual arrays.
854 : !-----------------------------------------------------------------------
855 :
856 : !------------------------------Arguments--------------------------------
857 : type(physics_ptend), intent(inout) :: ptend ! Incoming ptend
858 : real(r8), intent(in) :: fac ! Factor to multiply ptend by.
859 : integer, intent(in) :: ncol ! number of columns
860 :
861 : !---------------------------Local storage-------------------------------
862 : integer :: m ! constituent index
863 :
864 : !-----------------------------------------------------------------------
865 :
866 : ! Update u,v fields
867 0 : if (ptend%lu) &
868 : call multiply_tendency(ptend%u, &
869 0 : ptend%taux_srf, ptend%taux_top)
870 :
871 0 : if (ptend%lv) &
872 : call multiply_tendency(ptend%v, &
873 0 : ptend%tauy_srf, ptend%tauy_top)
874 :
875 : ! Heat
876 0 : if (ptend%ls) &
877 : call multiply_tendency(ptend%s, &
878 0 : ptend%hflux_srf, ptend%hflux_top)
879 :
880 : ! Update constituents
881 0 : do m = 1, pcnst
882 0 : if (ptend%lq(m)) &
883 0 : call multiply_tendency(ptend%q(:,:,m), &
884 0 : ptend%cflx_srf(:,m), ptend%cflx_top(:,m))
885 : end do
886 :
887 :
888 : contains
889 :
890 0 : subroutine multiply_tendency(tend_arr, flx_srf, flx_top)
891 : real(r8), intent(inout) :: tend_arr(:,:) ! Tendency array (pcols, plev)
892 : real(r8), intent(inout) :: flx_srf(:) ! Surface flux (or stress)
893 : real(r8), intent(inout) :: flx_top(:) ! Top-of-model flux (or stress)
894 :
895 : integer :: k
896 :
897 0 : do k = ptend%top_level, ptend%bot_level
898 0 : tend_arr(:ncol,k) = tend_arr(:ncol,k) * fac
899 : end do
900 0 : flx_srf(:ncol) = flx_srf(:ncol) * fac
901 0 : flx_top(:ncol) = flx_top(:ncol) * fac
902 :
903 0 : end subroutine multiply_tendency
904 :
905 : end subroutine physics_ptend_scale
906 :
907 : !===============================================================================
908 :
909 0 : subroutine physics_ptend_copy(ptend, ptend_cp)
910 :
911 : !-----------------------------------------------------------------------
912 : ! Copy a physics_ptend object. Allocate ptend_cp internally before copy.
913 : !-----------------------------------------------------------------------
914 :
915 : type(physics_ptend), intent(in) :: ptend ! ptend source
916 : type(physics_ptend), intent(out) :: ptend_cp ! copy of ptend
917 :
918 : !-----------------------------------------------------------------------
919 :
920 0 : ptend_cp%name = ptend%name
921 :
922 0 : ptend_cp%ls = ptend%ls
923 0 : ptend_cp%lu = ptend%lu
924 0 : ptend_cp%lv = ptend%lv
925 0 : ptend_cp%lq = ptend%lq
926 :
927 0 : call physics_ptend_alloc(ptend_cp, ptend%psetcols)
928 :
929 0 : ptend_cp%top_level = ptend%top_level
930 0 : ptend_cp%bot_level = ptend%bot_level
931 :
932 0 : if (ptend_cp%ls) then
933 0 : ptend_cp%s = ptend%s
934 0 : ptend_cp%hflux_srf = ptend%hflux_srf
935 0 : ptend_cp%hflux_top = ptend%hflux_top
936 : end if
937 :
938 0 : if (ptend_cp%lu) then
939 0 : ptend_cp%u = ptend%u
940 0 : ptend_cp%taux_srf = ptend%taux_srf
941 0 : ptend_cp%taux_top = ptend%taux_top
942 : end if
943 :
944 0 : if (ptend_cp%lv) then
945 0 : ptend_cp%v = ptend%v
946 0 : ptend_cp%tauy_srf = ptend%tauy_srf
947 0 : ptend_cp%tauy_top = ptend%tauy_top
948 : end if
949 :
950 0 : if (any(ptend_cp%lq(:))) then
951 0 : ptend_cp%q = ptend%q
952 0 : ptend_cp%cflx_srf = ptend%cflx_srf
953 0 : ptend_cp%cflx_top = ptend%cflx_top
954 : end if
955 :
956 0 : end subroutine physics_ptend_copy
957 :
958 : !===============================================================================
959 :
960 1176552 : subroutine physics_ptend_reset(ptend)
961 : !-----------------------------------------------------------------------
962 : ! Reset the parameterization tendency structure to "empty"
963 : !-----------------------------------------------------------------------
964 :
965 : !------------------------------Arguments--------------------------------
966 : type(physics_ptend), intent(inout) :: ptend ! Parameterization tendencies
967 : !-----------------------------------------------------------------------
968 :
969 1176552 : if(ptend%ls) then
970 396477912 : ptend%s = 0._r8
971 15214728 : ptend%hflux_srf = 0._r8
972 15214728 : ptend%hflux_top = 0._r8
973 : endif
974 1176552 : if(ptend%lu) then
975 115825008 : ptend%u = 0._r8
976 4444752 : ptend%taux_srf = 0._r8
977 4444752 : ptend%taux_top = 0._r8
978 : endif
979 1176552 : if(ptend%lv) then
980 115825008 : ptend%v = 0._r8
981 4444752 : ptend%tauy_srf = 0._r8
982 4444752 : ptend%tauy_top = 0._r8
983 : endif
984 2423496 : if(any (ptend%lq(:))) then
985 1105623680 : ptend%q = 0._r8
986 43227392 : ptend%cflx_srf = 0._r8
987 43227392 : ptend%cflx_top = 0._r8
988 : end if
989 :
990 1176552 : ptend%top_level = 1
991 1176552 : ptend%bot_level = pver
992 :
993 1176552 : return
994 : end subroutine physics_ptend_reset
995 :
996 : !===============================================================================
997 6569920 : subroutine physics_ptend_init(ptend, psetcols, name, ls, lu, lv, lq)
998 : !-----------------------------------------------------------------------
999 : ! Allocate the fields in the structure which are specified.
1000 : ! Initialize the parameterization tendency structure to "empty"
1001 : !-----------------------------------------------------------------------
1002 :
1003 : !------------------------------Arguments--------------------------------
1004 : type(physics_ptend), intent(out) :: ptend ! Parameterization tendencies
1005 : integer, intent(in) :: psetcols ! maximum number of columns
1006 : character(len=*) :: name ! optional name of parameterization which produced tendencies.
1007 : logical, optional :: ls ! if true, then fields to support dsdt are allocated
1008 : logical, optional :: lu ! if true, then fields to support dudt are allocated
1009 : logical, optional :: lv ! if true, then fields to support dvdt are allocated
1010 : logical, dimension(pcnst),optional :: lq ! if true, then fields to support dqdt are allocated
1011 :
1012 : !-----------------------------------------------------------------------
1013 :
1014 1642480 : if (allocated(ptend%s)) then
1015 0 : call endrun(' physics_ptend_init: ptend should not be allocated before calling this routine')
1016 : end if
1017 :
1018 1642480 : ptend%name = name
1019 1642480 : ptend%psetcols = psetcols
1020 :
1021 : ! If no fields being stored, initialize all values to appropriate nulls and return
1022 1642480 : if (.not. present(ls) .and. .not. present(lu) .and. .not. present(lv) .and. .not. present(lq) ) then
1023 465928 : ptend%ls = .false.
1024 465928 : ptend%lu = .false.
1025 465928 : ptend%lv = .false.
1026 1863712 : ptend%lq(:) = .false.
1027 465928 : ptend%top_level = 1
1028 465928 : ptend%bot_level = pver
1029 465928 : return
1030 : end if
1031 :
1032 1176552 : if (present(ls)) then
1033 894984 : ptend%ls = ls
1034 : else
1035 281568 : ptend%ls = .false.
1036 : end if
1037 :
1038 1176552 : if (present(lu)) then
1039 261456 : ptend%lu = lu
1040 : else
1041 915096 : ptend%lu = .false.
1042 : end if
1043 :
1044 1176552 : if (present(lv)) then
1045 261456 : ptend%lv = lv
1046 : else
1047 915096 : ptend%lv = .false.
1048 : end if
1049 :
1050 1176552 : if (present(lq)) then
1051 3606752 : ptend%lq(:) = lq(:)
1052 : else
1053 1099456 : ptend%lq(:) = .false.
1054 : end if
1055 :
1056 1176552 : call physics_ptend_alloc(ptend, psetcols)
1057 :
1058 1176552 : call physics_ptend_reset(ptend)
1059 :
1060 1176552 : return
1061 1642480 : end subroutine physics_ptend_init
1062 :
1063 : !===============================================================================
1064 :
1065 6704 : subroutine physics_state_set_grid(lchnk, phys_state)
1066 : !-----------------------------------------------------------------------
1067 : ! Set the grid components of the physics_state object
1068 : !-----------------------------------------------------------------------
1069 :
1070 : integer, intent(in) :: lchnk
1071 : type(physics_state), intent(inout) :: phys_state
1072 :
1073 : ! local variables
1074 : integer :: i, ncol
1075 : real(r8) :: rlon(pcols)
1076 : real(r8) :: rlat(pcols)
1077 :
1078 : !-----------------------------------------------------------------------
1079 : ! get_ncols_p requires a state which does not have sub-columns
1080 6704 : if (phys_state%psetcols .ne. pcols) then
1081 0 : call endrun('physics_state_set_grid: cannot pass in a state which has sub-columns')
1082 : end if
1083 :
1084 6704 : ncol = get_ncols_p(lchnk)
1085 :
1086 6704 : if(ncol<=0) then
1087 0 : write(iulog,*) lchnk, ncol
1088 0 : call endrun('physics_state_set_grid')
1089 : end if
1090 :
1091 6704 : call get_rlon_all_p(lchnk, ncol, rlon)
1092 6704 : call get_rlat_all_p(lchnk, ncol, rlat)
1093 6704 : phys_state%ncol = ncol
1094 6704 : phys_state%lchnk = lchnk
1095 103904 : do i=1,ncol
1096 97200 : phys_state%lat(i) = rlat(i)
1097 103904 : phys_state%lon(i) = rlon(i)
1098 : end do
1099 6704 : call init_geo_unique(phys_state,ncol)
1100 :
1101 6704 : end subroutine physics_state_set_grid
1102 :
1103 :
1104 6704 : subroutine init_geo_unique(phys_state,ncol)
1105 : integer, intent(in) :: ncol
1106 : type(physics_state), intent(inout) :: phys_state
1107 : logical :: match
1108 : integer :: i, j, ulatcnt, uloncnt
1109 :
1110 113968 : phys_state%ulat=-999._r8
1111 113968 : phys_state%ulon=-999._r8
1112 113968 : phys_state%latmapback=0
1113 113968 : phys_state%lonmapback=0
1114 6704 : match=.false.
1115 6704 : ulatcnt=0
1116 6704 : uloncnt=0
1117 6704 : match=.false.
1118 103904 : do i=1,ncol
1119 795030 : do j=1,ulatcnt
1120 795030 : if(phys_state%lat(i) .eq. phys_state%ulat(j)) then
1121 1790 : match=.true.
1122 1790 : phys_state%latmapback(i)=j
1123 : end if
1124 : end do
1125 97200 : if(.not. match) then
1126 95410 : ulatcnt=ulatcnt+1
1127 95410 : phys_state%ulat(ulatcnt)=phys_state%lat(i)
1128 95410 : phys_state%latmapback(i)=ulatcnt
1129 : end if
1130 :
1131 97200 : match=.false.
1132 586682 : do j=1,uloncnt
1133 586682 : if(phys_state%lon(i) .eq. phys_state%ulon(j)) then
1134 37334 : match=.true.
1135 37334 : phys_state%lonmapback(i)=j
1136 : end if
1137 : end do
1138 97200 : if(.not. match) then
1139 59866 : uloncnt=uloncnt+1
1140 59866 : phys_state%ulon(uloncnt)=phys_state%lon(i)
1141 59866 : phys_state%lonmapback(i)=uloncnt
1142 : end if
1143 103904 : match=.false.
1144 :
1145 : end do
1146 6704 : phys_state%uloncnt=uloncnt
1147 6704 : phys_state%ulatcnt=ulatcnt
1148 :
1149 6704 : call get_gcol_all_p(phys_state%lchnk,pcols,phys_state%cid)
1150 :
1151 :
1152 6704 : end subroutine init_geo_unique
1153 :
1154 : !===============================================================================
1155 0 : subroutine physics_cnst_limit(state)
1156 : type(physics_state), intent(inout) :: state
1157 :
1158 : integer :: i,k, ncol
1159 :
1160 : real(r8) :: mmrSum_O_O2_H ! Sum of mass mixing ratios for O, O2, and H
1161 : real(r8), parameter :: mmrMin=1.e-20_r8 ! lower limit of o2, o, and h mixing ratios
1162 : real(r8), parameter :: N2mmrMin=1.e-6_r8 ! lower limit of N2 mass mixing ratio
1163 : real(r8), parameter :: H2lim=6.e-5_r8 ! H2 limiter: 10x global H2 MMR (Roble, 1995)
1164 : integer :: ixo, ixo2, ixh, ixh2
1165 :
1166 0 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
1167 0 : call cnst_get_ind('O', ixo)
1168 0 : call cnst_get_ind('O2', ixo2)
1169 0 : call cnst_get_ind('H', ixh)
1170 0 : call cnst_get_ind('H2', ixh2)
1171 :
1172 0 : ncol = state%ncol
1173 :
1174 : !------------------------------------------------------------
1175 : ! Ensure N2 = 1-(O2 + O + H) mmr is greater than 0
1176 : ! Check for unusually large H2 values and set to lower value.
1177 : !------------------------------------------------------------
1178 :
1179 0 : do k=1,pver
1180 0 : do i=1,ncol
1181 :
1182 0 : if (state%q(i,k,ixo) < mmrMin) state%q(i,k,ixo) = mmrMin
1183 0 : if (state%q(i,k,ixo2) < mmrMin) state%q(i,k,ixo2) = mmrMin
1184 :
1185 0 : mmrSum_O_O2_H = state%q(i,k,ixo)+state%q(i,k,ixo2)+state%q(i,k,ixh)
1186 :
1187 0 : if ((1._r8-mmrMin-mmrSum_O_O2_H) < 0._r8) then
1188 :
1189 0 : state%q(i,k,ixo) = state%q(i,k,ixo) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
1190 :
1191 0 : state%q(i,k,ixo2) = state%q(i,k,ixo2) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
1192 :
1193 0 : state%q(i,k,ixh) = state%q(i,k,ixh) * (1._r8 - N2mmrMin) / mmrSum_O_O2_H
1194 :
1195 : endif
1196 :
1197 0 : if(state%q(i,k,ixh2) > H2lim) then
1198 0 : state%q(i,k,ixh2) = H2lim
1199 : endif
1200 :
1201 : end do
1202 : end do
1203 :
1204 : end if
1205 0 : end subroutine physics_cnst_limit
1206 :
1207 : !===============================================================================
1208 0 : subroutine physics_dme_adjust(state, tend, qini, liqini, iceini, dt)
1209 : use air_composition, only: dry_air_species_num,thermodynamic_active_species_num
1210 : use air_composition, only: thermodynamic_active_species_idx
1211 : use dycore, only: dycore_is
1212 : use dme_adjust, only: dme_adjust_run
1213 : use ccpp_constituent_prop_mod, only: ccpp_const_props
1214 : !-----------------------------------------------------------------------
1215 : !
1216 : ! Purpose: Adjust the dry mass in each layer back to the value of physics input state
1217 : !
1218 : ! Method: Conserve the integrated mass, momentum and total energy in each layer
1219 : ! by scaling the specific mass of consituents, specific momentum (velocity)
1220 : ! and specific total energy by the relative change in layer mass. Solve for
1221 : ! the new temperature by subtracting the new kinetic energy from total energy
1222 : ! and inverting the hydrostatic equation
1223 : !
1224 : ! The mass in each layer is modified, changing the relationship of the layer
1225 : ! interfaces and midpoints to the surface pressure. The result is no longer in
1226 : ! the original hybrid coordinate.
1227 : !
1228 : ! Author: Byron Boville
1229 :
1230 : ! !REVISION HISTORY:
1231 : ! 03.03.28 Boville Created, partly from code by Lin in p_d_adjust
1232 : !
1233 : !-----------------------------------------------------------------------
1234 :
1235 : implicit none
1236 : !
1237 : ! Arguments
1238 : !
1239 : type(physics_state), intent(inout) :: state
1240 : type(physics_tend ), intent(inout) :: tend
1241 : real(r8), intent(in ) :: qini(pcols,pver) ! initial specific humidity
1242 : real(r8), intent(in ) :: liqini(pcols,pver) ! initial total liquid
1243 : real(r8), intent(in ) :: iceini(pcols,pver) ! initial total ice
1244 : real(r8), intent(in ) :: dt ! model physics timestep
1245 : !
1246 : !---------------------------Local workspace-----------------------------
1247 : !
1248 : integer :: lchnk ! chunk identifier
1249 : integer :: ncol ! number of atmospheric columns
1250 : integer :: k,m ! Longitude, level indices
1251 : real(r8) :: fdq(pcols) ! mass adjustment factor
1252 : real(r8) :: te(pcols) ! total energy in a layer
1253 : real(r8) :: utmp(pcols) ! temp variable for recalculating the initial u values
1254 : real(r8) :: vtmp(pcols) ! temp variable for recalculating the initial v values
1255 :
1256 : real(r8) :: zvirv(pcols,pver) ! Local zvir array pointer
1257 :
1258 : real(r8) :: tot_water (pcols,2) ! total water (initial, present)
1259 : real(r8) :: tot_water_chg(pcols) ! total water change
1260 :
1261 :
1262 : real(r8),allocatable :: cpairv_loc(:,:)
1263 : integer :: m_cnst
1264 :
1265 : logical :: is_dycore_moist
1266 :
1267 : character(len=512) :: errmsg
1268 : integer :: errflg
1269 :
1270 : !
1271 : !-----------------------------------------------------------------------
1272 :
1273 0 : if (state%psetcols .ne. pcols) then
1274 0 : call endrun('physics_dme_adjust: cannot pass in a state which has sub-columns')
1275 : end if
1276 :
1277 0 : lchnk = state%lchnk
1278 0 : ncol = state%ncol
1279 :
1280 : !
1281 : ! original code for backwards compatability with FV
1282 : !
1283 0 : if (.not.(dycore_is('MPAS') .or. dycore_is('SE'))) then
1284 0 : do k = 1, pver
1285 :
1286 : ! adjust dry mass in each layer back to input value, while conserving
1287 : ! constituents, momentum, and total energy
1288 0 : state%ps(:ncol) = state%pint(:ncol,1)
1289 :
1290 : ! adjusment factor is just change in water vapor
1291 0 : fdq(:ncol) = 1._r8 + state%q(:ncol,k,1) - qini(:ncol,k)
1292 :
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 : end do
1304 : else
1305 0 : is_dycore_moist = .true.
1306 0 : call dme_adjust_run (state%ncol, pver, pcnst, state%ps(:ncol), state%pint(:ncol,:), state%pdel(:ncol,:), &
1307 0 : state%lnpint(:ncol,:), state%rpdel(:ncol,:), &
1308 0 : ccpp_const_props, state%q(:ncol,:,:), qini(:ncol,:), liqini(:ncol,:), iceini(:ncol,:), &
1309 0 : is_dycore_moist, errmsg, errflg)
1310 0 : if (errflg /= 0) then
1311 0 : call endrun('physics_dme_adjust: '//errmsg)
1312 : end if
1313 : endif
1314 0 : if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then
1315 0 : zvirv(:,:) = shr_const_rwv / rairv(:,:,state%lchnk) - 1._r8
1316 : else
1317 0 : zvirv(:,:) = zvir
1318 : endif
1319 :
1320 0 : end subroutine physics_dme_adjust
1321 :
1322 : !-----------------------------------------------------------------------
1323 :
1324 : !===============================================================================
1325 274864 : subroutine physics_state_copy(state_in, state_out)
1326 :
1327 : use ppgrid, only: pver, pverp
1328 : use constituents, only: pcnst
1329 :
1330 : implicit none
1331 :
1332 : !
1333 : ! Arguments
1334 : !
1335 : type(physics_state), intent(in) :: state_in
1336 : type(physics_state), intent(out) :: state_out
1337 :
1338 : !
1339 : ! Local variables
1340 : !
1341 : integer i, k, m, ncol
1342 :
1343 : ! Allocate state_out with same subcol dimension as state_in
1344 274864 : call physics_state_alloc ( state_out, state_in%lchnk, state_in%psetcols)
1345 :
1346 274864 : ncol = state_in%ncol
1347 :
1348 274864 : state_out%psetcols = state_in%psetcols
1349 274864 : state_out%ngrdcol = state_in%ngrdcol
1350 274864 : state_out%lchnk = state_in%lchnk
1351 274864 : state_out%ncol = state_in%ncol
1352 274864 : state_out%count = state_in%count
1353 :
1354 4260064 : do i = 1, ncol
1355 3985200 : state_out%lat(i) = state_in%lat(i)
1356 3985200 : state_out%lon(i) = state_in%lon(i)
1357 3985200 : state_out%ps(i) = state_in%ps(i)
1358 4260064 : state_out%phis(i) = state_in%phis(i)
1359 : end do
1360 8794992 : state_out%te_ini(:ncol,:) = state_in%te_ini(:ncol,:)
1361 8794992 : state_out%te_cur(:ncol,:) = state_in%te_cur(:ncol,:)
1362 4260064 : state_out%tw_ini(:ncol) = state_in%tw_ini(:ncol)
1363 4260064 : state_out%tw_cur(:ncol) = state_in%tw_cur(:ncol)
1364 :
1365 7421328 : do k = 1, pver
1366 111036528 : do i = 1, ncol
1367 103615200 : state_out%temp_ini(i,k) = state_in%temp_ini(i,k)
1368 103615200 : state_out%z_ini(i,k) = state_in%z_ini(i,k)
1369 103615200 : state_out%t(i,k) = state_in%t(i,k)
1370 103615200 : state_out%u(i,k) = state_in%u(i,k)
1371 103615200 : state_out%v(i,k) = state_in%v(i,k)
1372 103615200 : state_out%s(i,k) = state_in%s(i,k)
1373 103615200 : state_out%omega(i,k) = state_in%omega(i,k)
1374 103615200 : state_out%pmid(i,k) = state_in%pmid(i,k)
1375 103615200 : state_out%pdel(i,k) = state_in%pdel(i,k)
1376 103615200 : state_out%rpdel(i,k) = state_in%rpdel(i,k)
1377 103615200 : state_out%lnpmid(i,k) = state_in%lnpmid(i,k)
1378 103615200 : state_out%exner(i,k) = state_in%exner(i,k)
1379 110761664 : state_out%zm(i,k) = state_in%zm(i,k)
1380 : end do
1381 : end do
1382 :
1383 7696192 : do k = 1, pverp
1384 115296592 : do i = 1, ncol
1385 107600400 : state_out%pint(i,k) = state_in%pint(i,k)
1386 107600400 : state_out%lnpint(i,k) = state_in%lnpint(i,k)
1387 115021728 : state_out%zi(i,k) = state_in% zi(i,k)
1388 : end do
1389 : end do
1390 :
1391 :
1392 4260064 : do i = 1, ncol
1393 4260064 : state_out%psdry(i) = state_in%psdry(i)
1394 : end do
1395 7421328 : do k = 1, pver
1396 111036528 : do i = 1, ncol
1397 103615200 : state_out%lnpmiddry(i,k) = state_in%lnpmiddry(i,k)
1398 103615200 : state_out%pmiddry(i,k) = state_in%pmiddry(i,k)
1399 103615200 : state_out%pdeldry(i,k) = state_in%pdeldry(i,k)
1400 110761664 : state_out%rpdeldry(i,k) = state_in%rpdeldry(i,k)
1401 : end do
1402 : end do
1403 7696192 : do k = 1, pverp
1404 115296592 : do i = 1, ncol
1405 107600400 : state_out%pintdry(i,k) = state_in%pintdry(i,k)
1406 115021728 : state_out%lnpintdry(i,k) = state_in%lnpintdry(i,k)
1407 : end do
1408 : end do
1409 :
1410 1099456 : do m = 1, pcnst
1411 22538848 : do k = 1, pver
1412 333109584 : do i = 1, ncol
1413 332284992 : state_out%q(i,k,m) = state_in%q(i,k,m)
1414 : end do
1415 : end do
1416 : end do
1417 :
1418 274864 : end subroutine physics_state_copy
1419 : !===============================================================================
1420 :
1421 0 : subroutine physics_tend_init(tend)
1422 :
1423 : implicit none
1424 :
1425 : !
1426 : ! Arguments
1427 : !
1428 : type(physics_tend), intent(inout) :: tend
1429 :
1430 : !
1431 : ! Local variables
1432 : !
1433 :
1434 0 : if (.not. allocated(tend%dtdt)) then
1435 0 : call endrun('physics_tend_init: tend must be allocated before it can be initialized')
1436 : end if
1437 :
1438 0 : tend%dtdt = 0._r8
1439 0 : tend%dudt = 0._r8
1440 0 : tend%dvdt = 0._r8
1441 0 : tend%flx_net = 0._r8
1442 0 : tend%te_tnd = 0._r8
1443 0 : tend%tw_tnd = 0._r8
1444 :
1445 0 : end subroutine physics_tend_init
1446 :
1447 : !===============================================================================
1448 :
1449 0 : subroutine set_state_pdry (state,pdeld_calc)
1450 :
1451 : use ppgrid, only: pver
1452 : implicit none
1453 :
1454 : type(physics_state), intent(inout) :: state
1455 : logical, optional, intent(in) :: pdeld_calc ! .true. do calculate pdeld [default]
1456 : ! .false. don't calculate pdeld
1457 : integer ncol
1458 : integer k
1459 : logical do_pdeld_calc
1460 :
1461 0 : if ( present(pdeld_calc) ) then
1462 0 : do_pdeld_calc = pdeld_calc
1463 : else
1464 0 : do_pdeld_calc = .true.
1465 : endif
1466 :
1467 0 : ncol = state%ncol
1468 :
1469 :
1470 0 : state%psdry(:ncol) = state%pint(:ncol,1)
1471 0 : state%pintdry(:ncol,1) = state%pint(:ncol,1)
1472 :
1473 0 : if (do_pdeld_calc) then
1474 0 : do k = 1, pver
1475 0 : state%pdeldry(:ncol,k) = state%pdel(:ncol,k)*(1._r8-state%q(:ncol,k,1))
1476 : end do
1477 : endif
1478 0 : do k = 1, pver
1479 0 : state%pintdry(:ncol,k+1) = state%pintdry(:ncol,k)+state%pdeldry(:ncol,k)
1480 0 : state%pmiddry(:ncol,k) = (state%pintdry(:ncol,k+1)+state%pintdry(:ncol,k))/2._r8
1481 0 : state%psdry(:ncol) = state%psdry(:ncol) + state%pdeldry(:ncol,k)
1482 : end do
1483 :
1484 0 : state%rpdeldry(:ncol,:) = 1._r8/state%pdeldry(:ncol,:)
1485 0 : state%lnpmiddry(:ncol,:) = log(state%pmiddry(:ncol,:))
1486 0 : state%lnpintdry(:ncol,:) = log(state%pintdry(:ncol,:))
1487 :
1488 0 : end subroutine set_state_pdry
1489 :
1490 : !===============================================================================
1491 :
1492 0 : subroutine set_wet_to_dry(state, convert_cnst_type)
1493 :
1494 : ! Convert mixing ratios from a wet to dry basis for constituents of type
1495 : ! convert_cnst_type. Constituents are given a type when they are added
1496 : ! to the constituent array by a call to cnst_add during the register
1497 : ! phase of initialization. There are two constituent types: 'wet' for
1498 : ! water species and 'dry' for non-water species.
1499 :
1500 : use constituents, only: pcnst, cnst_type
1501 :
1502 : type(physics_state), intent(inout) :: state
1503 : character(len=3), intent(in) :: convert_cnst_type
1504 :
1505 : ! local variables
1506 : integer m, ncol
1507 : character(len=*), parameter :: sub = 'set_wet_to_dry'
1508 : !-----------------------------------------------------------------------------
1509 :
1510 : ! check input
1511 0 : if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then
1512 0 : write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type
1513 0 : call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type)
1514 : end if
1515 :
1516 0 : ncol = state%ncol
1517 :
1518 0 : do m = 1, pcnst
1519 0 : if (cnst_type(m) == convert_cnst_type) then
1520 0 : state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdel(:ncol,:)/state%pdeldry(:ncol,:)
1521 : end if
1522 : end do
1523 :
1524 0 : end subroutine set_wet_to_dry
1525 :
1526 : !===============================================================================
1527 :
1528 0 : subroutine set_dry_to_wet(state, convert_cnst_type)
1529 :
1530 : ! Convert mixing ratios from a dry to wet basis for constituents of type
1531 : ! convert_cnst_type. Constituents are given a type when they are added
1532 : ! to the constituent array by a call to cnst_add during the register
1533 : ! phase of initialization. There are two constituent types: 'wet' for
1534 : ! water species and 'dry' for non-water species.
1535 :
1536 : use constituents, only: pcnst, cnst_type
1537 :
1538 : type(physics_state), intent(inout) :: state
1539 : character(len=3), intent(in) :: convert_cnst_type
1540 :
1541 : ! local variables
1542 : integer m, ncol
1543 : character(len=*), parameter :: sub = 'set_dry_to_wet'
1544 : !-----------------------------------------------------------------------------
1545 :
1546 : ! check input
1547 0 : if (.not.(convert_cnst_type == 'wet' .or. convert_cnst_type == 'dry')) then
1548 0 : write(iulog,*) sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type
1549 0 : call endrun(sub//': FATAL: convert_cnst_type not recognized: '//convert_cnst_type)
1550 : end if
1551 :
1552 0 : ncol = state%ncol
1553 :
1554 0 : do m = 1, pcnst
1555 0 : if (cnst_type(m) == convert_cnst_type) then
1556 0 : state%q(:ncol,:,m) = state%q(:ncol,:,m)*state%pdeldry(:ncol,:)/state%pdel(:ncol,:)
1557 : end if
1558 : end do
1559 :
1560 0 : end subroutine set_dry_to_wet
1561 :
1562 : !===============================================================================
1563 :
1564 281568 : subroutine physics_state_alloc(state,lchnk,psetcols)
1565 :
1566 : use infnan, only: inf, assignment(=)
1567 :
1568 : ! allocate the individual state components
1569 :
1570 : type(physics_state), intent(inout) :: state
1571 : integer,intent(in) :: lchnk
1572 :
1573 : integer, intent(in) :: psetcols
1574 :
1575 : integer :: ierr=0
1576 :
1577 281568 : state%lchnk = lchnk
1578 281568 : state%psetcols = psetcols
1579 281568 : state%ngrdcol = get_ncols_p(lchnk) ! Number of grid columns
1580 :
1581 : !----------------------------------
1582 : ! Following variables will be overwritten by sub-column generator, if sub-columns are being used
1583 :
1584 : ! state%ncol - is initialized in physics_state_set_grid, if not using sub-columns
1585 :
1586 : !----------------------------------
1587 :
1588 281568 : allocate(state%lat(psetcols), stat=ierr)
1589 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lat')
1590 :
1591 281568 : allocate(state%lon(psetcols), stat=ierr)
1592 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lon')
1593 :
1594 281568 : allocate(state%ps(psetcols), stat=ierr)
1595 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ps')
1596 :
1597 281568 : allocate(state%psdry(psetcols), stat=ierr)
1598 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%psdry')
1599 :
1600 281568 : allocate(state%phis(psetcols), stat=ierr)
1601 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%phis')
1602 :
1603 281568 : allocate(state%ulat(psetcols), stat=ierr)
1604 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulat')
1605 :
1606 281568 : allocate(state%ulon(psetcols), stat=ierr)
1607 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%ulon')
1608 :
1609 281568 : allocate(state%t(psetcols,pver), stat=ierr)
1610 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%t')
1611 :
1612 281568 : allocate(state%u(psetcols,pver), stat=ierr)
1613 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%u')
1614 :
1615 281568 : allocate(state%v(psetcols,pver), stat=ierr)
1616 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%v')
1617 :
1618 281568 : allocate(state%s(psetcols,pver), stat=ierr)
1619 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%s')
1620 :
1621 281568 : allocate(state%omega(psetcols,pver), stat=ierr)
1622 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%omega')
1623 :
1624 281568 : allocate(state%pmid(psetcols,pver), stat=ierr)
1625 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmid')
1626 :
1627 281568 : allocate(state%pmiddry(psetcols,pver), stat=ierr)
1628 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pmiddry')
1629 :
1630 281568 : allocate(state%pdel(psetcols,pver), stat=ierr)
1631 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdel')
1632 :
1633 281568 : allocate(state%pdeldry(psetcols,pver), stat=ierr)
1634 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pdeldry')
1635 :
1636 281568 : allocate(state%rpdel(psetcols,pver), stat=ierr)
1637 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdel')
1638 :
1639 281568 : allocate(state%rpdeldry(psetcols,pver), stat=ierr)
1640 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%rpdeldry')
1641 :
1642 281568 : allocate(state%lnpmid(psetcols,pver), stat=ierr)
1643 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmid')
1644 :
1645 281568 : allocate(state%lnpmiddry(psetcols,pver), stat=ierr)
1646 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpmiddry')
1647 :
1648 281568 : allocate(state%exner(psetcols,pver), stat=ierr)
1649 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%exner')
1650 :
1651 281568 : allocate(state%zm(psetcols,pver), stat=ierr)
1652 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zm')
1653 :
1654 281568 : allocate(state%q(psetcols,pver,pcnst), stat=ierr)
1655 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%q')
1656 :
1657 281568 : allocate(state%pint(psetcols,pver+1), stat=ierr)
1658 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pint')
1659 :
1660 281568 : allocate(state%pintdry(psetcols,pver+1), stat=ierr)
1661 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%pintdry')
1662 :
1663 281568 : allocate(state%lnpint(psetcols,pver+1), stat=ierr)
1664 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpint')
1665 :
1666 281568 : allocate(state%lnpintdry(psetcols,pver+1), stat=ierr)
1667 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lnpintdry')
1668 :
1669 281568 : allocate(state%zi(psetcols,pver+1), stat=ierr)
1670 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%zi')
1671 :
1672 281568 : allocate(state%te_ini(psetcols,2), stat=ierr)
1673 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_ini')
1674 :
1675 281568 : allocate(state%te_cur(psetcols,2), stat=ierr)
1676 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%te_cur')
1677 :
1678 281568 : allocate(state%tw_ini(psetcols), stat=ierr)
1679 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_ini')
1680 :
1681 281568 : allocate(state%tw_cur(psetcols), stat=ierr)
1682 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%tw_cur')
1683 :
1684 281568 : allocate(state%temp_ini(psetcols,pver), stat=ierr)
1685 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%temp_ini')
1686 :
1687 281568 : allocate(state%z_ini(psetcols,pver), stat=ierr)
1688 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%z_ini')
1689 :
1690 281568 : allocate(state%latmapback(psetcols), stat=ierr)
1691 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%latmapback')
1692 :
1693 281568 : allocate(state%lonmapback(psetcols), stat=ierr)
1694 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%lonmapback')
1695 :
1696 281568 : allocate(state%cid(psetcols), stat=ierr)
1697 281568 : if ( ierr /= 0 ) call endrun('physics_state_alloc error: allocation error for state%cid')
1698 :
1699 281568 : state%lat(:) = inf
1700 281568 : state%lon(:) = inf
1701 281568 : state%ulat(:) = inf
1702 281568 : state%ulon(:) = inf
1703 281568 : state%ps(:) = inf
1704 281568 : state%psdry(:) = inf
1705 281568 : state%phis(:) = inf
1706 281568 : state%t(:,:) = inf
1707 281568 : state%u(:,:) = inf
1708 281568 : state%v(:,:) = inf
1709 281568 : state%s(:,:) = inf
1710 281568 : state%omega(:,:) = inf
1711 281568 : state%pmid(:,:) = inf
1712 281568 : state%pmiddry(:,:) = inf
1713 281568 : state%pdel(:,:) = inf
1714 281568 : state%pdeldry(:,:) = inf
1715 281568 : state%rpdel(:,:) = inf
1716 281568 : state%rpdeldry(:,:) = inf
1717 281568 : state%lnpmid(:,:) = inf
1718 281568 : state%lnpmiddry(:,:) = inf
1719 281568 : state%exner(:,:) = inf
1720 281568 : state%zm(:,:) = inf
1721 281568 : state%q(:,:,:) = inf
1722 :
1723 281568 : state%pint(:,:) = inf
1724 281568 : state%pintdry(:,:) = inf
1725 281568 : state%lnpint(:,:) = inf
1726 281568 : state%lnpintdry(:,:) = inf
1727 281568 : state%zi(:,:) = inf
1728 :
1729 281568 : state%te_ini(:,:) = inf
1730 281568 : state%te_cur(:,:) = inf
1731 281568 : state%tw_ini(:) = inf
1732 281568 : state%tw_cur(:) = inf
1733 281568 : state%temp_ini(:,:) = inf
1734 281568 : state%z_ini(:,:) = inf
1735 :
1736 281568 : end subroutine physics_state_alloc
1737 :
1738 : !===============================================================================
1739 :
1740 211176 : subroutine physics_state_dealloc(state)
1741 :
1742 : ! deallocate the individual state components
1743 :
1744 : type(physics_state), intent(inout) :: state
1745 : integer :: ierr = 0
1746 :
1747 211176 : deallocate(state%lat, stat=ierr)
1748 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lat')
1749 :
1750 211176 : deallocate(state%lon, stat=ierr)
1751 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lon')
1752 :
1753 211176 : deallocate(state%ps, stat=ierr)
1754 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ps')
1755 :
1756 211176 : deallocate(state%psdry, stat=ierr)
1757 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%psdry')
1758 :
1759 211176 : deallocate(state%phis, stat=ierr)
1760 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%phis')
1761 :
1762 211176 : deallocate(state%ulat, stat=ierr)
1763 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulat')
1764 :
1765 211176 : deallocate(state%ulon, stat=ierr)
1766 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%ulon')
1767 :
1768 211176 : deallocate(state%t, stat=ierr)
1769 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%t')
1770 :
1771 211176 : deallocate(state%u, stat=ierr)
1772 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%u')
1773 :
1774 211176 : deallocate(state%v, stat=ierr)
1775 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%v')
1776 :
1777 211176 : deallocate(state%s, stat=ierr)
1778 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%s')
1779 :
1780 211176 : deallocate(state%omega, stat=ierr)
1781 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%omega')
1782 :
1783 211176 : deallocate(state%pmid, stat=ierr)
1784 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmid')
1785 :
1786 211176 : deallocate(state%pmiddry, stat=ierr)
1787 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pmiddry')
1788 :
1789 211176 : deallocate(state%pdel, stat=ierr)
1790 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdel')
1791 :
1792 211176 : deallocate(state%pdeldry, stat=ierr)
1793 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pdeldry')
1794 :
1795 211176 : deallocate(state%rpdel, stat=ierr)
1796 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdel')
1797 :
1798 211176 : deallocate(state%rpdeldry, stat=ierr)
1799 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%rpdeldry')
1800 :
1801 211176 : deallocate(state%lnpmid, stat=ierr)
1802 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmid')
1803 :
1804 211176 : deallocate(state%lnpmiddry, stat=ierr)
1805 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpmiddry')
1806 :
1807 211176 : deallocate(state%exner, stat=ierr)
1808 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%exner')
1809 :
1810 211176 : deallocate(state%zm, stat=ierr)
1811 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zm')
1812 :
1813 211176 : deallocate(state%q, stat=ierr)
1814 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%q')
1815 :
1816 211176 : deallocate(state%pint, stat=ierr)
1817 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pint')
1818 :
1819 211176 : deallocate(state%pintdry, stat=ierr)
1820 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%pintdry')
1821 :
1822 211176 : deallocate(state%lnpint, stat=ierr)
1823 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpint')
1824 :
1825 211176 : deallocate(state%lnpintdry, stat=ierr)
1826 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lnpintdry')
1827 :
1828 211176 : deallocate(state%zi, stat=ierr)
1829 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%zi')
1830 :
1831 211176 : deallocate(state%te_ini, stat=ierr)
1832 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_ini')
1833 :
1834 211176 : deallocate(state%te_cur, stat=ierr)
1835 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%te_cur')
1836 :
1837 211176 : deallocate(state%tw_ini, stat=ierr)
1838 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_ini')
1839 :
1840 211176 : deallocate(state%tw_cur, stat=ierr)
1841 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%tw_cur')
1842 :
1843 211176 : deallocate(state%temp_ini, stat=ierr)
1844 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%temp_ini')
1845 :
1846 211176 : deallocate(state%z_ini, stat=ierr)
1847 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%z_ini')
1848 :
1849 211176 : deallocate(state%latmapback, stat=ierr)
1850 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%latmapback')
1851 :
1852 211176 : deallocate(state%lonmapback, stat=ierr)
1853 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%lonmapback')
1854 :
1855 211176 : deallocate(state%cid, stat=ierr)
1856 211176 : if ( ierr /= 0 ) call endrun('physics_state_dealloc error: deallocation error for state%cid')
1857 :
1858 211176 : end subroutine physics_state_dealloc
1859 :
1860 : !===============================================================================
1861 :
1862 6704 : subroutine physics_tend_alloc(tend,psetcols)
1863 :
1864 : use infnan, only : inf, assignment(=)
1865 : ! allocate the individual tend components
1866 :
1867 : type(physics_tend), intent(inout) :: tend
1868 :
1869 : integer, intent(in) :: psetcols
1870 :
1871 : integer :: ierr = 0
1872 :
1873 6704 : tend%psetcols = psetcols
1874 :
1875 6704 : allocate(tend%dtdt(psetcols,pver), stat=ierr)
1876 6704 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dtdt')
1877 :
1878 6704 : allocate(tend%dudt(psetcols,pver), stat=ierr)
1879 6704 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dudt')
1880 :
1881 6704 : allocate(tend%dvdt(psetcols,pver), stat=ierr)
1882 6704 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%dvdt')
1883 :
1884 6704 : allocate(tend%flx_net(psetcols), stat=ierr)
1885 6704 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%flx_net')
1886 :
1887 6704 : allocate(tend%te_tnd(psetcols), stat=ierr)
1888 6704 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%te_tnd')
1889 :
1890 6704 : allocate(tend%tw_tnd(psetcols), stat=ierr)
1891 6704 : if ( ierr /= 0 ) call endrun('physics_tend_alloc error: allocation error for tend%tw_tnd')
1892 :
1893 6704 : tend%dtdt(:,:) = inf
1894 6704 : tend%dudt(:,:) = inf
1895 6704 : tend%dvdt(:,:) = inf
1896 6704 : tend%flx_net(:) = inf
1897 6704 : tend%te_tnd(:) = inf
1898 6704 : tend%tw_tnd(:) = inf
1899 :
1900 6704 : end subroutine physics_tend_alloc
1901 :
1902 : !===============================================================================
1903 :
1904 0 : subroutine physics_tend_dealloc(tend)
1905 :
1906 : ! deallocate the individual tend components
1907 :
1908 : type(physics_tend), intent(inout) :: tend
1909 : integer :: ierr = 0
1910 :
1911 0 : deallocate(tend%dtdt, stat=ierr)
1912 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dtdt')
1913 :
1914 0 : deallocate(tend%dudt, stat=ierr)
1915 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dudt')
1916 :
1917 0 : deallocate(tend%dvdt, stat=ierr)
1918 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%dvdt')
1919 :
1920 0 : deallocate(tend%flx_net, stat=ierr)
1921 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%flx_net')
1922 :
1923 0 : deallocate(tend%te_tnd, stat=ierr)
1924 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%te_tnd')
1925 :
1926 0 : deallocate(tend%tw_tnd, stat=ierr)
1927 0 : if ( ierr /= 0 ) call endrun('physics_tend_dealloc error: deallocation error for tend%tw_tnd')
1928 0 : end subroutine physics_tend_dealloc
1929 :
1930 : !===============================================================================
1931 :
1932 1176552 : subroutine physics_ptend_alloc(ptend,psetcols)
1933 :
1934 : ! allocate the individual ptend components
1935 :
1936 : type(physics_ptend), intent(inout) :: ptend
1937 :
1938 : integer, intent(in) :: psetcols
1939 :
1940 : integer :: ierr = 0
1941 :
1942 1176552 : ptend%psetcols = psetcols
1943 :
1944 1176552 : if (ptend%ls) then
1945 894984 : allocate(ptend%s(psetcols,pver), stat=ierr)
1946 894984 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%s')
1947 :
1948 894984 : allocate(ptend%hflux_srf(psetcols), stat=ierr)
1949 894984 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_srf')
1950 :
1951 894984 : allocate(ptend%hflux_top(psetcols), stat=ierr)
1952 894984 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%hflux_top')
1953 : end if
1954 :
1955 1176552 : if (ptend%lu) then
1956 261456 : allocate(ptend%u(psetcols,pver), stat=ierr)
1957 261456 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%u')
1958 :
1959 261456 : allocate(ptend%taux_srf(psetcols), stat=ierr)
1960 261456 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_srf')
1961 :
1962 261456 : allocate(ptend%taux_top(psetcols), stat=ierr)
1963 261456 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%taux_top')
1964 : end if
1965 :
1966 1176552 : if (ptend%lv) then
1967 261456 : allocate(ptend%v(psetcols,pver), stat=ierr)
1968 261456 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%v')
1969 :
1970 261456 : allocate(ptend%tauy_srf(psetcols), stat=ierr)
1971 261456 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_srf')
1972 :
1973 261456 : allocate(ptend%tauy_top(psetcols), stat=ierr)
1974 261456 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%tauy_top')
1975 : end if
1976 :
1977 2423496 : if (any(ptend%lq)) then
1978 831296 : allocate(ptend%q(psetcols,pver,pcnst), stat=ierr)
1979 831296 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%q')
1980 :
1981 831296 : allocate(ptend%cflx_srf(psetcols,pcnst), stat=ierr)
1982 831296 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_srf')
1983 :
1984 831296 : allocate(ptend%cflx_top(psetcols,pcnst), stat=ierr)
1985 831296 : if ( ierr /= 0 ) call endrun('physics_ptend_alloc error: allocation error for ptend%cflx_top')
1986 : end if
1987 :
1988 1176552 : end subroutine physics_ptend_alloc
1989 :
1990 : !===============================================================================
1991 :
1992 1317336 : subroutine physics_ptend_dealloc(ptend)
1993 :
1994 : ! deallocate the individual ptend components
1995 :
1996 : type(physics_ptend), intent(inout) :: ptend
1997 : integer :: ierr = 0
1998 :
1999 1317336 : ptend%psetcols = 0
2000 :
2001 1317336 : if (allocated(ptend%s)) deallocate(ptend%s, stat=ierr)
2002 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%s')
2003 :
2004 1317336 : if (allocated(ptend%hflux_srf)) deallocate(ptend%hflux_srf, stat=ierr)
2005 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_srf')
2006 :
2007 1317336 : if (allocated(ptend%hflux_top)) deallocate(ptend%hflux_top, stat=ierr)
2008 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%hflux_top')
2009 :
2010 1317336 : if (allocated(ptend%u)) deallocate(ptend%u, stat=ierr)
2011 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%u')
2012 :
2013 1317336 : if (allocated(ptend%taux_srf)) deallocate(ptend%taux_srf, stat=ierr)
2014 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_srf')
2015 :
2016 1317336 : if (allocated(ptend%taux_top)) deallocate(ptend%taux_top, stat=ierr)
2017 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%taux_top')
2018 :
2019 1317336 : if (allocated(ptend%v)) deallocate(ptend%v, stat=ierr)
2020 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%v')
2021 :
2022 1317336 : if (allocated(ptend%tauy_srf)) deallocate(ptend%tauy_srf, stat=ierr)
2023 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_srf')
2024 :
2025 1317336 : if (allocated(ptend%tauy_top)) deallocate(ptend%tauy_top, stat=ierr)
2026 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%tauy_top')
2027 :
2028 1317336 : if (allocated(ptend%q)) deallocate(ptend%q, stat=ierr)
2029 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%q')
2030 :
2031 1317336 : if (allocated(ptend%cflx_srf)) deallocate(ptend%cflx_srf, stat=ierr)
2032 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_srf')
2033 :
2034 1317336 : if(allocated(ptend%cflx_top)) deallocate(ptend%cflx_top, stat=ierr)
2035 1317336 : if ( ierr /= 0 ) call endrun('physics_ptend_dealloc error: deallocation error for ptend%cflx_top')
2036 :
2037 1317336 : end subroutine physics_ptend_dealloc
2038 :
2039 0 : end module physics_types
|