FV3DYCORE  Version 1.1.0
fv_diagnostics.F90
Go to the documentation of this file.
1 
2 !***********************************************************************
3 !* GNU Lesser General Public License
4 !*
5 !* This file is part of the FV3 dynamical core.
6 !*
7 !* The FV3 dynamical core is free software: you can redistribute it
8 !* and/or modify it under the terms of the
9 !* GNU Lesser General Public License as published by the
10 !* Free Software Foundation, either version 3 of the License, or
11 !* (at your option) any later version.
12 !*
13 !* The FV3 dynamical core is distributed in the hope that it will be
14 !* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
15 !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
16 !* See the GNU General Public License for more details.
17 !*
18 !* You should have received a copy of the GNU Lesser General Public
19 !* License along with the FV3 dynamical core.
20 !* If not, see <http://www.gnu.org/licenses/>.
21 !***********************************************************************
22 
25 
26 ! <table>
27 ! <tr>
28 ! <th>Module Name</th>
29 ! <th>Functions Included</th>
30 ! </tr>
31 ! <tr>
32 ! <td>a2b_edge_mod</td>
33 ! <td>a2b_ord2, a2b_ord4</td>
34 ! </tr>
35 ! <tr>
36 ! <td>constants_mod</td>
37 ! <td>grav, rdgas, rvgas, pi=>pi_8, radius, kappa, WTMAIR, WTMCO2,
38 ! omega, hlv, cp_air, cp_vapor</td>
39 ! </tr>
40 ! <tr>
41 ! <td>diag_manager_mod</td>
42 ! <td>diag_axis_init, register_diag_field,
43 ! register_static_field, send_data, diag_grid_init</td>
44 ! </tr>
45 ! <tr>
46 ! <td>field_manager_mod</td>
47 ! <td>MODEL_ATMOS</td>
48 ! </tr>
49 ! <tr>
50 ! <td>fms_mod</td>
51 ! <td>write_version_number</td>
52 ! </tr>
53 ! <tr>
54 ! <td>fms_io_mod</td>
55 ! <td>set_domain, nullify_domain, write_version_number</td>
56 ! </tr>
57 ! <tr>
58 ! <td>fv_arrays_mod</td>
59 ! <td>fv_atmos_type, fv_grid_type, fv_diag_type, fv_grid_bounds_type,
60 ! R_GRIDmax_step</td>
61 ! </tr>
62 ! <tr>
63 ! <td>fv_eta_mod</td>
64 ! <td>get_eta_level, gw_1d</td>
65 ! </tr>
66 ! <tr>
67 ! <td>fv_grid_utils_mod</td>
68 ! <td> g_sum</td>
69 ! </tr>
70 ! <tr>
71 ! <td>fv_io_mod</td>
72 ! <td>fv_io_read_tracers</td>
73 ! </tr>
74 ! <tr>
75 ! <td>fv_mp_mod</td>
76 ! <td>mp_reduce_sum, mp_reduce_min, mp_reduce_max, is_master</td>
77 ! </tr>
78 ! <tr>
79 ! <td>fv_mapz_mod</td>
80 ! <td>E_Flux, moist_cv</td>
81 ! </tr>
82 ! <tr>
83 ! <td>fv_sg_mod</td>
84 ! <td>qsmith</td>
85 ! </tr>
86 ! <tr>
87 ! <td>fv_surf_map_mod</td>
88 ! <td>zs_g</td>
89 ! </tr>
90 ! <tr>
91 ! <td>fv_timing_mod</td>
92 ! <td>timing_on, timing_off</td>
93 ! </tr>
94 ! <tr>
95 ! <td>gfdl_cloud_microphys_mod</td>
96 ! <td>wqs1, qsmith_init</td>
97 ! </tr>
98 ! <tr>
99 ! <td>mpp_mod</td>
100 ! <td>mpp_error, FATAL, stdlog, mpp_pe, mpp_root_pe, mpp_sum, mpp_max, NOTE</td>
101 ! </tr>
102 ! <tr>
103 ! <td>mpp_domains_mod</td>
104 ! <td>domain2d, mpp_update_domains, DGRID_NE</td>
105 ! </tr>>
106 ! <tr>
107 ! <td>sat_vapor_pres_mod</td>
108 ! <td>compute_qs, lookup_es</td>
109 ! </tr>
110 ! <tr>
111 ! <td>time_manager_mod</td>
112 ! <td>time_type, get_date, get_time</td>
113 ! </tr>
114 ! <tr>
115 ! <td>tracer_manager_mod</td>
116 ! <td>get_tracer_names, get_number_tracers, get_tracer_index, set_tracer_profile</td>
117 ! </tr>
118 ! </table>
119 
120  use constants_mod, only: grav, rdgas, rvgas, pi=>pi_8, radius, kappa, wtmair, wtmco2, &
121  omega, hlv, cp_air, cp_vapor
122  use fms_mod, only: write_version_number
123  use fms_io_mod, only: set_domain, nullify_domain, write_version_number
124  use time_manager_mod, only: time_type, get_date, get_time
125  use mpp_domains_mod, only: domain2d, mpp_update_domains, dgrid_ne
126  use diag_manager_mod, only: diag_axis_init, register_diag_field, &
127  register_static_field, send_data, diag_grid_init
129  r_grid
130  !!! CLEANUP needs rem oval?
131  use fv_mapz_mod, only: e_flux, moist_cv
132  use fv_mp_mod, only: mp_reduce_sum, mp_reduce_min, mp_reduce_max, is_master
133  use fv_eta_mod, only: get_eta_level, gw_1d
134  use fv_grid_utils_mod, only: g_sum
135  use a2b_edge_mod, only: a2b_ord2, a2b_ord4
136  use fv_surf_map_mod, only: zs_g
137  use fv_sg_mod, only: qsmith
138 
139  use tracer_manager_mod, only: get_tracer_names, get_number_tracers, get_tracer_index
140  use field_manager_mod, only: model_atmos
141  use mpp_mod, only: mpp_error, fatal, stdlog, mpp_pe, mpp_root_pe, mpp_sum, mpp_max, note
142  use sat_vapor_pres_mod, only: compute_qs, lookup_es
143 
144  use fv_arrays_mod, only: max_step
145 #ifndef GFS_PHYS
146  use gfdl_cloud_microphys_mod, only: wqs1, qsmith_init
147 #endif
148 #ifdef MULTI_GASES
150 #endif
151 
152  implicit none
153  private
154 
155 
156  real, parameter:: missing_value = -1.e10
157  real, parameter:: missing_value2 = -1.e3
158  real, parameter:: missing_value3 = 1.e10
159  real :: ginv
160  real :: pk0
161  logical master
162  character(len=3) :: gn = ''
163 
164 ! private (to this module) diag:
165 
166  type(time_type) :: fv_time
167  type(fv_diag_type), pointer :: idiag
168 
169  logical :: module_is_initialized=.false.
170  logical :: prt_minmax =.false.
171  logical :: m_calendar
172  integer sphum, liq_wat, ice_wat, cld_amt ! GFDL physics
174  integer :: istep, mp_top
175  real :: ptop
176  real, parameter :: rad2deg = 180./pi
177 
178 ! tracers
179  character(len=128) :: tname
180  character(len=256) :: tlongname, tunits
181  real :: sphum_ll_fix = 0.
182  real :: qcly0 ! initial value for terminator test
183 
184  public :: fv_diag_init, fv_time, fv_diag, prt_mxm, prt_maxmin, range_check!, id_divg, id_te
187  public :: max_vv,get_vorticity,max_uh
189  public :: helicity_relative_caps
190 
191  integer, parameter :: nplev = 31
192  integer :: levs(nplev)
193 
194 ! version number of this module
195 ! Include variable "version" to be written to log file.
196 #include<file_version.h>
197 
198 contains
199 
200  subroutine fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
201  type(fv_atmos_type), intent(inout), target :: Atm(:)
202  integer, intent(out) :: axes(4)
203  type(time_type), intent(in) :: Time
204  integer, intent(in) :: npx, npy, npz
205  real, intent(in):: p_ref
206 
207  real, allocatable :: grid_xt(:), grid_yt(:), grid_xe(:), grid_ye(:), grid_xn(:), grid_yn(:)
208  real, allocatable :: grid_x(:), grid_y(:)
209  real :: vrange(2), vsrange(2), wrange(2), trange(2), slprange(2), rhrange(2), skrange(2)
210  real, allocatable :: a3(:,:,:)
211  real :: pfull(npz)
212  real :: hyam(npz), hybm(npz)
213 
214  !These id_* are not needed later since they are for static data which is not used elsewhere
215  integer :: id_bk, id_pk, id_area, id_lon, id_lat, id_lont, id_latt, id_phalf, id_pfull
216  integer :: id_hyam, id_hybm
217  integer :: id_plev
218  integer :: i, j, k, n, ntileMe, id_xt, id_yt, id_x, id_y, id_xe, id_ye, id_xn, id_yn
219  integer :: isc, iec, jsc, jec
220  logical :: used
221 
222  character(len=64) :: plev
223  character(len=64) :: field
224  integer :: ntprog
225  integer :: unit
226 
227  integer :: ncnst
228  integer :: axe2(3)
229 
230 
231  call write_version_number ( 'FV_DIAGNOSTICS_MOD', version )
232  idiag => atm(1)%idiag
233 
234 ! For total energy diagnostics:
235  idiag%steps = 0
236  idiag%efx = 0.; idiag%efx_sum = 0.
237  idiag%mtq = 0.; idiag%mtq_sum = 0.
238 
239  ncnst = atm(1)%ncnst
240  m_calendar = atm(1)%flagstruct%moist_phys
241  call set_domain(atm(1)%domain) ! Set domain so that diag_manager can access tile information
242 
243  sphum = get_tracer_index(model_atmos, 'sphum')
244  liq_wat = get_tracer_index(model_atmos, 'liq_wat')
245  ice_wat = get_tracer_index(model_atmos, 'ice_wat')
246 
247  rainwat = get_tracer_index(model_atmos, 'rainwat')
248  snowwat = get_tracer_index(model_atmos, 'snowwat')
249  graupel = get_tracer_index(model_atmos, 'graupel')
250  cld_amt = get_tracer_index(model_atmos, 'cld_amt')
251 
252 ! valid range for some fields
253 
254 !!! This will need mods for more than 1 tile per pe !!!
255 
256  vsrange = (/ -200., 200. /) ! surface (lowest layer) winds
257 
258  vrange = (/ -330., 330. /) ! winds
259  wrange = (/ -100., 100. /) ! vertical wind
260  rhrange = (/ -10., 150. /) ! RH
261 #ifdef HIWPP
262  trange = (/ 5., 350. /) ! temperature
263 #else
264  trange = (/ 100., 350. /) ! temperature
265 #endif
266  slprange = (/800., 1200./) ! sea-level-pressure
267  skrange = (/ -10000000.0, 10000000.0 /) ! dissipation estimate for SKEB
268 
269  ginv = 1./grav
270  if (atm(1)%grid_number == 1) fv_time = time
271 
272  allocate ( idiag%phalf(npz+1) )
273  call get_eta_level(atm(1)%npz, p_ref, pfull, idiag%phalf, atm(1)%ak, atm(1)%bk, 0.01)
274 
275  mp_top = 1
276  do k=1,npz
277  if ( pfull(k) > 30.e2 ) then
278  mp_top = k
279  exit
280  endif
281  enddo
282  if ( is_master() ) write(*,*) 'mp_top=', mp_top, 'pfull=', pfull(mp_top)
283 
284 ! allocate(grid_xt(npx-1), grid_yt(npy-1), grid_xe(npx), grid_ye(npy-1), grid_xn(npx-1), grid_yn(npy))
285  allocate(grid_xt(npx-1), grid_yt(npy-1))
286  grid_xt = (/ (i, i=1,npx-1) /)
287  grid_yt = (/ (j, j=1,npy-1) /)
288 ! grid_xe = (/ (i, i=1,npx) /)
289 ! grid_ye = (/ (j, j=1,npy-1) /)
290 ! grid_xn = (/ (i, i=1,npx-1) /)
291 ! grid_yn = (/ (j, j=1,npy) /)
292 
293  allocate(grid_x(npx), grid_y(npy))
294  grid_x = (/ (i, i=1,npx) /)
295  grid_y = (/ (j, j=1,npy) /)
296 
297  n=1
298  isc = atm(n)%bd%isc; iec = atm(n)%bd%iec
299  jsc = atm(n)%bd%jsc; jec = atm(n)%bd%jec
300 
301  ! Send diag_manager the grid informtaion
302  call diag_grid_init(domain=atm(n)%domain, &
303  & glo_lon=rad2deg*atm(n)%gridstruct%grid(isc:iec+1,jsc:jec+1,1), &
304  & glo_lat=rad2deg*atm(n)%gridstruct%grid(isc:iec+1,jsc:jec+1,2), &
305  & aglo_lon=rad2deg*atm(n)%gridstruct%agrid(isc-1:iec+1,jsc-1:jec+1,1), &
306  & aglo_lat=rad2deg*atm(n)%gridstruct%agrid(isc-1:iec+1,jsc-1:jec+1,2))
307 
308  ntileme = size(atm(:))
309  if (ntileme > 1) call mpp_error(fatal, "fv_diag_init can only be called with one grid at a time.")
310 
311 ! do n = 1, ntileMe
312  n = 1
313  field = 'grid'
314 
315  id_xt = diag_axis_init('grid_xt',grid_xt,'degrees_E','x','T-cell longitude', &
316  set_name=trim(field),domain2=atm(n)%Domain, tile_count=n)
317  id_yt = diag_axis_init('grid_yt',grid_yt,'degrees_N','y','T-cell latitude', &
318  set_name=trim(field), domain2=atm(n)%Domain, tile_count=n)
319 ! Don't need these right now
320 ! id_xe = diag_axis_init ('grid_xe',grid_xe,'degrees_E','x','E-cell longitude', &
321 ! set_name=trim(field),Domain2=Domain, tile_count=n)
322 ! id_ye = diag_axis_init ('grid_ye',grid_ye,'degrees_N','y','E-cell latitude', &
323 ! set_name=trim(field), Domain2=Domain, tile_count=n)
324 ! id_xn = diag_axis_init ('grid_xn',grid_xn,'degrees_E','x','N-cell longitude', &
325 ! set_name=trim(field),Domain2=Domain, aux='geolon_n, geolat_n', tile_count=n)
326 ! id_yn = diag_axis_init ('grid_yn',grid_yn,'degrees_N','y','N-cell latitude', &
327 ! set_name=trim(field), Domain2=Domain, tile_count=n)
328 
329  id_x = diag_axis_init('grid_x',grid_x,'degrees_E','x','cell corner longitude', &
330  set_name=trim(field),domain2=atm(n)%Domain, tile_count=n)
331  id_y = diag_axis_init('grid_y',grid_y,'degrees_N','y','cell corner latitude', &
332  set_name=trim(field), domain2=atm(n)%Domain, tile_count=n)
333 
334 ! end do
335 ! deallocate(grid_xt, grid_yt, grid_xe, grid_ye, grid_xn, grid_yn)
336  deallocate(grid_xt, grid_yt)
337  deallocate(grid_x, grid_y )
338 
339  id_phalf = diag_axis_init('phalf', idiag%phalf, 'mb', 'z', &
340  'ref half pressure level', direction=-1, set_name="dynamics")
341  id_pfull = diag_axis_init('pfull', pfull, 'mb', 'z', &
342  'ref full pressure level', direction=-1, set_name="dynamics", edges=id_phalf)
343 
344 !---- register static fields -------
345 
346  id_bk = register_static_field( "dynamics", 'bk', (/id_phalf/), &
347  'vertical coordinate sigma value', 'none' )
348 
349  id_pk = register_static_field( "dynamics", 'pk', (/id_phalf/), &
350  'pressure part of the hybrid coordinate', 'pascal' )
351 
352  id_hyam = register_static_field( "dynamics", 'hyam', (/id_pfull/), &
353  'vertical coordinate A value', '1E-5 Pa' )
354 
355  id_hybm = register_static_field( "dynamics", 'hybm', (/id_pfull/), &
356  'vertical coordinate B value', 'none' )
357 
358 !--- Send static data
359 
360  if ( id_bk > 0 ) used = send_data( id_bk,atm(1)%bk, time )
361  if ( id_pk > 0 ) used = send_data( id_pk,atm(1)%ak, time )
362  if ( id_hyam > 0 ) then
363  do k=1,npz
364  hyam(k) = 0.5 * ( atm(1)%ak(k) + atm(1)%ak(k+1) ) * 1.e-5
365  enddo
366  used = send_data( id_hyam, hyam, time )
367  endif
368  if ( id_hybm > 0 ) then
369  do k=1,npz
370  hybm(k) = 0.5 * ( atm(1)%bk(k) + atm(1)%bk(k+1) )
371  enddo
372  used = send_data( id_hybm, hybm, time )
373  endif
374 
375 ! Approach will need modification if we wish to write values on other than A grid.
376  axes(1) = id_xt
377  axes(2) = id_yt
378  axes(3) = id_pfull
379  axes(4) = id_phalf
380 
381 ! Selected pressure levels
382 ! SJL note: 31 is enough here; if you need more levels you should do it OFF line
383 ! do not add more to prevent the model from slowing down too much.
384  levs = (/1,2,3,5,7,10,20,30,50,70,100,150,200,250,300,350,400,450,500,550,600,650,700,750,800,850,900,925,950,975,1000/)
385 
386  id_plev = diag_axis_init('plev', levs(:)*1.0, 'mb', 'z', &
387  'actual pressure level', direction=-1, set_name="dynamics")
388 
389  axe2(1) = id_xt
390  axe2(2) = id_yt
391  axe2(3) = id_plev
392 
393 !---- register time independent fields -------
394 
395 ! do n = 1, ntileMe
396  n = 1
397  field= 'dynamics'
398  id_lon = register_static_field( trim(field), 'grid_lon', (/id_x,id_y/), &
399  'longitude', 'degrees_E' )
400  id_lat = register_static_field( trim(field), 'grid_lat', (/id_x,id_y/), &
401  'latitude', 'degrees_N' )
402  id_lont = register_static_field( trim(field), 'grid_lont', (/id_xt,id_yt/), &
403  'longitude', 'degrees_E' )
404  id_latt = register_static_field( trim(field), 'grid_latt', (/id_xt,id_yt/), &
405  'latitude', 'degrees_N' )
406  id_area = register_static_field( trim(field), 'area', axes(1:2), &
407  'cell area', 'm**2' )
408 #ifndef DYNAMICS_ZS
409  idiag%id_zsurf = register_static_field( trim(field), 'zsurf', axes(1:2), &
410  'surface height', 'm' )
411 #endif
412  idiag%id_zs = register_static_field( trim(field), 'zs', axes(1:2), &
413  'Original Mean Terrain', 'm' )
414 ! 3D hybrid_z fields:
415  idiag%id_ze = register_static_field( trim(field), 'ze', axes(1:3), &
416  'Hybrid_Z_surface', 'm' )
417  idiag%id_oro = register_static_field( trim(field), 'oro', axes(1:2), &
418  'Land/Water Mask', 'none' )
419  idiag%id_sgh = register_static_field( trim(field), 'sgh', axes(1:2), &
420  'Terrain Standard deviation', 'm' )
421 ! idiag%id_ts = register_static_field ( trim(field), 'ts', axes(1:2), &
422 ! 'Skin temperature', 'K' )
423 
424 !--------------------
425 ! Initial conditions:
426 !--------------------
427  idiag%ic_ps = register_static_field( trim(field), 'ps_ic', axes(1:2), &
428  'initial surface pressure', 'Pa' )
429  idiag%ic_ua = register_static_field( trim(field), 'ua_ic', axes(1:3), &
430  'zonal wind', 'm/sec' )
431  idiag%ic_va = register_static_field( trim(field), 'va_ic', axes(1:3), &
432  'meridional wind', 'm/sec' )
433  idiag%ic_ppt= register_static_field( trim(field), 'ppt_ic', axes(1:3), &
434  'potential temperature perturbation', 'K' )
435  idiag%ic_sphum = register_static_field( trim(field), 'sphum_ic', axes(1:2), &
436  'initial surface pressure', 'Pa' )
437 
438 ! end do
439 
440  master = (mpp_pe()==mpp_root_pe())
441 
442  n=1
443  isc = atm(n)%bd%isc; iec = atm(n)%bd%iec
444  jsc = atm(n)%bd%jsc; jec = atm(n)%bd%jec
445 
446  allocate ( idiag%zsurf(isc:iec,jsc:jec) )
447 
448  do j=jsc,jec
449  do i=isc,iec
450  idiag%zsurf(i,j) = ginv * atm(n)%phis(i,j)
451  enddo
452  enddo
453 
454 !--- Send time independent data
455 
456 ! do n = 1, ntileMe
457  n = 1
458  isc = atm(n)%bd%isc; iec = atm(n)%bd%iec
459  jsc = atm(n)%bd%jsc; jec = atm(n)%bd%jec
460  if (id_lon > 0) used = send_data(id_lon, rad2deg*atm(n)%gridstruct%grid(isc:iec+1,jsc:jec+1,1), time)
461  if (id_lat > 0) used = send_data(id_lat, rad2deg*atm(n)%gridstruct%grid(isc:iec+1,jsc:jec+1,2), time)
462  if (id_lont > 0) used = send_data(id_lont, rad2deg*atm(n)%gridstruct%agrid(isc:iec,jsc:jec,1), time)
463  if (id_latt > 0) used = send_data(id_latt, rad2deg*atm(n)%gridstruct%agrid(isc:iec,jsc:jec,2), time)
464  if (id_area > 0) used = send_data(id_area, atm(n)%gridstruct%area(isc:iec,jsc:jec), time)
465 #ifndef DYNAMICS_ZS
466  if (idiag%id_zsurf > 0) used = send_data(idiag%id_zsurf, idiag%zsurf, time)
467 #endif
468  if ( atm(n)%flagstruct%fv_land ) then
469  if (idiag%id_zs > 0) used = send_data(idiag%id_zs , zs_g, time)
470  if (idiag%id_oro > 0) used = send_data(idiag%id_oro, atm(n)%oro(isc:iec,jsc:jec), time)
471  if (idiag%id_sgh > 0) used = send_data(idiag%id_sgh, atm(n)%sgh(isc:iec,jsc:jec), time)
472  endif
473 
474  if ( atm(n)%flagstruct%ncep_ic ) then
475  if (idiag%id_ts > 0) used = send_data(idiag%id_ts, atm(n)%ts(isc:iec,jsc:jec), time)
476  endif
477 
478  if ( atm(n)%flagstruct%hybrid_z .and. idiag%id_ze > 0 ) &
479  used = send_data(idiag%id_ze, atm(n)%ze0(isc:iec,jsc:jec,1:npz), time)
480 
481  if (idiag%ic_ps > 0) used = send_data(idiag%ic_ps, atm(n)%ps(isc:iec,jsc:jec)*ginv, time)
482 
483  if(idiag%ic_ua > 0) used=send_data(idiag%ic_ua, atm(n)%ua(isc:iec,jsc:jec,:), time)
484  if(idiag%ic_va > 0) used=send_data(idiag%ic_va, atm(n)%va(isc:iec,jsc:jec,:), time)
485 
486  pk0 = 1000.e2 ** kappa
487  if(idiag%ic_ppt> 0) then
488 ! Potential temperature
489  allocate ( idiag%pt1(npz) )
490  allocate ( a3(isc:iec,jsc:jec,npz) )
491 #ifdef TEST_GWAVES
492  call gw_1d(npz, 1000.e2, atm(n)%ak, atm(n)%ak, atm(n)%ak(1), 10.e3, idiag%pt1)
493 #else
494  idiag%pt1 = 0.
495 #endif
496  do k=1,npz
497  do j=jsc,jec
498  do i=isc,iec
499  a3(i,j,k) = (atm(n)%pt(i,j,k)/atm(n)%pkz(i,j,k) - idiag%pt1(k)) * pk0
500  enddo
501  enddo
502  enddo
503  used=send_data(idiag%ic_ppt, a3, time)
504  deallocate ( a3 )
505  deallocate ( idiag%pt1 )
506  endif
507 ! end do
508 
509 !--------------------------------------------------------------
510 ! Register main prognostic fields: ps, (u,v), t, omega (dp/dt)
511 !--------------------------------------------------------------
512 
513  allocate(idiag%id_tracer(ncnst))
514  allocate(idiag%id_tracer_dmmr(ncnst))
515  allocate(idiag%id_tracer_dvmr(ncnst))
516  allocate(idiag%w_mr(ncnst))
517  idiag%id_tracer(:) = 0
518  idiag%id_tracer_dmmr(:) = 0
519  idiag%id_tracer_dvmr(:) = 0
520  idiag%w_mr(:) = 0.e0
521 
522  allocate(idiag%id_u(nplev))
523  allocate(idiag%id_v(nplev))
524  allocate(idiag%id_t(nplev))
525  allocate(idiag%id_h(nplev))
526  allocate(idiag%id_q(nplev))
527  allocate(idiag%id_omg(nplev))
528  idiag%id_u(:) = 0
529  idiag%id_v(:) = 0
530  idiag%id_t(:) = 0
531  idiag%id_h(:) = 0
532  idiag%id_q(:) = 0
533  idiag%id_omg(:) = 0
534 
535 ! do n = 1, ntileMe
536  n = 1
537  field= 'dynamics'
538 
539 #ifdef DYNAMICS_ZS
540  idiag%id_zsurf = register_diag_field( trim(field), 'zsurf', axes(1:2), time, &
541  'surface height', 'm')
542 #endif
543 !-------------------
544 ! Surface pressure
545 !-------------------
546  idiag%id_ps = register_diag_field( trim(field), 'ps', axes(1:2), time, &
547  'surface pressure', 'Pa', missing_value=missing_value )
548 
549 !-------------------
550 ! Mountain torque
551 !-------------------
552  idiag%id_mq = register_diag_field( trim(field), 'mq', axes(1:2), time, &
553  'mountain torque', 'Hadleys per unit area', missing_value=missing_value )
554 !-------------------
555 ! Angular momentum
556 !-------------------
557  idiag%id_aam = register_diag_field( trim(field), 'aam', axes(1:2), time, &
558  'angular momentum', 'kg*m^2/s', missing_value=missing_value )
559  idiag%id_amdt = register_diag_field( trim(field), 'amdt', axes(1:2), time, &
560  'angular momentum error', 'kg*m^2/s^2', missing_value=missing_value )
561 
562 !
563  do i=1,nplev
564  write(plev,'(I5)') levs(i)
565 ! Height:
566  idiag%id_h(i) = register_diag_field(trim(field), 'z'//trim(adjustl(plev)), axes(1:2), time, &
567  trim(adjustl(plev))//'-mb height', 'm', missing_value=missing_value)
568 ! u-wind:
569  idiag%id_u(i) = register_diag_field(trim(field), 'u'//trim(adjustl(plev)), axes(1:2), time, &
570  trim(adjustl(plev))//'-mb u', 'm/s', missing_value=missing_value)
571 ! v-wind:
572  idiag%id_v(i) = register_diag_field(trim(field), 'v'//trim(adjustl(plev)), axes(1:2), time, &
573  trim(adjustl(plev))//'-mb v', 'm/s', missing_value=missing_value)
574 ! Temperature (K):
575  idiag%id_t(i) = register_diag_field(trim(field), 't'//trim(adjustl(plev)), axes(1:2), time, &
576  trim(adjustl(plev))//'-mb temperature', 'K', missing_value=missing_value)
577 ! specific humidity:
578  idiag%id_q(i) = register_diag_field(trim(field), 'q'//trim(adjustl(plev)), axes(1:2), time, &
579  trim(adjustl(plev))//'-mb specific humidity', 'kg/kg', missing_value=missing_value)
580 ! Omega (Pa/sec)
581  idiag%id_omg(i) = register_diag_field(trim(field), 'omg'//trim(adjustl(plev)), axes(1:2), time, &
582  trim(adjustl(plev))//'-mb omega', 'Pa/s', missing_value=missing_value)
583  enddo
584 
585  idiag%id_u_plev = register_diag_field( trim(field), 'u_plev', axe2(1:3), time, &
586  'zonal wind', 'm/sec', missing_value=missing_value, range=vrange )
587  idiag%id_v_plev = register_diag_field( trim(field), 'v_plev', axe2(1:3), time, &
588  'meridional wind', 'm/sec', missing_value=missing_value, range=vrange )
589  idiag%id_t_plev = register_diag_field( trim(field), 't_plev', axe2(1:3), time, &
590  'temperature', 'K', missing_value=missing_value, range=trange )
591  idiag%id_h_plev = register_diag_field( trim(field), 'h_plev', axe2(1:3), time, &
592  'height', 'm', missing_value=missing_value )
593  idiag%id_q_plev = register_diag_field( trim(field), 'q_plev', axe2(1:3), time, &
594  'specific humidity', 'kg/kg', missing_value=missing_value )
595  idiag%id_omg_plev = register_diag_field( trim(field), 'omg_plev', axe2(1:3), time, &
596  'omega', 'Pa/s', missing_value=missing_value )
597 
598  ! flag for calculation of geopotential
599  if ( all(idiag%id_h(minloc(abs(levs-10)))>0) .or. all(idiag%id_h(minloc(abs(levs-50)))>0) .or. &
600  all(idiag%id_h(minloc(abs(levs-100)))>0) .or. all(idiag%id_h(minloc(abs(levs-200)))>0) .or. &
601  all(idiag%id_h(minloc(abs(levs-250)))>0) .or. all(idiag%id_h(minloc(abs(levs-300)))>0) .or. &
602  all(idiag%id_h(minloc(abs(levs-500)))>0) .or. all(idiag%id_h(minloc(abs(levs-700)))>0) .or. &
603  all(idiag%id_h(minloc(abs(levs-850)))>0) .or. all(idiag%id_h(minloc(abs(levs-1000)))>0) ) then
604  idiag%id_hght = 1
605  else
606  idiag%id_hght = 0
607  endif
608 !-----------------------------
609 ! mean temp between 300-500 mb
610 !-----------------------------
611  idiag%id_tm = register_diag_field(trim(field), 'tm', axes(1:2), time, &
612  'mean 300-500 mb temp', 'K', missing_value=missing_value )
613 
614 !-------------------
615 ! Sea-level-pressure
616 !-------------------
617  idiag%id_slp = register_diag_field(trim(field), 'slp', axes(1:2), time, &
618  'sea-level pressure', 'mb', missing_value=missing_value, &
619  range=slprange )
620 !----------------------------------
621 ! Bottom level pressure for masking
622 !----------------------------------
623  idiag%id_pmask = register_diag_field(trim(field), 'pmask', axes(1:2), time, &
624  'masking pressure at lowest level', 'mb', &
626 !------------------------------------------
627 ! Fix for Bottom level pressure for masking
628 !------------------------------------------
629  idiag%id_pmaskv2 = register_diag_field(trim(field), 'pmaskv2', axes(1:2), time,&
630  & 'masking pressure at lowest level', 'mb', missing_value=missing_value)
631 
632 !-------------------
633 ! Hurricane scales:
634 !-------------------
635 ! Net effects: ~ intensity * freq
636  idiag%id_c15 = register_diag_field(trim(field), 'cat15', axes(1:2), time, &
637  'de-pression < 1000', 'mb', missing_value=missing_value)
638  idiag%id_c25 = register_diag_field(trim(field), 'cat25', axes(1:2), time, &
639  'de-pression < 980', 'mb', missing_value=missing_value)
640  idiag%id_c35 = register_diag_field(trim(field), 'cat35', axes(1:2), time, &
641  'de-pression < 964', 'mb', missing_value=missing_value)
642  idiag%id_c45 = register_diag_field(trim(field), 'cat45', axes(1:2), time, &
643  'de-pression < 944', 'mb', missing_value=missing_value)
644 ! Frequency:
645  idiag%id_f15 = register_diag_field(trim(field), 'f15', axes(1:2), time, &
646  'Cat15 frequency', 'none', missing_value=missing_value)
647  idiag%id_f25 = register_diag_field(trim(field), 'f25', axes(1:2), time, &
648  'Cat25 frequency', 'none', missing_value=missing_value)
649  idiag%id_f35 = register_diag_field(trim(field), 'f35', axes(1:2), time, &
650  'Cat35 frequency', 'none', missing_value=missing_value)
651  idiag%id_f45 = register_diag_field(trim(field), 'f45', axes(1:2), time, &
652  'Cat45 frequency', 'none', missing_value=missing_value)
653 !-------------------
654 ! A grid winds (lat-lon)
655 !-------------------
656  if (atm(n)%flagstruct%write_3d_diags) then
657  idiag%id_ua = register_diag_field( trim(field), 'ucomp', axes(1:3), time, &
658  'zonal wind', 'm/sec', missing_value=missing_value, range=vrange )
659  idiag%id_va = register_diag_field( trim(field), 'vcomp', axes(1:3), time, &
660  'meridional wind', 'm/sec', missing_value=missing_value, range=vrange)
661  if ( .not. atm(n)%flagstruct%hydrostatic ) &
662  idiag%id_w = register_diag_field( trim(field), 'w', axes(1:3), time, &
663  'vertical wind', 'm/sec', missing_value=missing_value, range=wrange )
664 
665  idiag%id_pt = register_diag_field( trim(field), 'temp', axes(1:3), time, &
666  'temperature', 'K', missing_value=missing_value, range=trange )
667  idiag%id_ppt = register_diag_field( trim(field), 'ppt', axes(1:3), time, &
668  'potential temperature perturbation', 'K', missing_value=missing_value )
669  idiag%id_theta_e = register_diag_field( trim(field), 'theta_e', axes(1:3), time, &
670  'theta_e', 'K', missing_value=missing_value )
671  idiag%id_omga = register_diag_field( trim(field), 'omega', axes(1:3), time, &
672  'omega', 'Pa/s', missing_value=missing_value )
673  idiag%id_divg = register_diag_field( trim(field), 'divg', axes(1:3), time, &
674  'mean divergence', '1/s', missing_value=missing_value )
675  ! diagnotic output for skeb testing
676  idiag%id_diss = register_diag_field( trim(field), 'diss_est', axes(1:3), time, &
677  'random', 'none', missing_value=missing_value, range=skrange )
678 
679  idiag%id_rh = register_diag_field( trim(field), 'rh', axes(1:3), time, &
680  'Relative Humidity', '%', missing_value=missing_value )
681  ! 'Relative Humidity', '%', missing_value=missing_value, range=rhrange )
682  idiag%id_delp = register_diag_field( trim(field), 'delp', axes(1:3), time, &
683  'pressure thickness', 'pa', missing_value=missing_value )
684  if ( .not. atm(n)%flagstruct%hydrostatic ) &
685  idiag%id_delz = register_diag_field( trim(field), 'delz', axes(1:3), time, &
686  'height thickness', 'm', missing_value=missing_value )
687  if( atm(n)%flagstruct%hydrostatic ) then
688  idiag%id_pfhy = register_diag_field( trim(field), 'pfhy', axes(1:3), time, &
689  'hydrostatic pressure', 'pa', missing_value=missing_value )
690  else
691  idiag%id_pfnh = register_diag_field( trim(field), 'pfnh', axes(1:3), time, &
692  'non-hydrostatic pressure', 'pa', missing_value=missing_value )
693  endif
694  idiag%id_zratio = register_diag_field( trim(field), 'zratio', axes(1:3), time, &
695  'nonhydro_ratio', 'n/a', missing_value=missing_value )
696  !--------------------
697  ! 3D Condensate
698  !--------------------
699  idiag%id_qn = register_diag_field( trim(field), 'qn', axes(1:3), time, &
700  'cloud condensate', 'kg/m/s^2', missing_value=missing_value )
701  idiag%id_qp = register_diag_field( trim(field), 'qp', axes(1:3), time, &
702  'precip condensate', 'kg/m/s^2', missing_value=missing_value )
703  ! fast moist phys tendencies:
704  idiag%id_mdt = register_diag_field( trim(field), 'mdt', axes(1:3), time, &
705  'DT/Dt: fast moist phys', 'deg/sec', missing_value=missing_value )
706  idiag%id_qdt = register_diag_field( trim(field), 'qdt', axes(1:3), time, &
707  'Dqv/Dt: fast moist phys', 'kg/kg/sec', missing_value=missing_value )
708  idiag%id_dbz = register_diag_field( trim(field), 'reflectivity', axes(1:3), time, &
709  'Stoelinga simulated reflectivity', 'dBz', missing_value=missing_value)
710 
711  !--------------------
712  ! Relative vorticity
713  !--------------------
714  idiag%id_vort = register_diag_field( trim(field), 'vort', axes(1:3), time, &
715  'vorticity', '1/s', missing_value=missing_value )
716  !--------------------
717  ! Potential vorticity
718  !--------------------
719  idiag%id_pv = register_diag_field( trim(field), 'pv', axes(1:3), time, &
720  'potential vorticity', '1/s', missing_value=missing_value )
721 
722  endif
723 
724 ! Total energy (only when moist_phys = .T.)
725  idiag%id_te = register_diag_field( trim(field), 'te', axes(1:2), time, &
726  'Total Energy', 'J/kg', missing_value=missing_value )
727 ! Total Kinetic energy
728  idiag%id_ke = register_diag_field( trim(field), 'ke', axes(1:2), time, &
729  'Total KE', 'm^2/s^2', missing_value=missing_value )
730  idiag%id_ws = register_diag_field( trim(field), 'ws', axes(1:2), time, &
731  'Terrain W', 'm/s', missing_value=missing_value )
732  idiag%id_maxdbz = register_diag_field( trim(field), 'max_reflectivity', axes(1:2), time, &
733  'Stoelinga simulated maximum (composite) reflectivity', 'dBz', missing_value=missing_value)
734  idiag%id_basedbz = register_diag_field( trim(field), 'base_reflectivity', axes(1:2), time, &
735  'Stoelinga simulated base (1 km AGL) reflectivity', 'dBz', missing_value=missing_value)
736  idiag%id_dbz4km = register_diag_field( trim(field), '4km_reflectivity', axes(1:2), time, &
737  'Stoelinga simulated base reflectivity', 'dBz', missing_value=missing_value)
738  idiag%id_dbztop = register_diag_field( trim(field), 'echo_top', axes(1:2), time, &
739  'Echo top ( <= 18.5 dBz )', 'm', missing_value=missing_value2)
740  idiag%id_dbz_m10C = register_diag_field( trim(field), 'm10C_reflectivity', axes(1:2), time, &
741  'Reflectivity at -10C level', 'm', missing_value=missing_value)
742 
743 !--------------------------
744 ! Extra surface diagnistics:
745 !--------------------------
746 ! Surface (lowest layer) vorticity: for tropical cyclones diag.
747  idiag%id_vorts = register_diag_field( trim(field), 'vorts', axes(1:2), time, &
748  'surface vorticity', '1/s', missing_value=missing_value )
749  idiag%id_us = register_diag_field( trim(field), 'us', axes(1:2), time, &
750  'surface u-wind', 'm/sec', missing_value=missing_value, range=vsrange )
751  idiag%id_vs = register_diag_field( trim(field), 'vs', axes(1:2), time, &
752  'surface v-wind', 'm/sec', missing_value=missing_value, range=vsrange )
753  idiag%id_tq = register_diag_field( trim(field), 'tq', axes(1:2), time, &
754  'Total water path', 'kg/m**2', missing_value=missing_value )
755  idiag%id_iw = register_diag_field( trim(field), 'iw', axes(1:2), time, &
756  'Ice water path', 'kg/m**2', missing_value=missing_value )
757  idiag%id_lw = register_diag_field( trim(field), 'lw', axes(1:2), time, &
758  'Liquid water path', 'kg/m**2', missing_value=missing_value )
759  idiag%id_ts = register_diag_field( trim(field), 'ts', axes(1:2), time, &
760  'Skin temperature', 'K' )
761  idiag%id_tb = register_diag_field( trim(field), 'tb', axes(1:2), time, &
762  'lowest layer temperature', 'K' )
763  idiag%id_ctt = register_diag_field( trim(field), 'ctt', axes(1:2), time, &
764  'cloud_top temperature', 'K', missing_value=missing_value3 )
765  idiag%id_ctp = register_diag_field( trim(field), 'ctp', axes(1:2), time, &
766  'cloud_top pressure', 'hPa' , missing_value=missing_value3 )
767  idiag%id_ctz = register_diag_field( trim(field), 'ctz', axes(1:2), time, &
768  'cloud_top height', 'hPa' , missing_value=missing_value2 )
769  idiag%id_cape = register_diag_field( trim(field), 'cape', axes(1:2), time, &
770  'Convective available potential energy (surface-based)', 'J/kg' , missing_value=missing_value )
771  idiag%id_cin = register_diag_field( trim(field), 'cin', axes(1:2), time, &
772  'Convective inhibition (surface-based)', 'J/kg' , missing_value=missing_value )
773 #ifdef HIWPP
774  idiag%id_acl = register_diag_field( trim(field), 'acl', axes(1:2), time, &
775  'Column-averaged Cl mixing ratio', 'kg/kg', missing_value=missing_value )
776  idiag%id_acl2 = register_diag_field( trim(field), 'acl2', axes(1:2), time, &
777  'Column-averaged Cl2 mixing ratio', 'kg/kg', missing_value=missing_value )
778  idiag%id_acly = register_diag_field( trim(field), 'acly', axes(1:2), time, &
779  'Column-averaged total chlorine mixing ratio', 'kg/kg', missing_value=missing_value )
780 #endif
781 
782 !--------------------------
783 ! 850-mb vorticity
784 !--------------------------
785  idiag%id_vort850 = register_diag_field( trim(field), 'vort850', axes(1:2), time, &
786  '850-mb vorticity', '1/s', missing_value=missing_value )
787 
788  idiag%id_vort200 = register_diag_field( trim(field), 'vort200', axes(1:2), time, &
789  '200-mb vorticity', '1/s', missing_value=missing_value )
790 
791 ! Cubed_2_latlon interpolation is more accurate, particularly near the poles, using
792 ! winds speed (a scalar), rather than wind vectors or kinetic energy directly.
793  idiag%id_s200 = register_diag_field( trim(field), 's200', axes(1:2), time, &
794  '200-mb wind_speed', 'm/s', missing_value=missing_value )
795  idiag%id_sl12 = register_diag_field( trim(field), 'sl12', axes(1:2), time, &
796  '12th L wind_speed', 'm/s', missing_value=missing_value )
797  idiag%id_sl13 = register_diag_field( trim(field), 'sl13', axes(1:2), time, &
798  '13th L wind_speed', 'm/s', missing_value=missing_value )
799 ! Selceted (HIWPP) levels of non-precip condensates:
800  idiag%id_qn200 = register_diag_field( trim(field), 'qn200', axes(1:2), time, &
801  '200mb condensate', 'kg/m/s^2', missing_value=missing_value )
802  idiag%id_qn500 = register_diag_field( trim(field), 'qn500', axes(1:2), time, &
803  '500mb condensate', 'kg/m/s^2', missing_value=missing_value )
804  idiag%id_qn850 = register_diag_field( trim(field), 'qn850', axes(1:2), time, &
805  '850mb condensate', 'kg/m/s^2', missing_value=missing_value )
806 
807  idiag%id_vort500 = register_diag_field( trim(field), 'vort500', axes(1:2), time, &
808  '500-mb vorticity', '1/s', missing_value=missing_value )
809 
810  idiag%id_rain5km = register_diag_field( trim(field), 'rain5km', axes(1:2), time, &
811  '5-km AGL liquid water', 'kg/kg', missing_value=missing_value )
812 !--------------------------
813 ! w on height or pressure levels
814 !--------------------------
815  if( .not. atm(n)%flagstruct%hydrostatic ) then
816  idiag%id_w200 = register_diag_field( trim(field), 'w200', axes(1:2), time, &
817  '200-mb w-wind', 'm/s', missing_value=missing_value )
818  idiag%id_w500 = register_diag_field( trim(field), 'w500', axes(1:2), time, &
819  '500-mb w-wind', 'm/s', missing_value=missing_value )
820  idiag%id_w700 = register_diag_field( trim(field), 'w700', axes(1:2), time, &
821  '700-mb w-wind', 'm/s', missing_value=missing_value )
822 
823  idiag%id_w850 = register_diag_field( trim(field), 'w850', axes(1:2), time, &
824  '850-mb w-wind', 'm/s', missing_value=missing_value )
825  idiag%id_w5km = register_diag_field( trim(field), 'w5km', axes(1:2), time, &
826  '5-km AGL w-wind', 'm/s', missing_value=missing_value )
827  idiag%id_w2500m = register_diag_field( trim(field), 'w2500m', axes(1:2), time, &
828  '2.5-km AGL w-wind', 'm/s', missing_value=missing_value )
829  idiag%id_w1km = register_diag_field( trim(field), 'w1km', axes(1:2), time, &
830  '1-km AGL w-wind', 'm/s', missing_value=missing_value )
831  idiag%id_wmaxup = register_diag_field( trim(field), 'wmaxup', axes(1:2), time, &
832  'column-maximum updraft', 'm/s', missing_value=missing_value )
833  idiag%id_wmaxdn = register_diag_field( trim(field), 'wmaxdn', axes(1:2), time, &
834  'column-maximum downdraft', 'm/s', missing_value=missing_value )
835 
836  endif
837 
838 ! helicity
839  idiag%id_x850 = register_diag_field( trim(field), 'x850', axes(1:2), time, &
840  '850-mb vertical comp. of helicity', 'm/s**2', missing_value=missing_value )
841 ! idiag%id_x03 = register_diag_field ( trim(field), 'x03', axes(1:2), Time, &
842 ! '0-3 km vertical comp. of helicity', 'm**2/s**2', missing_value=missing_value )
843 ! idiag%id_x25 = register_diag_field ( trim(field), 'x25', axes(1:2), Time, &
844 ! '2-5 km vertical comp. of helicity', 'm**2/s**2', missing_value=missing_value )
845 
846 ! Storm Relative Helicity
847  idiag%id_srh1 = register_diag_field( trim(field), 'srh01', axes(1:2), time, &
848  '0-1 km Storm Relative Helicity', 'm/s**2', missing_value=missing_value )
849  idiag%id_srh3 = register_diag_field( trim(field), 'srh03', axes(1:2), time, &
850  '0-3 km Storm Relative Helicity', 'm/s**2', missing_value=missing_value )
851  idiag%id_ustm = register_diag_field( trim(field), 'ustm', axes(1:2), time, &
852  'u Component of Storm Motion', 'm/s', missing_value=missing_value )
853  idiag%id_vstm = register_diag_field( trim(field), 'vstm', axes(1:2), time, &
854  'v Component of Storm Motion', 'm/s', missing_value=missing_value )
855 
856  idiag%id_srh25 = register_diag_field( trim(field), 'srh25', axes(1:2), time, &
857  '2-5 km Storm Relative Helicity', 'm/s**2', missing_value=missing_value )
858 
859  if( .not. atm(n)%flagstruct%hydrostatic ) then
860  idiag%id_uh03 = register_diag_field( trim(field), 'uh03', axes(1:2), time, &
861  '0-3 km Updraft Helicity', 'm/s**2', missing_value=missing_value )
862  idiag%id_uh25 = register_diag_field( trim(field), 'uh25', axes(1:2), time, &
863  '2-5 km Updraft Helicity', 'm/s**2', missing_value=missing_value )
864  endif
865 ! TC test winds at 100 m
866  if( .not. atm(n)%flagstruct%hydrostatic ) &
867  idiag%id_w100m = register_diag_field( trim(field), 'w100m', axes(1:2), time, &
868  '100-m AGL w-wind', 'm/s', missing_value=missing_value )
869  idiag%id_u100m = register_diag_field( trim(field), 'u100m', axes(1:2), time, &
870  '100-m AGL u-wind', 'm/s', missing_value=missing_value )
871  idiag%id_v100m = register_diag_field( trim(field), 'v100m', axes(1:2), time, &
872  '100-m AGL v-wind', 'm/s', missing_value=missing_value )
873 !--------------------------
874 ! relative humidity (physics definition):
875 !--------------------------
876  idiag%id_rh10 = register_diag_field( trim(field), 'rh10', axes(1:2), time, &
877  '10-mb relative humidity', '%', missing_value=missing_value )
878  idiag%id_rh50 = register_diag_field( trim(field), 'rh50', axes(1:2), time, &
879  '50-mb relative humidity', '%', missing_value=missing_value )
880  idiag%id_rh100 = register_diag_field( trim(field), 'rh100', axes(1:2), time, &
881  '100-mb relative humidity', '%', missing_value=missing_value )
882  idiag%id_rh200 = register_diag_field( trim(field), 'rh200', axes(1:2), time, &
883  '200-mb relative humidity', '%', missing_value=missing_value )
884  idiag%id_rh250 = register_diag_field( trim(field), 'rh250', axes(1:2), time, &
885  '250-mb relative humidity', '%', missing_value=missing_value )
886  idiag%id_rh300 = register_diag_field( trim(field), 'rh300', axes(1:2), time, &
887  '300-mb relative humidity', '%', missing_value=missing_value )
888  idiag%id_rh500 = register_diag_field( trim(field), 'rh500', axes(1:2), time, &
889  '500-mb relative humidity', '%', missing_value=missing_value )
890  idiag%id_rh700 = register_diag_field( trim(field), 'rh700', axes(1:2), time, &
891  '700-mb relative humidity', '%', missing_value=missing_value )
892  idiag%id_rh850 = register_diag_field( trim(field), 'rh850', axes(1:2), time, &
893  '850-mb relative humidity', '%', missing_value=missing_value )
894  idiag%id_rh925 = register_diag_field( trim(field), 'rh925', axes(1:2), time, &
895  '925-mb relative humidity', '%', missing_value=missing_value )
896  idiag%id_rh1000 = register_diag_field( trim(field), 'rh1000', axes(1:2), time, &
897  '1000-mb relative humidity', '%', missing_value=missing_value )
898 !--------------------------
899 ! Dew Point
900 !--------------------------
901  idiag%id_dp10 = register_diag_field( trim(field), 'dp10', axes(1:2), time, &
902  '10-mb dew point', 'K', missing_value=missing_value )
903  idiag%id_dp50 = register_diag_field( trim(field), 'dp50', axes(1:2), time, &
904  '50-mb dew point', 'K', missing_value=missing_value )
905  idiag%id_dp100 = register_diag_field( trim(field), 'dp100', axes(1:2), time, &
906  '100-mb dew point', 'K', missing_value=missing_value )
907  idiag%id_dp200 = register_diag_field( trim(field), 'dp200', axes(1:2), time, &
908  '200-mb dew point', 'K', missing_value=missing_value )
909  idiag%id_dp250 = register_diag_field( trim(field), 'dp250', axes(1:2), time, &
910  '250-mb dew point', 'K', missing_value=missing_value )
911  idiag%id_dp300 = register_diag_field( trim(field), 'dp300', axes(1:2), time, &
912  '300-mb dew point', 'K', missing_value=missing_value )
913  idiag%id_dp500 = register_diag_field( trim(field), 'dp500', axes(1:2), time, &
914  '500-mb dew point', 'K', missing_value=missing_value )
915  idiag%id_dp700 = register_diag_field( trim(field), 'dp700', axes(1:2), time, &
916  '700-mb dew point', 'K', missing_value=missing_value )
917  idiag%id_dp850 = register_diag_field( trim(field), 'dp850', axes(1:2), time, &
918  '850-mb dew point', 'K', missing_value=missing_value )
919  idiag%id_dp925 = register_diag_field( trim(field), 'dp925', axes(1:2), time, &
920  '925-mb dew point', 'K', missing_value=missing_value )
921  idiag%id_dp1000 = register_diag_field( trim(field), 'dp1000', axes(1:2), time, &
922  '1000-mb dew point', 'K', missing_value=missing_value )
923 !--------------------------
924 ! relative humidity (CMIP definition):
925 !--------------------------
926  idiag%id_rh10_cmip = register_diag_field( trim(field), 'rh10_cmip', axes(1:2), time, &
927  '10-mb relative humidity (CMIP)', '%', missing_value=missing_value )
928  idiag%id_rh50_cmip = register_diag_field( trim(field), 'rh50_cmip', axes(1:2), time, &
929  '50-mb relative humidity (CMIP)', '%', missing_value=missing_value )
930  idiag%id_rh100_cmip = register_diag_field( trim(field), 'rh100_cmip', axes(1:2), time, &
931  '100-mb relative humidity (CMIP)', '%', missing_value=missing_value )
932  idiag%id_rh250_cmip = register_diag_field( trim(field), 'rh250_cmip', axes(1:2), time, &
933  '250-mb relative humidity (CMIP)', '%', missing_value=missing_value )
934  idiag%id_rh300_cmip = register_diag_field( trim(field), 'rh300_cmip', axes(1:2), time, &
935  '300-mb relative humidity (CMIP)', '%', missing_value=missing_value )
936  idiag%id_rh500_cmip = register_diag_field( trim(field), 'rh500_cmip', axes(1:2), time, &
937  '500-mb relative humidity (CMIP)', '%', missing_value=missing_value )
938  idiag%id_rh700_cmip = register_diag_field( trim(field), 'rh700_cmip', axes(1:2), time, &
939  '700-mb relative humidity (CMIP)', '%', missing_value=missing_value )
940  idiag%id_rh850_cmip = register_diag_field( trim(field), 'rh850_cmip', axes(1:2), time, &
941  '850-mb relative humidity (CMIP)', '%', missing_value=missing_value )
942  idiag%id_rh925_cmip = register_diag_field( trim(field), 'rh925_cmip', axes(1:2), time, &
943  '925-mb relative humidity (CMIP)', '%', missing_value=missing_value )
944  idiag%id_rh1000_cmip = register_diag_field( trim(field), 'rh1000_cmip', axes(1:2), time, &
945  '1000-mb relative humidity (CMIP)', '%', missing_value=missing_value )
946 
947  if (atm(n)%flagstruct%write_3d_diags) then
948  do i=1, ncnst
949  !--------------------
950  ! Tracer diagnostics:
951  !--------------------
952  call get_tracer_names ( model_atmos, i, tname, tlongname, tunits )
953  idiag%id_tracer(i) = register_diag_field( field, trim(tname), &
954  axes(1:3), time, trim(tlongname), &
956  if (master) then
957  if (idiag%id_tracer(i) > 0) then
958  unit = stdlog()
959  write(unit,'(a,a,a,a)') &
960  & 'Diagnostics available for tracer ',trim(tname), &
961  ' in module ', trim(field)
962  end if
963  endif
964  !----------------------------------
965  ! ESM Tracer dmmr/dvmr diagnostics:
966  ! for specific elements only
967  !----------------------------------
968  !---co2
969  if (trim(tname).eq.'co2') then
970  idiag%w_mr(:) = wtmco2
971  idiag%id_tracer_dmmr(i) = register_diag_field( field, trim(tname)//'_dmmr', &
972  axes(1:3), time, trim(tlongname)//" (dry mmr)", &
974  idiag%id_tracer_dvmr(i) = register_diag_field( field, trim(tname)//'_dvmr', &
975  axes(1:3), time, trim(tlongname)//" (dry vmr)", &
976  'mol/mol', missing_value=missing_value)
977  if (master) then
978  unit = stdlog()
979  if (idiag%id_tracer_dmmr(i) > 0) then
980  write(unit,'(a,a,a,a)') 'Diagnostics available for '//trim(tname)//' dry mmr ', &
981  trim(tname)//'_dmmr', ' in module ', trim(field)
982  end if
983  if (idiag%id_tracer_dvmr(i) > 0) then
984  write(unit,'(a,a,a,a)') 'Diagnostics available for '//trim(tname)//' dry vmr ', &
985  trim(tname)//'_dvmr', ' in module ', trim(field)
986  end if
987  endif
988  endif
989  !---end co2
990 
991  enddo
992  endif
993 
994  if ( atm(1)%flagstruct%consv_am .or. idiag%id_mq > 0 .or. idiag%id_amdt > 0 ) then
995  allocate ( idiag%zxg(isc:iec,jsc:jec) )
996  ! Initialize gradient of terrain for mountain torque computation:
997  call init_mq(atm(n)%phis, atm(n)%gridstruct, &
998  npx, npy, isc, iec, jsc, jec, atm(n)%ng)
999  endif
1000 
1001 ! end do
1002 
1003 
1004 #ifdef TEST_TRACER
1005  call prt_mass(npz, atm(n)%ncnst, isc, iec, jsc, jec, atm(n)%ng, max(1,atm(n)%flagstruct%nwat), &
1006  atm(n)%ps, atm(n)%delp, atm(n)%q, atm(n)%gridstruct%area_64, atm(n)%domain)
1007 #else
1008  call prt_mass(npz, atm(n)%ncnst, isc, iec, jsc, jec, atm(n)%ng, atm(n)%flagstruct%nwat, &
1009  atm(n)%ps, atm(n)%delp, atm(n)%q, atm(n)%gridstruct%area_64, atm(n)%domain)
1010 #endif
1011 
1012  call nullify_domain() ! Nullify set_domain info
1013 
1014  module_is_initialized=.true.
1015  istep = 0
1016 #ifndef GFS_PHYS
1017  if(idiag%id_theta_e >0 ) call qsmith_init
1018 #endif
1019  end subroutine fv_diag_init
1020 
1021 
1022  subroutine init_mq(phis, gridstruct, npx, npy, is, ie, js, je, ng)
1023  integer, intent(in):: npx, npy, is, ie, js, je, ng
1024  real, intent(in):: phis(is-ng:ie+ng, js-ng:je+ng)
1025  type(fv_grid_type), intent(IN), target :: gridstruct
1026 
1027 ! local:
1028  real zs(is-ng:ie+ng, js-ng:je+ng)
1029  real zb(is-ng:ie+ng, js-ng:je+ng)
1030  real pdx(3,is:ie,js:je+1)
1031  real pdy(3,is:ie+1,js:je)
1032  integer i, j, n
1033 
1034  real, pointer :: rarea(:,:)
1035  real, pointer, dimension(:,:) :: dx, dy
1036  real(kind=R_GRID), pointer, dimension(:,:,:) :: en1, en2, vlon, vlat
1037  real, pointer, dimension(:,:,:) :: agrid
1038 
1039  rarea => gridstruct%rarea
1040  dx => gridstruct%dx
1041  dy => gridstruct%dy
1042  en1 => gridstruct%en1
1043  en2 => gridstruct%en2
1044  agrid => gridstruct%agrid
1045  vlon => gridstruct%vlon
1046  vlat => gridstruct%vlat
1047 
1048 ! do j=js,je
1049 ! do i=is,ie
1050  do j=js-ng,je+ng
1051  do i=is-ng,ie+ng
1052  zs(i,j) = phis(i,j) / grav
1053  enddo
1054  enddo
1055 ! call mpp_update_domains( zs, domain )
1056 
1057 ! call a2b_ord2(zs, zb, gridstruct, npx, npy, is, ie, js, je, ng)
1058  call a2b_ord4(zs, zb, gridstruct, npx, npy, is, ie, js, je, ng)
1059 
1060  do j=js,je+1
1061  do i=is,ie
1062  do n=1,3
1063  pdx(n,i,j) = 0.5*(zb(i,j)+zb(i+1,j))*dx(i,j)*en1(n,i,j)
1064  enddo
1065  enddo
1066  enddo
1067  do j=js,je
1068  do i=is,ie+1
1069  do n=1,3
1070  pdy(n,i,j) = 0.5*(zb(i,j)+zb(i,j+1))*dy(i,j)*en2(n,i,j)
1071  enddo
1072  enddo
1073  enddo
1074 
1075 ! Compute "volume-mean" gradient by Green's theorem
1076  do j=js,je
1077  do i=is,ie
1078  idiag%zxg(i,j) = vlon(i,j,1)*(pdx(1,i,j+1)-pdx(1,i,j)-pdy(1,i,j)+pdy(1,i+1,j)) &
1079  + vlon(i,j,2)*(pdx(2,i,j+1)-pdx(2,i,j)-pdy(2,i,j)+pdy(2,i+1,j)) &
1080  + vlon(i,j,3)*(pdx(3,i,j+1)-pdx(3,i,j)-pdy(3,i,j)+pdy(3,i+1,j))
1081 ! dF/d(lamda) = radius*cos(agrid(i,j,2)) * dF/dx, F is a scalar
1082 ! ________________________
1083  idiag%zxg(i,j) = idiag%zxg(i,j)*rarea(i,j) * radius*cos(agrid(i,j,2))
1084 ! ^^^^^^^^^^^^^^^^^^^^^^^^
1085  enddo
1086  enddo
1087 
1088  end subroutine init_mq
1089 
1090  subroutine fv_diag(Atm, zvir, Time, print_freq)
1092  type(fv_atmos_type), intent(inout) :: Atm(:)
1093  type(time_type), intent(in) :: Time
1094  real, intent(in):: zvir
1095  integer, intent(in):: print_freq
1096 
1097  integer :: isc, iec, jsc, jec, n, ntileMe
1098  integer :: isd, ied, jsd, jed, npz, itrac
1099  integer :: ngc, nwater
1100 
1101  real, allocatable :: a2(:,:),a3(:,:,:), wk(:,:,:), wz(:,:,:), ucoor(:,:,:), vcoor(:,:,:)
1102  real, allocatable :: ustm(:,:), vstm(:,:)
1103  real, allocatable :: slp(:,:), depress(:,:), ws_max(:,:), tc_count(:,:)
1104  real, allocatable :: u2(:,:), v2(:,:), x850(:,:), var1(:,:), var2(:,:), var3(:,:)
1105  real, allocatable :: dmmr(:,:,:), dvmr(:,:,:)
1106  real height(2)
1107  real:: plevs(nplev), pout(nplev)
1108  integer:: idg(nplev), id1(nplev)
1109  real :: tot_mq, tmp, sar, slon, slat
1110  real :: a1d(atm(1)%npz)
1111 ! real :: t_gb, t_nh, t_sh, t_eq, area_gb, area_nh, area_sh, area_eq
1112  logical :: do_cs_intp
1113  logical :: used
1114  logical :: bad_range
1115  integer i,j,k, yr, mon, dd, hr, mn, days, seconds, nq, theta_d
1116  character(len=128) :: tname
1117  real, parameter:: ws_0 = 16. ! minimum max_wind_speed within the 7x7 search box
1118  real, parameter:: ws_1 = 20.
1119  real, parameter:: vort_c0= 2.2e-5
1120  logical, allocatable :: storm(:,:), cat_crt(:,:)
1121  real :: tmp2, pvsum, e2, einf, qm, mm, maxdbz, allmax, rgrav
1122  integer :: Cl, Cl2
1123  !!! CLEANUP: does it really make sense to have this routine loop over Atm% anymore? We assume n=1 below anyway
1124 
1125 ! cat15: SLP<1000; srf_wnd>ws_0; vort>vort_c0
1126 ! cat25: SLP< 980; srf_wnd>ws_1; vort>vort_c0
1127 ! cat35: SLP< 964; srf_wnd>ws_1; vort>vort_c0
1128 ! cat45: SLP< 944; srf_wnd>ws_1; vort>vort_c0
1129 
1130  height(1) = 5.e3 ! for computing 5-km "pressure"
1131  height(2) = 0. ! for sea-level pressure
1132 
1133  do i=1,nplev
1134  pout(i) = levs(i) * 1.e2
1135  plevs(i) = log( pout(i) )
1136  enddo
1137 
1138  ntileme = size(atm(:))
1139  n = 1
1140  isc = atm(n)%bd%isc; iec = atm(n)%bd%iec
1141  jsc = atm(n)%bd%jsc; jec = atm(n)%bd%jec
1142  ngc = atm(n)%ng
1143  npz = atm(n)%npz
1144  ptop = atm(n)%ak(1)
1145  nq = size (atm(n)%q,4)
1146 
1147  isd = atm(n)%bd%isd; ied = atm(n)%bd%ied
1148  jsd = atm(n)%bd%jsd; jed = atm(n)%bd%jed
1149 
1150  if( idiag%id_c15>0 ) then
1151  allocate ( storm(isc:iec,jsc:jec) )
1152  allocate ( depress(isc:iec,jsc:jec) )
1153  allocate ( ws_max(isc:iec,jsc:jec) )
1154  allocate ( cat_crt(isc:iec,jsc:jec) )
1155  allocate (tc_count(isc:iec,jsc:jec) )
1156  endif
1157 
1158  if( idiag%id_x850>0 ) then
1159  allocate ( x850(isc:iec,jsc:jec) )
1160  endif
1161 
1162  fv_time = time
1163  call set_domain(atm(1)%domain)
1164 
1165  if ( m_calendar ) then
1166  call get_date(fv_time, yr, mon, dd, hr, mn, seconds)
1167  if( print_freq == 0 ) then
1168  prt_minmax = .false.
1169  elseif( print_freq < 0 ) then
1170  istep = istep + 1
1171  prt_minmax = mod(istep, -print_freq) == 0
1172  else
1173  prt_minmax = mod(hr, print_freq) == 0 .and. mn==0 .and. seconds==0
1174  endif
1175  else
1176  call get_time (fv_time, seconds, days)
1177  if( print_freq == 0 ) then
1178  prt_minmax = .false.
1179  elseif( print_freq < 0 ) then
1180  istep = istep + 1
1181  prt_minmax = mod(istep, -print_freq) == 0
1182  else
1183  prt_minmax = mod(seconds, 3600*print_freq) == 0
1184  endif
1185  endif
1186 
1187  if(prt_minmax) then
1188  if ( m_calendar ) then
1189  if(master) write(*,*) yr, mon, dd, hr, mn, seconds
1190  else
1191  if(master) write(*,*) days, seconds
1192  endif
1193  endif
1194 
1195  allocate ( a2(isc:iec,jsc:jec) )
1196 
1197  if( prt_minmax ) then
1198 
1199  call prt_mxm('ZS', idiag%zsurf, isc, iec, jsc, jec, 0, 1, 1.0, atm(n)%gridstruct%area_64, atm(n)%domain)
1200  call prt_maxmin('PS', atm(n)%ps, isc, iec, jsc, jec, ngc, 1, 0.01)
1201 
1202 #ifdef HIWPP
1203  allocate(var2(isc:iec,jsc:jec))
1204  !hemispheric max/min pressure
1205  do j=jsc,jec
1206  do i=isc,iec
1207  slat = rad2deg*atm(n)%gridstruct%agrid(i,j,2)
1208  if (slat >= 0.) then
1209  a2(i,j) = atm(n)%ps(i,j)
1210  var2(i,j) = 101300.
1211  else
1212  a2(i,j) = 101300.
1213  var2(i,j) = atm(n)%ps(i,j)
1214  endif
1215  enddo
1216  enddo
1217  call prt_maxmin('NH PS', a2, isc, iec, jsc, jec, 0, 1, 0.01)
1218  call prt_maxmin('SH PS', var2, isc, iec, jsc, jec, 0, 1, 0.01)
1219 
1220  deallocate(var2)
1221 #endif
1222 
1223 #ifdef TEST_TRACER
1224  call prt_mass(npz, nq, isc, iec, jsc, jec, ngc, max(1,atm(n)%flagstruct%nwat), &
1225  atm(n)%ps, atm(n)%delp, atm(n)%q, atm(n)%gridstruct%area_64, atm(n)%domain)
1226 #else
1227  call prt_mass(npz, nq, isc, iec, jsc, jec, ngc, atm(n)%flagstruct%nwat, &
1228  atm(n)%ps, atm(n)%delp, atm(n)%q, atm(n)%gridstruct%area_64, atm(n)%domain)
1229 #endif
1230 
1231 #ifndef SW_DYNAMICS
1232  if (atm(n)%flagstruct%consv_te > 1.e-5) then
1233  idiag%steps = idiag%steps + 1
1234  idiag%efx_sum = idiag%efx_sum + e_flux
1235  if ( idiag%steps <= max_step ) idiag%efx(idiag%steps) = e_flux
1236  if (master) then
1237  write(*,*) 'ENG Deficit (W/m**2)', trim(gn), '=', e_flux
1238  endif
1239 
1240 
1241  endif
1242  if ( .not. atm(n)%flagstruct%hydrostatic ) &
1243  call nh_total_energy(isc, iec, jsc, jec, isd, ied, jsd, jed, npz, &
1244  atm(n)%w, atm(n)%delz, atm(n)%pt, atm(n)%delp, &
1245  atm(n)%q, atm(n)%phis, atm(n)%gridstruct%area, atm(n)%domain, &
1246  sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, atm(n)%flagstruct%nwat, &
1247  atm(n)%ua, atm(n)%va, atm(n)%flagstruct%moist_phys, a2)
1248 #endif
1249  call prt_maxmin('UA_top', atm(n)%ua(isc:iec,jsc:jec,1), &
1250  isc, iec, jsc, jec, 0, 1, 1.)
1251  call prt_maxmin('UA', atm(n)%ua, isc, iec, jsc, jec, ngc, npz, 1.)
1252  call prt_maxmin('VA', atm(n)%va, isc, iec, jsc, jec, ngc, npz, 1.)
1253 
1254  if ( .not. atm(n)%flagstruct%hydrostatic ) then
1255  call prt_maxmin('W ', atm(n)%w , isc, iec, jsc, jec, ngc, npz, 1.)
1256  call prt_maxmin('Bottom w', atm(n)%w(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1.)
1257  do j=jsc,jec
1258  do i=isc,iec
1259  a2(i,j) = -atm(n)%w(i,j,npz)/atm(n)%delz(i,j,npz)
1260  enddo
1261  enddo
1262  call prt_maxmin('Bottom: w/dz', a2, isc, iec, jsc, jec, 0, 1, 1.)
1263 
1264  if ( atm(n)%flagstruct%hybrid_z ) call prt_maxmin('Hybrid_ZTOP (km)', atm(n)%ze0(isc:iec,jsc:jec,1), &
1265  isc, iec, jsc, jec, 0, 1, 1.e-3)
1266  call prt_maxmin('DZ (m)', atm(n)%delz(isc:iec,jsc:jec,1:npz), &
1267  isc, iec, jsc, jec, 0, npz, 1.)
1268  call prt_maxmin('Bottom DZ (m)', atm(n)%delz(isc:iec,jsc:jec,npz), &
1269  isc, iec, jsc, jec, 0, 1, 1.)
1270 ! call prt_maxmin('Top DZ (m)', Atm(n)%delz(isc:iec,jsc:jec,1), &
1271 ! isc, iec, jsc, jec, 0, 1, 1.)
1272  endif
1273 
1274 #ifndef SW_DYNAMICS
1275  call prt_maxmin('TA', atm(n)%pt, isc, iec, jsc, jec, ngc, npz, 1.)
1276 ! call prt_maxmin('Top: TA', Atm(n)%pt(isc:iec,jsc:jec, 1), isc, iec, jsc, jec, 0, 1, 1.)
1277 ! call prt_maxmin('Bot: TA', Atm(n)%pt(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1.)
1278  call prt_maxmin('OM', atm(n)%omga, isc, iec, jsc, jec, ngc, npz, 1.)
1279 #endif
1280 
1281  elseif ( atm(n)%flagstruct%range_warn ) then
1282  call range_check('DELP', atm(n)%delp, isc, iec, jsc, jec, ngc, npz, atm(n)%gridstruct%agrid, &
1283  0.01*ptop, 200.e2, bad_range)
1284  call range_check('UA', atm(n)%ua, isc, iec, jsc, jec, ngc, npz, atm(n)%gridstruct%agrid, &
1285  -250., 250., bad_range)
1286  call range_check('VA', atm(n)%va, isc, iec, jsc, jec, ngc, npz, atm(n)%gridstruct%agrid, &
1287  -250., 250., bad_range)
1288 #ifndef SW_DYNAMICS
1289  call range_check('TA', atm(n)%pt, isc, iec, jsc, jec, ngc, npz, atm(n)%gridstruct%agrid, &
1290 #ifdef HIWPP
1291  130., 350., bad_range) !DCMIP ICs have very low temperatures
1292 #else
1293  150., 350., bad_range)
1294 #endif
1295 #endif
1296 
1297  endif
1298 
1299  allocate ( u2(isc:iec,jsc:jec) )
1300  allocate ( v2(isc:iec,jsc:jec) )
1301  allocate ( wk(isc:iec,jsc:jec,npz) )
1302  if ( any(idiag%id_tracer_dmmr > 0) .or. any(idiag%id_tracer_dvmr > 0) ) then
1303  allocate ( dmmr(isc:iec,jsc:jec,1:npz) )
1304  allocate ( dvmr(isc:iec,jsc:jec,1:npz) )
1305  endif
1306 
1307 ! do n = 1, ntileMe
1308  n = 1
1309 
1310 #ifdef DYNAMICS_ZS
1311  if(idiag%id_zsurf > 0) used=send_data(idiag%id_zsurf, idiag%zsurf, time)
1312 #endif
1313  if(idiag%id_ps > 0) used=send_data(idiag%id_ps, atm(n)%ps(isc:iec,jsc:jec), time)
1314 
1315  if(idiag%id_c15>0 .or. idiag%id_c25>0 .or. idiag%id_c35>0 .or. idiag%id_c45>0) then
1316  call wind_max(isc, iec, jsc, jec ,isd, ied, jsd, jed, atm(n)%ua(isc:iec,jsc:jec,npz), &
1317  atm(n)%va(isc:iec,jsc:jec,npz), ws_max, atm(n)%domain)
1318  do j=jsc,jec
1319  do i=isc,iec
1320  if( abs(atm(n)%gridstruct%agrid(i,j,2)*rad2deg)<45.0 .and. &
1321  atm(n)%phis(i,j)*ginv<500.0 .and. ws_max(i,j)>ws_0 ) then
1322  storm(i,j) = .true.
1323  else
1324  storm(i,j) = .false.
1325  endif
1326  enddo
1327  enddo
1328  endif
1329 
1330  if ( idiag%id_vort200>0 .or. idiag%id_vort500>0 .or. idiag%id_vort850>0 .or. idiag%id_vorts>0 &
1331  .or. idiag%id_vort>0 .or. idiag%id_pv>0 .or. idiag%id_rh>0 .or. idiag%id_x850>0 .or. &
1332  idiag%id_uh03>0 .or. idiag%id_uh25>0) then
1333  call get_vorticity(isc, iec, jsc, jec, isd, ied, jsd, jed, npz, atm(n)%u, atm(n)%v, wk, &
1334  atm(n)%gridstruct%dx, atm(n)%gridstruct%dy, atm(n)%gridstruct%rarea)
1335 
1336  if(idiag%id_vort >0) used=send_data(idiag%id_vort, wk, time)
1337  if(idiag%id_vorts>0) used=send_data(idiag%id_vorts, wk(isc:iec,jsc:jec,npz), time)
1338 
1339  if(idiag%id_c15>0) then
1340  do j=jsc,jec
1341  do i=isc,iec
1342  if ( storm(i,j) ) &
1343  storm(i,j) = (atm(n)%gridstruct%agrid(i,j,2)>0. .and. wk(i,j,npz)> vort_c0) .or. &
1344  (atm(n)%gridstruct%agrid(i,j,2)<0. .and. wk(i,j,npz)<-vort_c0)
1345  enddo
1346  enddo
1347  endif
1348 
1349  if( idiag%id_vort200>0 ) then
1350  call interpolate_vertical(isc, iec, jsc, jec, npz, &
1351  200.e2, atm(n)%peln, wk, a2)
1352  used=send_data(idiag%id_vort200, a2, time)
1353  endif
1354  if( idiag%id_vort500>0 ) then
1355  call interpolate_vertical(isc, iec, jsc, jec, npz, &
1356  500.e2, atm(n)%peln, wk, a2)
1357  used=send_data(idiag%id_vort500, a2, time)
1358  endif
1359 
1360  if(idiag%id_vort850>0 .or. idiag%id_c15>0 .or. idiag%id_x850>0) then
1361  call interpolate_vertical(isc, iec, jsc, jec, npz, &
1362  850.e2, atm(n)%peln, wk, a2)
1363  used=send_data(idiag%id_vort850, a2, time)
1364  if ( idiag%id_x850>0 ) x850(:,:) = a2(:,:)
1365 
1366  if(idiag%id_c15>0) then
1367  do j=jsc,jec
1368  do i=isc,iec
1369  if ( storm(i,j) ) &
1370  storm(i,j) = (atm(n)%gridstruct%agrid(i,j,2)>0. .and. a2(i,j)> vort_c0) .or. &
1371  (atm(n)%gridstruct%agrid(i,j,2)<0. .and. a2(i,j)<-vort_c0)
1372  enddo
1373  enddo
1374  endif
1375 
1376  endif
1377 
1378  if( .not. atm(n)%flagstruct%hydrostatic ) then
1379 
1380  if ( idiag%id_uh03 > 0 ) then
1381  call updraft_helicity(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, &
1382  atm(n)%w, wk, atm(n)%delz, atm(n)%q, &
1383  atm(n)%flagstruct%hydrostatic, atm(n)%pt, atm(n)%peln, atm(n)%phis, grav, 0., 3.e3)
1384  used = send_data( idiag%id_uh03, a2, time )
1385  if(prt_minmax) then
1386  do j=jsc,jec
1387  do i=isc,iec
1388  tmp = rad2deg * atm(n)%gridstruct%agrid(i,j,1)
1389  tmp2 = rad2deg * atm(n)%gridstruct%agrid(i,j,2)
1390  if ( tmp2<25. .or. tmp2>50. &
1391  .or. tmp<235. .or. tmp>300. ) then
1392  a2(i,j) = 0.
1393  endif
1394  enddo
1395  enddo
1396  call prt_maxmin('UH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
1397  endif
1398  endif
1399  if ( idiag%id_uh25 > 0 ) then
1400  call updraft_helicity(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, &
1401  atm(n)%w, wk, atm(n)%delz, atm(n)%q, &
1402  atm(n)%flagstruct%hydrostatic, atm(n)%pt, atm(n)%peln, atm(n)%phis, grav, 2.e3, 5.e3)
1403  used = send_data( idiag%id_uh25, a2, time )
1404  endif
1405  endif
1406 
1407 
1408  if ( idiag%id_srh1 > 0 .or. idiag%id_srh3 > 0 .or. idiag%id_srh25 > 0 .or. idiag%id_ustm > 0 .or. idiag%id_vstm > 0) then
1409  allocate(ustm(isc:iec,jsc:jec), vstm(isc:iec,jsc:jec))
1410 
1411  call bunkers_vector(isc, iec, jsc, jec, ngc, npz, zvir, sphum, ustm, vstm, &
1412  atm(n)%ua, atm(n)%va, atm(n)%delz, atm(n)%q, &
1413  atm(n)%flagstruct%hydrostatic, atm(n)%pt, atm(n)%peln, atm(n)%phis, grav)
1414 
1415  if ( idiag%id_ustm > 0 ) then
1416  used = send_data( idiag%id_ustm, ustm, time )
1417  endif
1418  if ( idiag%id_vstm > 0 ) then
1419  used = send_data( idiag%id_vstm, vstm, time )
1420  endif
1421 
1422  if ( idiag%id_srh1 > 0 ) then
1423  call helicity_relative_caps(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, ustm, vstm, &
1424  atm(n)%ua, atm(n)%va, atm(n)%delz, atm(n)%q, &
1425  atm(n)%flagstruct%hydrostatic, atm(n)%pt, atm(n)%peln, atm(n)%phis, grav, 0., 1.e3)
1426  used = send_data( idiag%id_srh1, a2, time )
1427  if(prt_minmax) then
1428  do j=jsc,jec
1429  do i=isc,iec
1430  tmp = rad2deg * atm(n)%gridstruct%agrid(i,j,1)
1431  tmp2 = rad2deg * atm(n)%gridstruct%agrid(i,j,2)
1432  if ( tmp2<25. .or. tmp2>50. &
1433  .or. tmp<235. .or. tmp>300. ) then
1434  a2(i,j) = 0.
1435  endif
1436  enddo
1437  enddo
1438  call prt_maxmin('SRH (0-1 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
1439  endif
1440  endif
1441 
1442  if ( idiag%id_srh3 > 0 ) then
1443  call helicity_relative_caps(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, ustm, vstm, &
1444  atm(n)%ua, atm(n)%va, atm(n)%delz, atm(n)%q, &
1445  atm(n)%flagstruct%hydrostatic, atm(n)%pt, atm(n)%peln, atm(n)%phis, grav, 0., 3e3)
1446  used = send_data( idiag%id_srh3, a2, time )
1447  if(prt_minmax) then
1448  do j=jsc,jec
1449  do i=isc,iec
1450  tmp = rad2deg * atm(n)%gridstruct%agrid(i,j,1)
1451  tmp2 = rad2deg * atm(n)%gridstruct%agrid(i,j,2)
1452  if ( tmp2<25. .or. tmp2>50. &
1453  .or. tmp<235. .or. tmp>300. ) then
1454  a2(i,j) = 0.
1455  endif
1456  enddo
1457  enddo
1458  call prt_maxmin('SRH (0-3 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
1459  endif
1460  endif
1461 
1462  if ( idiag%id_srh25 > 0 ) then
1463  call helicity_relative_caps(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, ustm, vstm, &
1464  atm(n)%ua, atm(n)%va, atm(n)%delz, atm(n)%q, &
1465  atm(n)%flagstruct%hydrostatic, atm(n)%pt, atm(n)%peln, atm(n)%phis, grav, 2.e3, 5e3)
1466  used = send_data( idiag%id_srh25, a2, time )
1467  if(prt_minmax) then
1468  do j=jsc,jec
1469  do i=isc,iec
1470  tmp = rad2deg * atm(n)%gridstruct%agrid(i,j,1)
1471  tmp2 = rad2deg * atm(n)%gridstruct%agrid(i,j,2)
1472  if ( tmp2<25. .or. tmp2>50. &
1473  .or. tmp<235. .or. tmp>300. ) then
1474  a2(i,j) = 0.
1475  endif
1476  enddo
1477  enddo
1478  call prt_maxmin('SRH (2-5 km) over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
1479  endif
1480  endif
1481 
1482  deallocate(ustm, vstm)
1483  endif
1484 
1485 
1486  if ( idiag%id_pv > 0 ) then
1487 ! Note: this is expensive computation.
1488  call pv_entropy(isc, iec, jsc, jec, ngc, npz, wk, &
1489  atm(n)%gridstruct%f0, atm(n)%pt, atm(n)%pkz, atm(n)%delp, grav)
1490  used = send_data( idiag%id_pv, wk, time )
1491  if (prt_minmax) call prt_maxmin('PV', wk, isc, iec, jsc, jec, 0, 1, 1.)
1492  endif
1493 
1494  endif
1495 
1496 
1497 
1498 !!$ if ( idiag%id_srh > 0 ) then
1499 !!$ call helicity_relative(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, &
1500 !!$ Atm(n)%ua, Atm(n)%va, Atm(n)%delz, Atm(n)%q, &
1501 !!$ Atm(n)%flagstruct%hydrostatic, Atm(n)%pt, Atm(n)%peln, Atm(n)%phis, grav, 0., 3.e3)
1502 !!$ used = send_data ( idiag%id_srh, a2, Time )
1503 !!$ if(prt_minmax) then
1504 !!$ do j=jsc,jec
1505 !!$ do i=isc,iec
1506 !!$ tmp = rad2deg * Atm(n)%gridstruct%agrid(i,j,1)
1507 !!$ tmp2 = rad2deg * Atm(n)%gridstruct%agrid(i,j,2)
1508 !!$ if ( tmp2<25. .or. tmp2>50. &
1509 !!$ .or. tmp<235. .or. tmp>300. ) then
1510 !!$ a2(i,j) = 0.
1511 !!$ endif
1512 !!$ enddo
1513 !!$ enddo
1514 !!$ call prt_maxmin('SRH over CONUS', a2, isc, iec, jsc, jec, 0, 1, 1.)
1515 !!$ endif
1516 !!$ endif
1517 
1518 !!$ if ( idiag%id_srh25 > 0 ) then
1519 !!$ call helicity_relative(isc, iec, jsc, jec, ngc, npz, zvir, sphum, a2, &
1520 !!$ Atm(n)%ua, Atm(n)%va, Atm(n)%delz, Atm(n)%q, &
1521 !!$ Atm(n)%flagstruct%hydrostatic, Atm(n)%pt, Atm(n)%peln, Atm(n)%phis, grav, 2.e3, 5.e3)
1522 !!$ used = send_data ( idiag%id_srh25, a2, Time )
1523 !!$ endif
1524 
1525 
1526  ! Relative Humidity
1527  if ( idiag%id_rh > 0 ) then
1528  ! Compute FV mean pressure
1529  do k=1,npz
1530  do j=jsc,jec
1531  do i=isc,iec
1532  a2(i,j) = atm(n)%delp(i,j,k)/(atm(n)%peln(i,k+1,j)-atm(n)%peln(i,k,j))
1533  enddo
1534  enddo
1535 #ifdef MULTI_GASES
1536  call qsmith((iec-isc+1)*(jec-jsc+1), npz, &
1537  (iec-isc+1)*(jec-jsc+1), 1, atm(n)%pt(isc:iec,jsc:jec,k), &
1538  a2, atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc,jsc,k))
1539 #else
1540  call qsmith(iec-isc+1, jec-jsc+1, 1, atm(n)%pt(isc:iec,jsc:jec,k), &
1541  a2, atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc,jsc,k))
1542 #endif
1543  do j=jsc,jec
1544  do i=isc,iec
1545  wk(i,j,k) = 100.*atm(n)%q(i,j,k,sphum)/wk(i,j,k)
1546  enddo
1547  enddo
1548  enddo
1549  used = send_data( idiag%id_rh, wk, time )
1550  if(prt_minmax) then
1551  call prt_maxmin('RH_sf (%)', wk(isc:iec,jsc:jec,npz), isc, iec, jsc, jec, 0, 1, 1.)
1552  call prt_maxmin('RH_3D (%)', wk, isc, iec, jsc, jec, 0, npz, 1.)
1553  endif
1554  endif
1555 
1556  ! rel hum from physics at selected press levels (for IPCC)
1557  if (idiag%id_rh50>0 .or. idiag%id_rh100>0 .or. idiag%id_rh200>0 .or. idiag%id_rh250>0 .or. &
1558  idiag%id_rh300>0 .or. idiag%id_rh500>0 .or. idiag%id_rh700>0 .or. idiag%id_rh850>0 .or. &
1559  idiag%id_rh925>0 .or. idiag%id_rh1000>0 .or. &
1560  idiag%id_dp50>0 .or. idiag%id_dp100>0 .or. idiag%id_dp200>0 .or. idiag%id_dp250>0 .or. &
1561  idiag%id_dp300>0 .or. idiag%id_dp500>0 .or. idiag%id_dp700>0 .or. idiag%id_dp850>0 .or. &
1562  idiag%id_dp925>0 .or. idiag%id_dp1000>0) then
1563  ! compute mean pressure
1564  do k=1,npz
1565  do j=jsc,jec
1566  do i=isc,iec
1567  a2(i,j) = atm(n)%delp(i,j,k)/(atm(n)%peln(i,k+1,j)-atm(n)%peln(i,k,j))
1568  enddo
1569  enddo
1570  call rh_calc (a2, atm(n)%pt(isc:iec,jsc:jec,k), &
1571  atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k))
1572  enddo
1573  if (idiag%id_rh50>0) then
1574  call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1575  used=send_data(idiag%id_rh50, a2, time)
1576  endif
1577  if (idiag%id_rh100>0) then
1578  call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1579  used=send_data(idiag%id_rh100, a2, time)
1580  endif
1581  if (idiag%id_rh200>0) then
1582  call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1583  used=send_data(idiag%id_rh200, a2, time)
1584  endif
1585  if (idiag%id_rh250>0) then
1586  call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1587  used=send_data(idiag%id_rh250, a2, time)
1588  endif
1589  if (idiag%id_rh300>0) then
1590  call interpolate_vertical(isc, iec, jsc, jec, npz, 300.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1591  used=send_data(idiag%id_rh300, a2, time)
1592  endif
1593  if (idiag%id_rh500>0) then
1594  call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1595  used=send_data(idiag%id_rh500, a2, time)
1596  endif
1597  if (idiag%id_rh700>0) then
1598  call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1599  used=send_data(idiag%id_rh700, a2, time)
1600  endif
1601  if (idiag%id_rh850>0) then
1602  call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1603  used=send_data(idiag%id_rh850, a2, time)
1604  endif
1605  if (idiag%id_rh925>0) then
1606  call interpolate_vertical(isc, iec, jsc, jec, npz, 925.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1607  used=send_data(idiag%id_rh925, a2, time)
1608  endif
1609  if (idiag%id_rh1000>0) then
1610  call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1611  used=send_data(idiag%id_rh1000, a2, time)
1612  endif
1613 
1614  if (idiag%id_dp50>0 .or. idiag%id_dp100>0 .or. idiag%id_dp200>0 .or. idiag%id_dp250>0 .or. &
1615  idiag%id_dp300>0 .or. idiag%id_dp500>0 .or. idiag%id_dp700>0 .or. idiag%id_dp850>0 .or. &
1616  idiag%id_dp925>0 .or. idiag%id_dp1000>0 ) then
1617 
1618  if (allocated(a3)) deallocate(a3)
1619  allocate(a3(isc:iec,jsc:jec,1:npz))
1620  !compute dew point (K)
1621  !using formula at https://cals.arizona.edu/azmet/dewpoint.html
1622  do k=1,npz
1623  do j=jsc,jec
1624  do i=isc,iec
1625  tmp = ( log(max(wk(i,j,k)*1.e-2,1.e-2)) + 17.27 * ( atm(n)%pt(i,j,k) - 273.14 )/ ( -35.84 + atm(n)%pt(i,j,k)) ) / 17.27
1626  a3(i,j,k) = 273.14 + 237.3*tmp/ ( 1. - tmp )
1627  enddo
1628  enddo
1629  enddo
1630 
1631  if (idiag%id_dp50>0) then
1632  call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, atm(n)%peln, a3, a2)
1633  used=send_data(idiag%id_dp50, a2, time)
1634  endif
1635  if (idiag%id_dp100>0) then
1636  call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, atm(n)%peln, a3, a2)
1637  used=send_data(idiag%id_dp100, a2, time)
1638  endif
1639  if (idiag%id_dp200>0) then
1640  call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, atm(n)%peln, a3, a2)
1641  used=send_data(idiag%id_dp200, a2, time)
1642  endif
1643  if (idiag%id_dp250>0) then
1644  call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, atm(n)%peln, a3, a2)
1645  used=send_data(idiag%id_dp250, a2, time)
1646  endif
1647  if (idiag%id_dp300>0) then
1648  call interpolate_vertical(isc, iec, jsc, jec, npz, 300.e2, atm(n)%peln, a3, a2)
1649  used=send_data(idiag%id_dp300, a2, time)
1650  endif
1651  if (idiag%id_dp500>0) then
1652  call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, atm(n)%peln, a3, a2)
1653  used=send_data(idiag%id_dp500, a2, time)
1654  endif
1655  if (idiag%id_dp700>0) then
1656  call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, atm(n)%peln, a3, a2)
1657  used=send_data(idiag%id_dp700, a2, time)
1658  endif
1659  if (idiag%id_dp850>0) then
1660  call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, atm(n)%peln, a3, a2)
1661  used=send_data(idiag%id_dp850, a2, time)
1662  endif
1663  if (idiag%id_dp925>0) then
1664  call interpolate_vertical(isc, iec, jsc, jec, npz, 925.e2, atm(n)%peln, a3, a2)
1665  used=send_data(idiag%id_dp925, a2, time)
1666  endif
1667  if (idiag%id_dp1000>0) then
1668  call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, atm(n)%peln, a3, a2)
1669  used=send_data(idiag%id_dp1000, a2, time)
1670  endif
1671  deallocate(a3)
1672 
1673  endif
1674 
1675  endif
1676 
1677  ! rel hum (CMIP definition) at selected press levels (for IPCC)
1678  if (idiag%id_rh10_cmip>0 .or. idiag%id_rh50_cmip>0 .or. idiag%id_rh100_cmip>0 .or. &
1679  idiag%id_rh250_cmip>0 .or. idiag%id_rh300_cmip>0 .or. idiag%id_rh500_cmip>0 .or. &
1680  idiag%id_rh700_cmip>0 .or. idiag%id_rh850_cmip>0 .or. idiag%id_rh925_cmip>0 .or. &
1681  idiag%id_rh1000_cmip>0) then
1682  ! compute mean pressure
1683  do k=1,npz
1684  do j=jsc,jec
1685  do i=isc,iec
1686  a2(i,j) = atm(n)%delp(i,j,k)/(atm(n)%peln(i,k+1,j)-atm(n)%peln(i,k,j))
1687  enddo
1688  enddo
1689  call rh_calc (a2, atm(n)%pt(isc:iec,jsc:jec,k), &
1690  atm(n)%q(isc:iec,jsc:jec,k,sphum), wk(isc:iec,jsc:jec,k), do_cmip=.true.)
1691  enddo
1692  if (idiag%id_rh10_cmip>0) then
1693  call interpolate_vertical(isc, iec, jsc, jec, npz, 10.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1694  used=send_data(idiag%id_rh10_cmip, a2, time)
1695  endif
1696  if (idiag%id_rh50_cmip>0) then
1697  call interpolate_vertical(isc, iec, jsc, jec, npz, 50.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1698  used=send_data(idiag%id_rh50_cmip, a2, time)
1699  endif
1700  if (idiag%id_rh100_cmip>0) then
1701  call interpolate_vertical(isc, iec, jsc, jec, npz, 100.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1702  used=send_data(idiag%id_rh100_cmip, a2, time)
1703  endif
1704  if (idiag%id_rh250_cmip>0) then
1705  call interpolate_vertical(isc, iec, jsc, jec, npz, 250.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1706  used=send_data(idiag%id_rh250_cmip, a2, time)
1707  endif
1708  if (idiag%id_rh300_cmip>0) then
1709  call interpolate_vertical(isc, iec, jsc, jec, npz, 300.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1710  used=send_data(idiag%id_rh300_cmip, a2, time)
1711  endif
1712  if (idiag%id_rh500_cmip>0) then
1713  call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1714  used=send_data(idiag%id_rh500_cmip, a2, time)
1715  endif
1716  if (idiag%id_rh700_cmip>0) then
1717  call interpolate_vertical(isc, iec, jsc, jec, npz, 700.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1718  used=send_data(idiag%id_rh700_cmip, a2, time)
1719  endif
1720  if (idiag%id_rh850_cmip>0) then
1721  call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1722  used=send_data(idiag%id_rh850_cmip, a2, time)
1723  endif
1724  if (idiag%id_rh925_cmip>0) then
1725  call interpolate_vertical(isc, iec, jsc, jec, npz, 925.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1726  used=send_data(idiag%id_rh925_cmip, a2, time)
1727  endif
1728  if (idiag%id_rh1000_cmip>0) then
1729  call interpolate_vertical(isc, iec, jsc, jec, npz, 1000.e2, atm(n)%peln, wk(isc:iec,jsc:jec,:), a2)
1730  used=send_data(idiag%id_rh1000_cmip, a2, time)
1731  endif
1732  endif
1733 
1734  if(idiag%id_c25>0 .or. idiag%id_c35>0 .or. idiag%id_c45>0) then
1735  do j=jsc,jec
1736  do i=isc,iec
1737  if ( storm(i,j) .and. ws_max(i,j)>ws_1 ) then
1738  cat_crt(i,j) = .true.
1739  else
1740  cat_crt(i,j) = .false.
1741  endif
1742  enddo
1743  enddo
1744  endif
1745 
1746 
1747 
1748  if( idiag%id_slp>0 .or. idiag%id_tm>0 .or. idiag%id_hght>0 .or. idiag%id_c15>0 .or. idiag%id_ctz>0 ) then
1749 
1750  allocate ( wz(isc:iec,jsc:jec,npz+1) )
1751  call get_height_field(isc, iec, jsc, jec, ngc, npz, atm(n)%flagstruct%hydrostatic, atm(n)%delz, &
1752  wz, atm(n)%pt, atm(n)%q, atm(n)%peln, zvir)
1753  if( prt_minmax ) &
1754  call prt_mxm('ZTOP',wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.e-3, atm(n)%gridstruct%area_64, atm(n)%domain)
1755 ! call prt_maxmin('ZTOP', wz(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, 1, 1.E-3)
1756 
1757  if(idiag%id_slp > 0) then
1758 ! Cumpute SLP (pressure at height=0)
1759  allocate ( slp(isc:iec,jsc:jec) )
1760  call get_pressure_given_height(isc, iec, jsc, jec, ngc, npz, wz, 1, height(2), &
1761  atm(n)%pt(:,:,npz), atm(n)%peln, slp, 0.01)
1762  used = send_data(idiag%id_slp, slp, time)
1763  if( prt_minmax ) then
1764  call prt_maxmin('SLP', slp, isc, iec, jsc, jec, 0, 1, 1.)
1765 ! US Potential Landfall TCs (PLT):
1766  do j=jsc,jec
1767  do i=isc,iec
1768  a2(i,j) = 1015.
1769  slon = rad2deg*atm(n)%gridstruct%agrid(i,j,1)
1770  slat = rad2deg*atm(n)%gridstruct%agrid(i,j,2)
1771  if ( slat>15. .and. slat<40. .and. slon>270. .and. slon<290. ) then
1772  a2(i,j) = slp(i,j)
1773  endif
1774  enddo
1775  enddo
1776  call prt_maxmin('ATL SLP', a2, isc, iec, jsc, jec, 0, 1, 1.)
1777  endif
1778  endif
1779 
1780 ! Compute H3000 and/or H500
1781  if( idiag%id_tm>0 .or. idiag%id_hght>0 .or. idiag%id_ppt>0) then
1782 
1783  allocate( a3(isc:iec,jsc:jec,nplev) )
1784 
1785  idg(:) = idiag%id_h(:)
1786 
1787  if ( idiag%id_tm>0 ) then
1788  idg(minloc(abs(levs-300))) = 1 ! 300-mb
1789  idg(minloc(abs(levs-500))) = 1 ! 500-mb
1790  else
1791  idg(minloc(abs(levs-300))) = idiag%id_h(minloc(abs(levs-300)))
1792  idg(minloc(abs(levs-500))) = idiag%id_h(minloc(abs(levs-500)))
1793  endif
1794 
1795  call get_height_given_pressure(isc, iec, jsc, jec, npz, wz, nplev, idg, plevs, atm(n)%peln, a3)
1796  ! reset
1797  idg(minloc(abs(levs-300))) = idiag%id_h(minloc(abs(levs-300)))
1798  idg(minloc(abs(levs-500))) = idiag%id_h(minloc(abs(levs-500)))
1799 
1800  do i=1,nplev
1801  if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), time)
1802  enddo
1803 
1804  if (idiag%id_h_plev>0) then
1805  id1(:) = 1
1806  call get_height_given_pressure(isc, iec, jsc, jec, npz, wz, nplev, id1, plevs, atm(n)%peln, a3)
1807  used=send_data(idiag%id_h_plev, a3(isc:iec,jsc:jec,:), time)
1808  endif
1809 
1810  if( prt_minmax ) then
1811 
1812  if(all(idiag%id_h(minloc(abs(levs-100)))>0)) &
1813  call prt_mxm('Z100',a3(isc:iec,jsc:jec,11),isc,iec,jsc,jec,0,1,1.e-3,atm(n)%gridstruct%area_64,atm(n)%domain)
1814 
1815  if(all(idiag%id_h(minloc(abs(levs-500)))>0)) then
1816  if (.not. atm(n)%neststruct%nested) then
1817 #ifdef TO_BE_DELETED
1818  t_eq = 0. ; t_nh = 0.; t_sh = 0.; t_gb = 0.
1819  area_eq = 0.; area_nh = 0.; area_sh = 0.; area_gb = 0.
1820  do j=jsc,jec
1821  do i=isc,iec
1822  slat = atm(n)%gridstruct%agrid(i,j,2)*rad2deg
1823  area_gb = area_gb + atm(n)%gridstruct%area(i,j)
1824  t_gb = t_gb + a3(i,j,19)*atm(n)%gridstruct%area(i,j)
1825  if( (slat>-20. .and. slat<20.) ) then
1826 ! Tropics:
1827  area_eq = area_eq + atm(n)%gridstruct%area(i,j)
1828  t_eq = t_eq + a3(i,j,19)*atm(n)%gridstruct%area(i,j)
1829  elseif( slat>=20. .and. slat<80. ) then
1830 ! NH
1831  area_nh = area_nh + atm(n)%gridstruct%area(i,j)
1832  t_nh = t_nh + a3(i,j,19)*atm(n)%gridstruct%area(i,j)
1833  elseif( slat<=-20. .and. slat>-80. ) then
1834 ! SH
1835  area_sh = area_sh + atm(n)%gridstruct%area(i,j)
1836  t_sh = t_sh + a3(i,j,19)*atm(n)%gridstruct%area(i,j)
1837  endif
1838  enddo
1839  enddo
1840  call mp_reduce_sum(area_gb)
1841  call mp_reduce_sum( t_gb)
1842  call mp_reduce_sum(area_nh)
1843  call mp_reduce_sum( t_nh)
1844  call mp_reduce_sum(area_sh)
1845  call mp_reduce_sum( t_sh)
1846  call mp_reduce_sum(area_eq)
1847  call mp_reduce_sum( t_eq)
1848  if (master) write(*,*) 'Z500 GB_NH_SH_EQ=', t_gb/area_gb, t_nh/area_nh, t_sh/area_sh, t_eq/area_eq
1849 #endif
1850 ! call prt_mxm('Z500',a3(isc:iec,jsc:jec,19),isc,iec,jsc,jec,0,1,1.,Atm(n)%gridstruct%area_64,Atm(n)%domain)
1851  call prt_gb_nh_sh('fv_GFS Z500', isc,iec, jsc,jec, a3(isc,jsc,19), atm(n)%gridstruct%area_64(isc:iec,jsc:jec), &
1852  atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2))
1853  endif
1854  endif
1855 
1856  endif
1857 
1858  ! mean virtual temp 300mb to 500mb
1859  if( idiag%id_tm>0 ) then
1860  do j=jsc,jec
1861  do i=isc,iec
1862  a2(i,j) = grav*(a3(i,j,15)-a3(i,j,19))/(rdgas*(plevs(19)-plevs(15)))
1863  enddo
1864  enddo
1865  used = send_data( idiag%id_tm, a2, time )
1866  endif
1867 
1868  if(idiag%id_c15>0 .or. idiag%id_c25>0 .or. idiag%id_c35>0 .or. idiag%id_c45>0) then
1869  do j=jsc,jec
1870  do i=isc,iec
1871 ! Minimum warm core:
1872  if ( storm(i,j) ) then
1873  if( a2(i,j)<254.0 .or. atm(n)%pt(i,j,npz)<281.0 ) Then
1874  storm(i,j) = .false.
1875  cat_crt(i,j) = .false.
1876  endif
1877  endif
1878  enddo
1879  enddo
1880 ! Cat 1-5:
1881  do j=jsc,jec
1882  do i=isc,iec
1883  if ( storm(i,j) .and. slp(i,j)<1000.0 ) then
1884  depress(i,j) = 1000. - slp(i,j)
1885  tc_count(i,j) = 1.
1886  else
1887  depress(i,j) = 0.
1888  tc_count(i,j) = 0.
1889  endif
1890  enddo
1891  enddo
1892  used = send_data(idiag%id_c15, depress, time)
1893  if(idiag%id_f15>0) used = send_data(idiag%id_f15, tc_count, time)
1894  if(prt_minmax) then
1895  do j=jsc,jec
1896  do i=isc,iec
1897  slon = rad2deg*atm(n)%gridstruct%agrid(i,j,1)
1898  slat = rad2deg*atm(n)%gridstruct%agrid(i,j,2)
1899 ! Western Pac: negative; positive elsewhere
1900  if ( slat>0. .and. slat<40. .and. slon>110. .and. slon<180. ) then
1901  depress(i,j) = -depress(i,j)
1902  endif
1903  enddo
1904  enddo
1905  call prt_maxmin('Depress', depress, isc, iec, jsc, jec, 0, 1, 1.)
1906  do j=jsc,jec
1907  do i=isc,iec
1908  if ( atm(n)%gridstruct%agrid(i,j,2)<0.) then
1909 ! Excluding the SH cyclones
1910  depress(i,j) = 0.
1911  endif
1912  enddo
1913  enddo
1914  call prt_maxmin('NH Deps', depress, isc, iec, jsc, jec, 0, 1, 1.)
1915 
1916 ! ATL basin cyclones
1917  do j=jsc,jec
1918  do i=isc,iec
1919  tmp = rad2deg * atm(n)%gridstruct%agrid(i,j,1)
1920  if ( tmp<280. ) then
1921  depress(i,j) = 0.
1922  endif
1923  enddo
1924  enddo
1925  call prt_maxmin('ATL Deps', depress, isc, iec, jsc, jec, 0, 1, 1.)
1926  endif
1927  endif
1928 
1929 ! Cat 2-5:
1930  if(idiag%id_c25>0) then
1931  do j=jsc,jec
1932  do i=isc,iec
1933  if ( cat_crt(i,j) .and. slp(i,j)<980.0 ) then
1934  depress(i,j) = 980. - slp(i,j)
1935  tc_count(i,j) = 1.
1936  else
1937  depress(i,j) = 0.
1938  tc_count(i,j) = 0.
1939  endif
1940  enddo
1941  enddo
1942  used = send_data(idiag%id_c25, depress, time)
1943  if(idiag%id_f25>0) used = send_data(idiag%id_f25, tc_count, time)
1944  endif
1945 
1946 ! Cat 3-5:
1947  if(idiag%id_c35>0) then
1948  do j=jsc,jec
1949  do i=isc,iec
1950  if ( cat_crt(i,j) .and. slp(i,j)<964.0 ) then
1951  depress(i,j) = 964. - slp(i,j)
1952  tc_count(i,j) = 1.
1953  else
1954  depress(i,j) = 0.
1955  tc_count(i,j) = 0.
1956  endif
1957  enddo
1958  enddo
1959  used = send_data(idiag%id_c35, depress, time)
1960  if(idiag%id_f35>0) used = send_data(idiag%id_f35, tc_count, time)
1961  endif
1962 
1963 ! Cat 4-5:
1964  if(idiag%id_c45>0) then
1965  do j=jsc,jec
1966  do i=isc,iec
1967  if ( cat_crt(i,j) .and. slp(i,j)<944.0 ) then
1968  depress(i,j) = 944. - slp(i,j)
1969  tc_count(i,j) = 1.
1970  else
1971  depress(i,j) = 0.
1972  tc_count(i,j) = 0.
1973  endif
1974  enddo
1975  enddo
1976  used = send_data(idiag%id_c45, depress, time)
1977  if(idiag%id_f45>0) used = send_data(idiag%id_f45, tc_count, time)
1978  endif
1979 
1980  if (idiag%id_c15>0) then
1981  deallocate(depress)
1982  deallocate(cat_crt)
1983  deallocate(storm)
1984  deallocate(ws_max)
1985  deallocate(tc_count)
1986  endif
1987 
1988  if(idiag%id_slp>0 ) deallocate( slp )
1989 
1990 ! deallocate( a3 )
1991  endif
1992 
1993 ! deallocate ( wz )
1994  endif
1995 
1996 ! Temperature:
1997  idg(:) = idiag%id_t(:)
1998 
1999  do_cs_intp = .false.
2000  do i=1,nplev
2001  if ( idg(i)>0 ) then
2002  do_cs_intp = .true.
2003  exit
2004  endif
2005  enddo
2006 
2007  if ( do_cs_intp ) then ! log(pe) as the coordinaite for temp re-construction
2008  if(.not. allocated (a3) ) allocate( a3(isc:iec,jsc:jec,nplev) )
2009  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%pt(isc:iec,jsc:jec,:), nplev, &
2010  plevs, wz, atm(n)%peln, idg, a3, 1)
2011  do i=1,nplev
2012  if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), time)
2013  enddo
2014  if ( all(idiag%id_t(minloc(abs(levs-100)))>0) .and. prt_minmax ) then
2015  call prt_mxm('T100:', a3(isc:iec,jsc:jec,11), isc, iec, jsc, jec, 0, 1, 1., &
2016  atm(n)%gridstruct%area_64, atm(n)%domain)
2017  if (.not. atm(n)%neststruct%nested) then
2018  tmp = 0.
2019  sar = 0.
2020  ! Compute mean temp at 100 mb near EQ
2021  do j=jsc,jec
2022  do i=isc,iec
2023  slat = atm(n)%gridstruct%agrid(i,j,2)*rad2deg
2024  if( (slat>-10.0 .and. slat<10.) ) then
2025  sar = sar + atm(n)%gridstruct%area(i,j)
2026  tmp = tmp + a3(i,j,11)*atm(n)%gridstruct%area(i,j)
2027  endif
2028  enddo
2029  enddo
2030  call mp_reduce_sum(sar)
2031  call mp_reduce_sum(tmp)
2032  if ( sar > 0. ) then
2033  if (master) write(*,*) 'Tropical [10s,10n] mean T100 =', tmp/sar
2034  else
2035  if (master) write(*,*) 'Warning: problem computing tropical mean T100'
2036  endif
2037  endif
2038  endif
2039  if ( all(idiag%id_t(minloc(abs(levs-200)))>0) .and. prt_minmax ) then
2040  call prt_mxm('T200:', a3(isc:iec,jsc:jec,13), isc, iec, jsc, jec, 0, 1, 1., &
2041  atm(n)%gridstruct%area_64, atm(n)%domain)
2042  if (.not. atm(n)%neststruct%nested) then
2043  tmp = 0.
2044  sar = 0.
2045  do j=jsc,jec
2046  do i=isc,iec
2047  slat = atm(n)%gridstruct%agrid(i,j,2)*rad2deg
2048  if( (slat>-20 .and. slat<20) ) then
2049  sar = sar + atm(n)%gridstruct%area(i,j)
2050  tmp = tmp + a3(i,j,13)*atm(n)%gridstruct%area(i,j)
2051  endif
2052  enddo
2053  enddo
2054  call mp_reduce_sum(sar)
2055  call mp_reduce_sum(tmp)
2056  if ( sar > 0. ) then
2057  if (master) write(*,*) 'Tropical [-20.,20.] mean T200 =', tmp/sar
2058  endif
2059  endif
2060  endif
2061  deallocate( a3 )
2062  endif
2063 
2064  if (idiag%id_t_plev>0) then
2065  if(.not. allocated (a3) ) allocate( a3(isc:iec,jsc:jec,nplev) )
2066  id1(:) = 1
2067  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%pt(isc:iec,jsc:jec,:), nplev, &
2068  plevs, wz, atm(n)%peln, id1, a3, 1)
2069  used=send_data(idiag%id_t_plev, a3(isc:iec,jsc:jec,:), time)
2070  deallocate( a3 )
2071  endif
2072 
2073  if(idiag%id_mq > 0) then
2074  do j=jsc,jec
2075  do i=isc,iec
2076 ! zxg * surface pressure * 1.e-18--> Hadleys per unit area
2077 ! Unit Hadley = 1.E18 kg m**2 / s**2
2078  a2(i,j) = -1.e-18 * atm(n)%ps(i,j)*idiag%zxg(i,j)
2079  enddo
2080  enddo
2081  used = send_data(idiag%id_mq, a2, time)
2082  if( prt_minmax ) then
2083  tot_mq = g_sum( atm(n)%domain, a2, isc, iec, jsc, jec, ngc, atm(n)%gridstruct%area_64, 0)
2084  idiag%mtq_sum = idiag%mtq_sum + tot_mq
2085  if ( idiag%steps <= max_step ) idiag%mtq(idiag%steps) = tot_mq
2086  if(master) write(*,*) 'Total (global) mountain torque (Hadleys)=', tot_mq
2087  endif
2088  endif
2089 
2090  if (idiag%id_ts > 0) used = send_data(idiag%id_ts, atm(n)%ts(isc:iec,jsc:jec), time)
2091 
2092  if ( idiag%id_tq>0 ) then
2093  nwater = atm(1)%flagstruct%nwat
2094  a2 = 0.
2095  do k=1,npz
2096  do j=jsc,jec
2097  do i=isc,iec
2098 ! a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,1)*Atm(n)%delp(i,j,k)
2099  a2(i,j) = a2(i,j) + sum(atm(n)%q(i,j,k,1:nwater))*atm(n)%delp(i,j,k)
2100  enddo
2101  enddo
2102  enddo
2103  used = send_data(idiag%id_tq, a2*ginv, time)
2104  endif
2105 #ifdef HIWPP
2106  cl = get_tracer_index(model_atmos, 'Cl')
2107  cl2 = get_tracer_index(model_atmos, 'Cl2')
2108  if (cl > 0 .and. cl2 > 0) then
2109  allocate(var2(isc:iec,jsc:jec))
2110  var2 = 0.
2111  do k=1,npz
2112  do j=jsc,jec
2113  do i=isc,iec
2114  var2(i,j) = var2(i,j) + atm(n)%delp(i,j,k)
2115  enddo
2116  enddo
2117  enddo
2118 
2119  if ( idiag%id_acl > 0 ) then
2120  a2 = 0.
2121  einf = 0.
2122  qm = 0.
2123  do k=1,npz
2124  do j=jsc,jec
2125  do i=isc,iec
2126  a2(i,j) = a2(i,j) + atm(n)%q(i,j,k,cl)*atm(n)%delp(i,j,k) ! moist mass
2127  enddo
2128  enddo
2129  enddo
2130  !Convert to mean mixing ratio
2131  do j=jsc,jec
2132  do i=isc,iec
2133  a2(i,j) = a2(i,j) / var2(i,j)
2134  enddo
2135  enddo
2136  used = send_data(idiag%id_acl, a2, time)
2137  endif
2138  if ( idiag%id_acl2 > 0 ) then
2139  a2 = 0.
2140  einf = 0.
2141  qm = 0.
2142  do k=1,npz
2143  do j=jsc,jec
2144  do i=isc,iec
2145  a2(i,j) = a2(i,j) + atm(n)%q(i,j,k,cl2)*atm(n)%delp(i,j,k) ! moist mass
2146  enddo
2147  enddo
2148  enddo
2149  !Convert to mean mixing ratio
2150  do j=jsc,jec
2151  do i=isc,iec
2152  a2(i,j) = a2(i,j) / var2(i,j)
2153  enddo
2154  enddo
2155  used = send_data(idiag%id_acl2, a2, time)
2156  endif
2157  if ( idiag%id_acly > 0 ) then
2158  a2 = 0.
2159  einf = 0.
2160  qm = 0.
2161  e2 = 0.
2162  do k=1,npz
2163  do j=jsc,jec
2164  do i=isc,iec
2165  mm = (atm(n)%q(i,j,k,cl)+2.*atm(n)%q(i,j,k,cl2))*atm(n)%delp(i,j,k) ! moist mass
2166  a2(i,j) = a2(i,j) + mm
2167  qm = qm + mm*atm(n)%gridstruct%area_64(i,j)
2168  enddo
2169  enddo
2170  enddo
2171  !Convert to mean mixing ratio
2172  do j=jsc,jec
2173  do i=isc,iec
2174  a2(i,j) = a2(i,j) / var2(i,j)
2175  enddo
2176  enddo
2177  used = send_data(idiag%id_acly, a2, time)
2178  do j=jsc,jec
2179  do i=isc,iec
2180  e2 = e2 + ((a2(i,j) - qcly0)**2)*atm(n)%gridstruct%area_64(i,j)
2181  einf = max(einf, abs(a2(i,j) - qcly0))
2182  enddo
2183  enddo
2184  if (prt_minmax .and. .not. atm(n)%neststruct%nested) then
2185  call mp_reduce_sum(qm)
2186  call mp_reduce_max(einf)
2187  call mp_reduce_sum(e2)
2188  if (master) then
2189  write(*,*) ' TERMINATOR TEST: '
2190  write(*,*) ' chlorine mass: ', real(qm)/(4.*pi*radius*radius)
2191  write(*,*) ' L2 err: ', sqrt(e2)/sqrt(4.*pi*radius*radius)/qcly0
2192  write(*,*) ' max err: ', einf/qcly0
2193  endif
2194  endif
2195  endif
2196 
2197  deallocate(var2)
2198 
2199  endif
2200 #endif
2201  if ( idiag%id_iw>0 ) then
2202  a2 = 0.
2203  if (ice_wat > 0) then
2204  do k=1,npz
2205  do j=jsc,jec
2206  do i=isc,iec
2207  a2(i,j) = a2(i,j) + atm(n)%delp(i,j,k) * &
2208  atm(n)%q(i,j,k,ice_wat)
2209  enddo
2210  enddo
2211  enddo
2212  endif
2213  if (snowwat > 0) then
2214  do k=1,npz
2215  do j=jsc,jec
2216  do i=isc,iec
2217  a2(i,j) = a2(i,j) + atm(n)%delp(i,j,k) * &
2218  atm(n)%q(i,j,k,snowwat)
2219  enddo
2220  enddo
2221  enddo
2222  endif
2223  if (graupel > 0) then
2224  do k=1,npz
2225  do j=jsc,jec
2226  do i=isc,iec
2227  a2(i,j) = a2(i,j) + atm(n)%delp(i,j,k) * &
2228  atm(n)%q(i,j,k,graupel)
2229  enddo
2230  enddo
2231  enddo
2232  endif
2233  used = send_data(idiag%id_iw, a2*ginv, time)
2234  endif
2235  if ( idiag%id_lw>0 ) then
2236  a2 = 0.
2237  if (liq_wat > 0) then
2238  do k=1,npz
2239  do j=jsc,jec
2240  do i=isc,iec
2241  a2(i,j) = a2(i,j) + atm(n)%q(i,j,k,liq_wat)*atm(n)%delp(i,j,k)
2242  enddo
2243  enddo
2244  enddo
2245  endif
2246  if (rainwat > 0) then
2247  do k=1,npz
2248  do j=jsc,jec
2249  do i=isc,iec
2250  a2(i,j) = a2(i,j) + atm(n)%q(i,j,k,rainwat)*atm(n)%delp(i,j,k)
2251  enddo
2252  enddo
2253  enddo
2254  endif
2255  used = send_data(idiag%id_lw, a2*ginv, time)
2256  endif
2257 
2258 ! Cloud top temperature & cloud top press:
2259  if ( (idiag%id_ctt>0 .or. idiag%id_ctp>0 .or. idiag%id_ctz>0).and. atm(n)%flagstruct%nwat==6) then
2260  allocate ( var1(isc:iec,jsc:jec) )
2261  allocate ( var2(isc:iec,jsc:jec) )
2262 !$OMP parallel do default(shared) private(tmp)
2263  do j=jsc,jec
2264  do i=isc,iec
2265  do k=2,npz
2266  tmp = atm(n)%q(i,j,k,liq_wat)+atm(n)%q(i,j,k,rainwat)+atm(n)%q(i,j,k,ice_wat)+ &
2267  atm(n)%q(i,j,k,snowwat)+atm(n)%q(i,j,k,graupel)
2268  if( tmp>5.e-6 ) then
2269  a2(i,j) = atm(n)%pt(i,j,k)
2270  var1(i,j) = 0.01*atm(n)%pe(i,k,j)
2271  var2(i,j) = wz(i,j,k) - wz(i,j,npz+1) ! height AGL
2272  exit
2273  elseif( k==npz ) then
2274  a2(i,j) = missing_value2
2275  var1(i,j) = missing_value2
2276  var2(i,j) = missing_value2
2277 !!$ a2(i,j) = Atm(n)%pt(i,j,k)
2278 !!$ var1(i,j) = 0.01*Atm(n)%pe(i,k+1,j) ! surface pressure
2279  endif
2280  enddo
2281  enddo
2282  enddo
2283  if ( idiag%id_ctt>0 ) then
2284  used = send_data(idiag%id_ctt, a2, time)
2285  if(prt_minmax) call prt_maxmin('Cloud_top_T (K)', a2, isc, iec, jsc, jec, 0, 1, 1.)
2286  endif
2287  if ( idiag%id_ctp>0 ) then
2288  used = send_data(idiag%id_ctp, var1, time)
2289  if(prt_minmax) call prt_maxmin('Cloud_top_P (mb)', var1, isc, iec, jsc, jec, 0, 1, 1.)
2290  endif
2291  deallocate ( var1 )
2292  if ( idiag%id_ctz>0 ) then
2293  used = send_data(idiag%id_ctz, var2, time)
2294  if(prt_minmax) call prt_maxmin('Cloud_top_z (m)', var2, isc, iec, jsc, jec, 0, 1, 1.)
2295  endif
2296  deallocate ( var2 )
2297  endif
2298 
2299 ! Condensates:
2300  if ( idiag%id_qn>0 .or. idiag%id_qn200>0 .or. idiag%id_qn500>0 .or. idiag%id_qn850>0 ) then
2301 !$OMP parallel do default(shared)
2302  do k=1,npz
2303  do j=jsc,jec
2304  do i=isc,iec
2305  wk(i,j,k) = 0.
2306  enddo
2307  enddo
2308  enddo
2309  if (liq_wat > 0) then
2310 !$OMP parallel do default(shared)
2311  do k=1,npz
2312  do j=jsc,jec
2313  do i=isc,iec
2314  wk(i,j,k) = wk(i,j,k) + atm(n)%q(i,j,k,liq_wat)*atm(n)%delp(i,j,k)
2315  enddo
2316  enddo
2317  enddo
2318  endif
2319  if (ice_wat > 0) then
2320 !$OMP parallel do default(shared)
2321  do k=1,npz
2322  do j=jsc,jec
2323  do i=isc,iec
2324  wk(i,j,k) = wk(i,j,k) + atm(n)%q(i,j,k,ice_wat)*atm(n)%delp(i,j,k)
2325  enddo
2326  enddo
2327  enddo
2328  endif
2329  if ( idiag%id_qn>0 ) used = send_data(idiag%id_qn, wk, time)
2330  if ( idiag%id_qn200>0 ) then
2331  call interpolate_vertical(isc, iec, jsc, jec, npz, 200.e2, atm(n)%peln, wk, a2)
2332  used=send_data(idiag%id_qn200, a2, time)
2333  endif
2334  if ( idiag%id_qn500>0 ) then
2335  call interpolate_vertical(isc, iec, jsc, jec, npz, 500.e2, atm(n)%peln, wk, a2)
2336  used=send_data(idiag%id_qn500, a2, time)
2337  endif
2338  if ( idiag%id_qn850>0 ) then
2339  call interpolate_vertical(isc, iec, jsc, jec, npz, 850.e2, atm(n)%peln, wk, a2)
2340  used=send_data(idiag%id_qn850, a2, time)
2341  endif
2342  endif
2343 ! Total 3D condensates
2344  if ( idiag%id_qp>0 ) then
2345 !$OMP parallel do default(shared)
2346  do k=1,npz
2347  do j=jsc,jec
2348  do i=isc,iec
2349  wk(i,j,k) = 0.
2350  enddo
2351  enddo
2352  enddo
2353  if (rainwat > 0) then
2354 !$OMP parallel do default(shared)
2355  do k=1,npz
2356  do j=jsc,jec
2357  do i=isc,iec
2358  wk(i,j,k) = wk(i,j,k) + atm(n)%q(i,j,k,rainwat)*atm(n)%delp(i,j,k)
2359  enddo
2360  enddo
2361  enddo
2362  endif
2363  if (snowwat > 0) then
2364 !$OMP parallel do default(shared)
2365  do k=1,npz
2366  do j=jsc,jec
2367  do i=isc,iec
2368  wk(i,j,k) = wk(i,j,k) + atm(n)%q(i,j,k,snowwat)*atm(n)%delp(i,j,k)
2369  enddo
2370  enddo
2371  enddo
2372  endif
2373  if (graupel > 0) then
2374 !$OMP parallel do default(shared)
2375  do k=1,npz
2376  do j=jsc,jec
2377  do i=isc,iec
2378  wk(i,j,k) = wk(i,j,k) + atm(n)%q(i,j,k,graupel)*atm(n)%delp(i,j,k)
2379  enddo
2380  enddo
2381  enddo
2382  endif
2383  used = send_data(idiag%id_qp, wk, time)
2384  endif
2385 
2386  if(idiag%id_us > 0 .and. idiag%id_vs > 0) then
2387  u2(:,:) = atm(n)%ua(isc:iec,jsc:jec,npz)
2388  v2(:,:) = atm(n)%va(isc:iec,jsc:jec,npz)
2389  do j=jsc,jec
2390  do i=isc,iec
2391  a2(i,j) = sqrt(u2(i,j)**2 + v2(i,j)**2)
2392  enddo
2393  enddo
2394  used=send_data(idiag%id_us, u2, time)
2395  used=send_data(idiag%id_vs, v2, time)
2396  if(prt_minmax) call prt_maxmin('Surf_wind_speed', a2, isc, iec, jsc, jec, 0, 1, 1.)
2397  endif
2398 
2399  if(idiag%id_tb > 0) then
2400  a2(:,:) = atm(n)%pt(isc:iec,jsc:jec,npz)
2401  used=send_data(idiag%id_tb, a2, time)
2402  if( prt_minmax ) &
2403  call prt_mxm('T_bot:', a2, isc, iec, jsc, jec, 0, 1, 1., atm(n)%gridstruct%area_64, atm(n)%domain)
2404  endif
2405 
2406  if(idiag%id_ua > 0) used=send_data(idiag%id_ua, atm(n)%ua(isc:iec,jsc:jec,:), time)
2407  if(idiag%id_va > 0) used=send_data(idiag%id_va, atm(n)%va(isc:iec,jsc:jec,:), time)
2408 
2409  if(idiag%id_ke > 0) then
2410  a2(:,:) = 0.
2411  do k=1,npz
2412  do j=jsc,jec
2413  do i=isc,iec
2414  a2(i,j) = a2(i,j) + atm(n)%delp(i,j,k)*(atm(n)%ua(i,j,k)**2+atm(n)%va(i,j,k)**2)
2415  enddo
2416  enddo
2417  enddo
2418 ! Mass weighted KE
2419  do j=jsc,jec
2420  do i=isc,iec
2421  a2(i,j) = 0.5*a2(i,j)/(atm(n)%ps(i,j)-ptop)
2422  enddo
2423  enddo
2424  used=send_data(idiag%id_ke, a2, time)
2425  if(prt_minmax) then
2426  tot_mq = g_sum( atm(n)%domain, a2, isc, iec, jsc, jec, ngc, atm(n)%gridstruct%area_64, 1)
2427  if (master) write(*,*) 'SQRT(2.*KE; m/s)=', sqrt(2.*tot_mq)
2428  endif
2429  endif
2430 
2431 
2432 #ifdef GFS_PHYS
2433  if(idiag%id_delp > 0 .or. idiag%id_cape > 0 .or. idiag%id_cin > 0 .or. ((.not. atm(n)%flagstruct%hydrostatic) .and. idiag%id_pfnh > 0)) then
2434  do k=1,npz
2435  do j=jsc,jec
2436  do i=isc,iec
2437  wk(i,j,k) = atm(n)%delp(i,j,k)*(1.-sum(atm(n)%q(i,j,k,2:atm(n)%flagstruct%nwat)))
2438  enddo
2439  enddo
2440  enddo
2441  if (idiag%id_delp > 0) used=send_data(idiag%id_delp, wk, time)
2442  endif
2443 
2444  if( ( (.not. atm(n)%flagstruct%hydrostatic) .and. idiag%id_pfnh > 0) .or. idiag%id_cape > 0 .or. idiag%id_cin > 0) then
2445  do k=1,npz
2446  do j=jsc,jec
2447  do i=isc,iec
2448 #ifdef MULTI_GASES
2449  wk(i,j,k) = -wk(i,j,k)/(atm(n)%delz(i,j,k)*grav)*rdgas* &
2450  atm(n)%pt(i,j,k)*virq(atm(n)%q(i,j,k,1:num_gas))
2451 #else
2452  wk(i,j,k) = -wk(i,j,k)/(atm(n)%delz(i,j,k)*grav)*rdgas* &
2453  atm(n)%pt(i,j,k)*(1.+zvir*atm(n)%q(i,j,k,sphum))
2454 #endif
2455  enddo
2456  enddo
2457  enddo
2458 ! if (prt_minmax) then
2459 ! call prt_maxmin(' PFNH (mb)', wk(isc:iec,jsc:jec,1), isc, iec, jsc, jec, 0, npz, 1.E-2)
2460 ! endif
2461  used=send_data(idiag%id_pfnh, wk, time)
2462  endif
2463 #else
2464  if(idiag%id_delp > 0) used=send_data(idiag%id_delp, atm(n)%delp(isc:iec,jsc:jec,:), time)
2465 
2466  if( (.not. atm(n)%flagstruct%hydrostatic) .and. (idiag%id_pfnh > 0 .or. idiag%id_cape > 0 .or. idiag%id_cin > 0)) then
2467  do k=1,npz
2468  do j=jsc,jec
2469  do i=isc,iec
2470 #ifdef MULTI_GASES
2471  wk(i,j,k) = -atm(n)%delp(i,j,k)/(atm(n)%delz(i,j,k)*grav)*rdgas* &
2472  atm(n)%pt(i,j,k)*virq(atm(n)%q(i,j,k,1:num_gas))
2473 #else
2474  wk(i,j,k) = -atm(n)%delp(i,j,k)/(atm(n)%delz(i,j,k)*grav)*rdgas* &
2475  atm(n)%pt(i,j,k)*(1.+zvir*atm(n)%q(i,j,k,sphum))
2476 #endif
2477  enddo
2478  enddo
2479  enddo
2480  used=send_data(idiag%id_pfnh, wk, time)
2481  endif
2482 #endif
2483 
2484  if( atm(n)%flagstruct%hydrostatic .and. (idiag%id_pfhy > 0 .or. idiag%id_cape > 0 .or. idiag%id_cin > 0) ) then
2485  do k=1,npz
2486  do j=jsc,jec
2487  do i=isc,iec
2488  wk(i,j,k) = 0.5 *(atm(n)%pe(i,k,j)+atm(n)%pe(i,k+1,j))
2489  enddo
2490  enddo
2491  enddo
2492  used=send_data(idiag%id_pfhy, wk, time)
2493  endif
2494 
2495  if (idiag%id_cape > 0 .or. idiag%id_cin > 0) then
2496  !wk here contains layer-mean pressure
2497 
2498  allocate(var2(isc:iec,jsc:jec))
2499  allocate(a3(isc:iec,jsc:jec,npz))
2500  call eqv_pot(a3, atm(n)%pt, atm(n)%delp, atm(n)%delz, atm(n)%peln, atm(n)%pkz, atm(n)%q(isd:ied,jsd:jed,1:npz,sphum), &
2501  isc, iec, jsc, jec, ngc, npz, atm(n)%flagstruct%hydrostatic, atm(n)%flagstruct%moist_phys)
2502 
2503 !$OMP parallel do default(shared)
2504  do j=jsc,jec
2505  do i=isc,iec
2506  a2(i,j) = 0.
2507  var2(i,j) = 0.
2508 
2509  call getcape(npz, wk(i,j,:), atm(n)%pt(i,j,:), -atm(n)%delz(i,j,:), atm(n)%q(i,j,:,sphum), a3(i,j,:), a2(i,j), var2(i,j), source_in=1)
2510  enddo
2511  enddo
2512 
2513  if (idiag%id_cape > 0) then
2514  if (prt_minmax) then
2515  call prt_maxmin(' CAPE (J/kg)', a2, isc,iec,jsc,jec, 0, 1, 1.)
2516  endif
2517  used=send_data(idiag%id_cape, a2, time)
2518  endif
2519  if (idiag%id_cin > 0) then
2520  if (prt_minmax) then
2521  call prt_maxmin(' CIN (J/kg)', var2, isc,iec,jsc,jec, 0, 1, 1.)
2522  endif
2523  used=send_data(idiag%id_cin, var2, time)
2524  endif
2525 
2526  deallocate(var2)
2527  deallocate(a3)
2528 
2529  endif
2530 
2531 
2532  if((.not. atm(n)%flagstruct%hydrostatic) .and. idiag%id_delz > 0) then
2533  do k=1,npz
2534  do j=jsc,jec
2535  do i=isc,iec
2536  wk(i,j,k) = -atm(n)%delz(i,j,k)
2537  enddo
2538  enddo
2539  enddo
2540  used=send_data(idiag%id_delz, wk, time)
2541  endif
2542 
2543 
2544 ! pressure for masking p-level fields
2545 ! incorrectly defines a2 to be ps (in mb).
2546  if (idiag%id_pmask>0) then
2547  do j=jsc,jec
2548  do i=isc,iec
2549  a2(i,j) = exp((atm(n)%peln(i,npz+1,j)+atm(n)%peln(i,npz+1,j))*0.5)*0.01
2550  !a2(i,j) = Atm(n)%delp(i,j,k)/(Atm(n)%peln(i,k+1,j)-Atm(n)%peln(i,k,j))*0.01
2551  enddo
2552  enddo
2553  used=send_data(idiag%id_pmask, a2, time)
2554  endif
2555 ! fix for pressure for masking p-level fields
2556 ! based on lowest-level pfull
2557 ! define pressure at lowest level the same as interpolate_vertical (in mb)
2558  if (idiag%id_pmaskv2>0) then
2559  do j=jsc,jec
2560  do i=isc,iec
2561  a2(i,j) = exp((atm(n)%peln(i,npz,j)+atm(n)%peln(i,npz+1,j))*0.5)*0.01
2562  enddo
2563  enddo
2564  used=send_data(idiag%id_pmaskv2, a2, time)
2565  endif
2566 
2567  if ( idiag%id_u100m>0 .or. idiag%id_v100m>0 .or. idiag%id_w100m>0 .or. idiag%id_w5km>0 .or. idiag%id_w2500m>0 .or. idiag%id_w1km>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0) then
2568  if (.not.allocated(wz)) allocate ( wz(isc:iec,jsc:jec,npz+1) )
2569  if ( atm(n)%flagstruct%hydrostatic) then
2570  rgrav = 1. / grav
2571 !$OMP parallel do default(none) shared(isc,iec,jsc,jec,wz,npz,Atm,n,rgrav)
2572  do j=jsc,jec
2573  do i=isc,iec
2574  wz(i,j,npz+1) = 0.
2575 ! wz(i,j,npz+1) = Atm(n)%phis(i,j)/grav
2576  enddo
2577  do k=npz,1,-1
2578  do i=isc,iec
2579  wz(i,j,k) = wz(i,j,k+1) - (rdgas*rgrav)*atm(n)%pt(i,j,k)*(atm(n)%peln(i,k,j) - atm(n)%peln(i,k+1,j))
2580  enddo
2581  enddo
2582  enddo
2583  else
2584 !$OMP parallel do default(none) shared(isc,iec,jsc,jec,wz,npz,Atm,n)
2585  do j=jsc,jec
2586  do i=isc,iec
2587  wz(i,j,npz+1) = 0.
2588 ! wz(i,j,npz+1) = Atm(n)%phis(i,j)/grav
2589  enddo
2590  do k=npz,1,-1
2591  do i=isc,iec
2592  wz(i,j,k) = wz(i,j,k+1) - atm(n)%delz(i,j,k)
2593  enddo
2594  enddo
2595  enddo
2596  endif
2597  if( prt_minmax ) &
2598  call prt_maxmin('ZTOP', wz(isc:iec,jsc:jec,1)+atm(n)%phis(isc:iec,jsc:jec)/grav, isc, iec, jsc, jec, 0, 1, 1.e-3)
2599  endif
2600 
2601  if ( idiag%id_rain5km>0 ) then
2602  rainwat = get_tracer_index(model_atmos, 'rainwat')
2603  call interpolate_z(isc, iec, jsc, jec, npz, 5.e3, wz, atm(n)%q(isc:iec,jsc:jec,:,rainwat), a2)
2604  used=send_data(idiag%id_rain5km, a2, time)
2605  if(prt_minmax) call prt_maxmin('rain5km', a2, isc, iec, jsc, jec, 0, 1, 1.)
2606  endif
2607  if ( idiag%id_w5km>0 ) then
2608  call interpolate_z(isc, iec, jsc, jec, npz, 5.e3, wz, atm(n)%w(isc:iec,jsc:jec,:), a2)
2609  used=send_data(idiag%id_w5km, a2, time)
2610  if(prt_minmax) call prt_maxmin('W5km', a2, isc, iec, jsc, jec, 0, 1, 1.)
2611  endif
2612  if ( idiag%id_w2500m>0 ) then
2613  call interpolate_z(isc, iec, jsc, jec, npz, 2.5e3, wz, atm(n)%w(isc:iec,jsc:jec,:), a2)
2614  used=send_data(idiag%id_w2500m, a2, time)
2615  if(prt_minmax) call prt_maxmin('W2500m', a2, isc, iec, jsc, jec, 0, 1, 1.)
2616  endif
2617  if ( idiag%id_w1km>0 ) then
2618  call interpolate_z(isc, iec, jsc, jec, npz, 1.e3, wz, atm(n)%w(isc:iec,jsc:jec,:), a2)
2619  used=send_data(idiag%id_w1km, a2, time)
2620  if(prt_minmax) call prt_maxmin('W1km', a2, isc, iec, jsc, jec, 0, 1, 1.)
2621  endif
2622  if ( idiag%id_w100m>0 ) then
2623  call interpolate_z(isc, iec, jsc, jec, npz, 100., wz, atm(n)%w(isc:iec,jsc:jec,:), a2)
2624  used=send_data(idiag%id_w100m, a2, time)
2625  if(prt_minmax) call prt_maxmin('w100m', a2, isc, iec, jsc, jec, 0, 1, 1.)
2626  endif
2627  if ( idiag%id_u100m>0 ) then
2628  call interpolate_z(isc, iec, jsc, jec, npz, 100., wz, atm(n)%ua(isc:iec,jsc:jec,:), a2)
2629  used=send_data(idiag%id_u100m, a2, time)
2630  if(prt_minmax) call prt_maxmin('u100m', a2, isc, iec, jsc, jec, 0, 1, 1.)
2631  endif
2632  if ( idiag%id_v100m>0 ) then
2633  call interpolate_z(isc, iec, jsc, jec, npz, 100., wz, atm(n)%va(isc:iec,jsc:jec,:), a2)
2634  used=send_data(idiag%id_v100m, a2, time)
2635  if(prt_minmax) call prt_maxmin('v100m', a2, isc, iec, jsc, jec, 0, 1, 1.)
2636  endif
2637 
2638  if ( rainwat > 0 .and. (idiag%id_dbz>0 .or. idiag%id_maxdbz>0 .or. idiag%id_basedbz>0 .or. idiag%id_dbz4km>0 .or. idiag%id_dbztop>0 .or. idiag%id_dbz_m10C>0)) then
2639 
2640  if (.not. allocated(a3)) allocate(a3(isc:iec,jsc:jec,npz))
2641 
2642 ! call dbzcalc_smithxue(Atm(n)%q, Atm(n)%pt, Atm(n)%delp, Atm(n)%peln, Atm(n)%delz, &
2643  call dbzcalc(atm(n)%q, atm(n)%pt, atm(n)%delp, atm(n)%peln, atm(n)%delz, &
2644  a3, a2, allmax, atm(n)%bd, npz, atm(n)%ncnst, atm(n)%flagstruct%hydrostatic, &
2645  zvir, .false., .false., .false., .true. ) ! GFDL MP has constant N_0 intercept
2646 
2647  if (idiag%id_dbz > 0) used=send_data(idiag%id_dbz, a3, time)
2648  if (idiag%id_maxdbz > 0) used=send_data(idiag%id_maxdbz, a2, time)
2649 
2650  if (idiag%id_basedbz > 0) then
2651  !interpolate to 1km dbz
2652  call cs_interpolator(isc, iec, jsc, jec, npz, a3, 1000., wz, a2, -20.)
2653  used=send_data(idiag%id_basedbz, a2, time)
2654  if(prt_minmax) call prt_maxmin('Base_dBz', a2, isc, iec, jsc, jec, 0, 1, 1.)
2655  endif
2656 
2657  if (idiag%id_dbz4km > 0) then
2658  !interpolate to 1km dbz
2659  call cs_interpolator(isc, iec, jsc, jec, npz, a3, 4000., wz, a2, -20.)
2660  used=send_data(idiag%id_dbz4km, a2, time)
2661  endif
2662  if (idiag%id_dbztop > 0) then
2663  do j=jsc,jec
2664  do i=isc,iec
2665  a2(i,j) = missing_value
2666  do k=2,npz
2667  if (wz(i,j,k) >= 25000. ) continue ! nothing above 25 km
2668  if (a3(i,j,k) >= 18.5 ) then
2669  a2(i,j) = wz(i,j,k)
2670  exit
2671  endif
2672  enddo
2673  enddo
2674  enddo
2675  used=send_data(idiag%id_dbztop, a2, time)
2676  endif
2677  if (idiag%id_dbz_m10C > 0) then
2678  do j=jsc,jec
2679  do i=isc,iec
2680  a2(i,j) = missing_value
2681  do k=npz,1,-1
2682  if (wz(i,j,k) >= 25000. ) exit ! nothing above 25 km
2683  if (atm(n)%pt(i,j,k) <= 263.14 ) then
2684  a2(i,j) = a3(i,j,k)
2685  exit
2686  endif
2687  enddo
2688  enddo
2689  enddo
2690  used=send_data(idiag%id_dbz_m10C, a2, time)
2691  endif
2692 
2693  if (prt_minmax) then
2694  call mpp_max(allmax)
2695  if (master) write(*,*) 'max reflectivity = ', allmax, ' dBZ'
2696  endif
2697 
2698  deallocate(a3)
2699  endif
2700 !-------------------------------------------------------
2701 ! Applying cubic-spline as the intepolator for (u,v,T,q)
2702 !-------------------------------------------------------
2703  if(.not. allocated(a3)) allocate( a3(isc:iec,jsc:jec,nplev) )
2704 ! u-winds:
2705  idg(:) = idiag%id_u(:)
2706 
2707  do_cs_intp = .false.
2708  do i=1,nplev
2709  if ( idg(i)>0 ) then
2710  do_cs_intp = .true.
2711  exit
2712  endif
2713  enddo
2714 
2715  if ( do_cs_intp ) then
2716  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%ua(isc:iec,jsc:jec,:), nplev, &
2717  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, -1)
2718 ! plevs, Atm(n)%peln, idg, a3, -1)
2719  do i=1,nplev
2720  if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), time)
2721  enddo
2722  endif
2723 
2724  if (idiag%id_u_plev>0) then
2725  id1(:) = 1
2726  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%ua(isc:iec,jsc:jec,:), nplev, &
2727  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, -1)
2728  used=send_data(idiag%id_u_plev, a3(isc:iec,jsc:jec,:), time)
2729  endif
2730 
2731 ! v-winds:
2732  idg(:) = idiag%id_v(:)
2733 
2734  do_cs_intp = .false.
2735  do i=1,nplev
2736  if ( idg(i)>0 ) then
2737  do_cs_intp = .true.
2738  exit
2739  endif
2740  enddo
2741 
2742  if ( do_cs_intp ) then
2743  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%va(isc:iec,jsc:jec,:), nplev, &
2744  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, -1)
2745 ! plevs, Atm(n)%peln, idg, a3, -1)
2746  do i=1,nplev
2747  if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), time)
2748  enddo
2749  endif
2750 
2751  if (idiag%id_v_plev>0) then
2752  id1(:) = 1
2753  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%va(isc:iec,jsc:jec,:), nplev, &
2754  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, -1)
2755  used=send_data(idiag%id_v_plev, a3(isc:iec,jsc:jec,:), time)
2756  endif
2757 
2758 ! Specific humidity
2759  idg(:) = idiag%id_q(:)
2760 
2761  do_cs_intp = .false.
2762  do i=1,nplev
2763  if ( idg(i)>0 ) then
2764  do_cs_intp = .true.
2765  exit
2766  endif
2767  enddo
2768 
2769  if ( do_cs_intp ) then
2770  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%q(isc:iec,jsc:jec,:,sphum), nplev, &
2771  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, 0)
2772 ! plevs, Atm(n)%peln, idg, a3, 0)
2773  do i=1,nplev
2774  if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), time)
2775  enddo
2776  endif
2777 
2778  if (idiag%id_q_plev>0) then
2779  id1(:) = 1
2780  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%q(isc:iec,jsc:jec,:,sphum), nplev, &
2781  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, 0)
2782  used=send_data(idiag%id_q_plev, a3(isc:iec,jsc:jec,:), time)
2783  endif
2784 
2785 ! Omega
2786  idg(:) = idiag%id_omg(:)
2787 
2788  do_cs_intp = .false.
2789  do i=1,nplev
2790  if ( idg(i)>0 ) then
2791  do_cs_intp = .true.
2792  exit
2793  endif
2794  enddo
2795  if ( do_cs_intp ) then
2796  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%omga(isc:iec,jsc:jec,:), nplev, &
2797  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), idg, a3, -1)
2798 ! plevs, Atm(n)%peln, idg, a3)
2799  do i=1,nplev
2800  if (idg(i)>0) used=send_data(idg(i), a3(isc:iec,jsc:jec,i), time)
2801  enddo
2802  endif
2803 
2804  if (idiag%id_omg_plev>0) then
2805  id1(:) = 1
2806  call cs3_interpolator(isc,iec,jsc,jec,npz, atm(n)%omga(isc:iec,jsc:jec,:), nplev, &
2807  pout, wz, atm(n)%pe(isc:iec,1:npz+1,jsc:jec), id1, a3, -1)
2808  used=send_data(idiag%id_omg_plev, a3(isc:iec,jsc:jec,:), time)
2809  endif
2810 
2811  if( allocated(a3) ) deallocate (a3)
2812 ! *** End cs_intp
2813 
2814  if ( idiag%id_sl12>0 ) then ! 13th level wind speed (~ 222 mb for the 32L setup)
2815  do j=jsc,jec
2816  do i=isc,iec
2817  a2(i,j) = sqrt(atm(n)%ua(i,j,12)**2 + atm(n)%va(i,j,12)**2)
2818  enddo
2819  enddo
2820  used=send_data(idiag%id_sl12, a2, time)
2821  endif
2822  if ( idiag%id_sl13>0 ) then ! 13th level wind speed (~ 222 mb for the 32L setup)
2823  do j=jsc,jec
2824  do i=isc,iec
2825  a2(i,j) = sqrt(atm(n)%ua(i,j,13)**2 + atm(n)%va(i,j,13)**2)
2826  enddo
2827  enddo
2828  used=send_data(idiag%id_sl13, a2, time)
2829  endif
2830 
2831  if ( (.not.atm(n)%flagstruct%hydrostatic) .and. idiag%id_w200>0 ) then
2832  call interpolate_vertical(isc, iec, jsc, jec, npz, &
2833  200.e2, atm(n)%peln, atm(n)%w(isc:iec,jsc:jec,:), a2)
2834  used=send_data(idiag%id_w200, a2, time)
2835  endif
2836 ! 500-mb
2837  if ( (.not.atm(n)%flagstruct%hydrostatic) .and. idiag%id_w500>0 ) then
2838  call interpolate_vertical(isc, iec, jsc, jec, npz, &
2839  500.e2, atm(n)%peln, atm(n)%w(isc:iec,jsc:jec,:), a2)
2840  used=send_data(idiag%id_w500, a2, time)
2841  endif
2842  if ( (.not.atm(n)%flagstruct%hydrostatic) .and. idiag%id_w700>0 ) then
2843  call interpolate_vertical(isc, iec, jsc, jec, npz, &
2844  700.e2, atm(n)%peln, atm(n)%w(isc:iec,jsc:jec,:), a2)
2845  used=send_data(idiag%id_w700, a2, time)
2846  endif
2847  if ( (.not.atm(n)%flagstruct%hydrostatic) .and. idiag%id_w850>0 .or. idiag%id_x850>0) then
2848  call interpolate_vertical(isc, iec, jsc, jec, npz, &
2849  850.e2, atm(n)%peln, atm(n)%w(isc:iec,jsc:jec,:), a2)
2850  used=send_data(idiag%id_w850, a2, time)
2851 
2852  if ( idiag%id_x850>0 .and. idiag%id_vort850>0 ) then
2853  x850(:,:) = x850(:,:)*a2(:,:)
2854  used=send_data(idiag%id_x850, x850, time)
2855  deallocate ( x850 )
2856  endif
2857  endif
2858 
2859 
2860  if ( .not.atm(n)%flagstruct%hydrostatic .and. idiag%id_w>0 ) then
2861  used=send_data(idiag%id_w, atm(n)%w(isc:iec,jsc:jec,:), time)
2862  endif
2863  if ( .not. atm(n)%flagstruct%hydrostatic .and. (idiag%id_wmaxup>0 .or. idiag%id_wmaxdn>0) ) then
2864  allocate(var2(isc:iec,jsc:jec))
2865  do j=jsc,jec
2866  do i=isc,iec
2867  a2(i,j) = 0.
2868  var2(i,j) = 0.
2869  do k=3,npz
2870  if (atm(n)%pe(i,k,j) <= 400.e2) continue
2871  a2(i,j) = max(a2(i,j),atm(n)%w(i,j,k))
2872  var2(i,j) = min(var2(i,j),atm(n)%w(i,j,k))
2873  enddo
2874  enddo
2875  enddo
2876  if (idiag%id_wmaxup > 0) then
2877  used=send_data(idiag%id_wmaxup, a2, time)
2878  endif
2879  if (idiag%id_wmaxdn > 0) then
2880  used=send_data(idiag%id_wmaxdn, var2, time)
2881  endif
2882  deallocate(var2)
2883  endif
2884 
2885  if(idiag%id_pt > 0) used=send_data(idiag%id_pt , atm(n)%pt (isc:iec,jsc:jec,:), time)
2886  if(idiag%id_omga > 0) used=send_data(idiag%id_omga, atm(n)%omga(isc:iec,jsc:jec,:), time)
2887  if(idiag%id_diss > 0) used=send_data(idiag%id_diss, atm(n)%diss_est(isc:iec,jsc:jec,:), time)
2888 
2889  allocate( a3(isc:iec,jsc:jec,npz) )
2890  if(idiag%id_theta_e > 0 ) then
2891 
2892  if ( atm(n)%flagstruct%adiabatic .and. atm(n)%flagstruct%kord_tm>0 ) then
2893  do k=1,npz
2894  do j=jsc,jec
2895  do i=isc,iec
2896  a3(i,j,k) = atm(n)%pt(i,j,k)
2897  enddo
2898  enddo
2899  enddo
2900  else
2901  call eqv_pot(a3, atm(n)%pt, atm(n)%delp, atm(n)%delz, atm(n)%peln, atm(n)%pkz, atm(n)%q(isd:ied,jsd:jed,1:npz,sphum), &
2902  isc, iec, jsc, jec, ngc, npz, atm(n)%flagstruct%hydrostatic, atm(n)%flagstruct%moist_phys)
2903  endif
2904 
2905  if (idiag%id_theta_e > 0) then
2906  if( prt_minmax ) call prt_maxmin('Theta_E', a3, isc, iec, jsc, jec, 0, npz, 1.)
2907  used=send_data(idiag%id_theta_e, a3, time)
2908  end if
2909  theta_d = get_tracer_index(model_atmos, 'theta_d')
2910  if ( theta_d>0 ) then
2911  if( prt_minmax ) then
2912  ! Check level-34 ~ 300 mb
2913  a2(:,:) = 0.
2914  do k=1,npz
2915  do j=jsc,jec
2916  do i=isc,iec
2917  a2(i,j) = a2(i,j) + atm(n)%delp(i,j,k)*(atm(n)%q(i,j,k,theta_d)-a3(i,j,k))**2
2918  enddo
2919  enddo
2920  enddo
2921  call prt_mxm('PT_SUM', a2, isc, iec, jsc, jec, 0, 1, 1.e-5, atm(n)%gridstruct%area_64, atm(n)%domain)
2922 
2923  do k=1,npz
2924  do j=jsc,jec
2925  do i=isc,iec
2926  a3(i,j,k) = atm(n)%q(i,j,k,theta_d)/a3(i,j,k) - 1.
2927  enddo
2928  enddo
2929  enddo
2930  call prt_maxmin('Theta_Err (%)', a3, isc, iec, jsc, jec, 0, npz, 100.)
2931  ! if ( master ) write(*,*) 'PK0=', pk0, 'KAPPA=', kappa
2932  endif
2933  endif
2934 
2935  endif
2936 
2937  if(idiag%id_ppt> 0) then
2938 ! Potential temperature perturbation for gravity wave test_case
2939  allocate ( idiag%pt1(npz) )
2940  if( .not. allocated(a3) ) allocate ( a3(isc:iec,jsc:jec,npz) )
2941 #ifdef TEST_GWAVES
2942  call gw_1d(npz, 1000.e2, atm(n)%ak, atm(n)%ak, atm(n)%ak(1), 10.e3, idiag%pt1)
2943 #else
2944  idiag%pt1 = 0.
2945 #endif
2946  do k=1,npz
2947  do j=jsc,jec
2948  do i=isc,iec
2949 ! wk(i,j,k) = (Atm(n)%pt(i,j,k)-300.)/Atm(n)%pkz(i,j,k) * pk0
2950  wk(i,j,k) = (atm(n)%pt(i,j,k)/atm(n)%pkz(i,j,k) - idiag%pt1(k)) * pk0
2951  enddo
2952  enddo
2953  enddo
2954  used=send_data(idiag%id_ppt, wk, time)
2955 
2956  if( prt_minmax ) then
2957  call prt_maxmin('PoTemp', wk, isc, iec, jsc, jec, 0, npz, 1.)
2958  endif
2959 
2960  if( allocated(a3) ) deallocate ( a3 )
2961  deallocate ( idiag%pt1 )
2962  endif
2963 
2964 
2965 #ifndef SW_DYNAMICS
2966  do itrac=1, atm(n)%ncnst
2967  call get_tracer_names (model_atmos, itrac, tname)
2968  if (idiag%id_tracer(itrac) > 0 .and. itrac.gt.nq) then
2969  used = send_data(idiag%id_tracer(itrac), atm(n)%qdiag(isc:iec,jsc:jec,:,itrac), time )
2970  else
2971  used = send_data(idiag%id_tracer(itrac), atm(n)%q(isc:iec,jsc:jec,:,itrac), time )
2972  endif
2973  if (itrac .le. nq) then
2974  if( prt_minmax ) call prt_maxmin(trim(tname), atm(n)%q(:,:,1,itrac), &
2975  isc, iec, jsc, jec, ngc, npz, 1.)
2976  else
2977  if( prt_minmax ) call prt_maxmin(trim(tname), atm(n)%qdiag(:,:,1,itrac), &
2978  isc, iec, jsc, jec, ngc, npz, 1.)
2979  endif
2980 !-------------------------------
2981 ! ESM TRACER diagnostics output:
2982 ! jgj: per SJ email (jul 17 2008): q_dry = q_moist/(1-sphum)
2983 ! mass mixing ratio: q_dry = mass_tracer/mass_dryair = mass_tracer/(mass_air - mass_water) ~ q_moist/(1-sphum)
2984 ! co2_mmr = (wco2/wair) * co2_vmr
2985 ! Note: There is a check to ensure tracer number one is sphum
2986 
2987  if (idiag%id_tracer_dmmr(itrac) > 0 .or. idiag%id_tracer_dvmr(itrac) > 0) then
2988  if (itrac .gt. nq) then
2989  dmmr(:,:,:) = atm(n)%qdiag(isc:iec,jsc:jec,1:npz,itrac) &
2990  /(1.0-atm(n)%q(isc:iec,jsc:jec,1:npz,1))
2991  else
2992  dmmr(:,:,:) = atm(n)%q(isc:iec,jsc:jec,1:npz,itrac) &
2993  /(1.0-atm(n)%q(isc:iec,jsc:jec,1:npz,1))
2994  endif
2995  dvmr(:,:,:) = dmmr(isc:iec,jsc:jec,1:npz) * wtmair/idiag%w_mr(itrac)
2996  used = send_data(idiag%id_tracer_dmmr(itrac), dmmr, time )
2997  used = send_data(idiag%id_tracer_dvmr(itrac), dvmr, time )
2998  if( prt_minmax ) then
2999  call prt_maxmin(trim(tname)//'_dmmr', dmmr, &
3000  isc, iec, jsc, jec, 0, npz, 1.)
3001  call prt_maxmin(trim(tname)//'_dvmr', dvmr, &
3002  isc, iec, jsc, jec, 0, npz, 1.)
3003  endif
3004  endif
3005  enddo
3006 
3007 ! Maximum overlap cloud fraction
3008  if ( .not. atm(n)%neststruct%nested ) then
3009  if ( cld_amt > 0 .and. prt_minmax ) then
3010  a2(:,:) = 0.
3011  do k=1,npz
3012  do j=jsc,jec
3013  do i=isc,iec
3014  a2(i,j) = max(a2(i,j), atm(n)%q(i,j,k,cld_amt) )
3015  enddo
3016  enddo
3017  enddo
3018  call prt_gb_nh_sh('Max_cld GB_NH_SH_EQ',isc,iec, jsc,jec, a2, atm(n)%gridstruct%area_64(isc:iec,jsc:jec), &
3019  atm(n)%gridstruct%agrid_64(isc:iec,jsc:jec,2))
3020  endif
3021  endif
3022 
3023 #endif
3024 
3025  ! enddo ! end ntileMe do-loop
3026 
3027  deallocate ( a2 )
3028  deallocate ( u2 )
3029  deallocate ( v2 )
3030  deallocate ( wk )
3031 
3032  if (allocated(a3)) deallocate(a3)
3033  if (allocated(wz)) deallocate(wz)
3034  if (allocated(dmmr)) deallocate(dmmr)
3035  if (allocated(dvmr)) deallocate(dvmr)
3036 
3037  call nullify_domain()
3038 
3039 
3040  end subroutine fv_diag
3041 
3042  subroutine wind_max(isc, iec, jsc, jec ,isd, ied, jsd, jed, us, vs, ws_max, domain)
3043  integer isc, iec, jsc, jec
3044  integer isd, ied, jsd, jed
3045  real, intent(in), dimension(isc:iec,jsc:jec):: us, vs
3046  real, intent(out) :: ws_max(isc:iec,jsc:jec)
3047  type(domain2d), intent(INOUT) :: domain
3048 ! Local
3049  real :: wx(isc:iec,jsd:jed), ws(isd:ied,jsd:jed)
3050  integer:: i,j
3051 
3052  ws = 0. ! fill corners with zeros
3053  do j=jsc,jec
3054  do i=isc,iec
3055  ws(i,j) = sqrt(us(i,j)**2 + vs(i,j)**2)
3056  enddo
3057  enddo
3058 
3059  call mpp_update_domains( ws, domain )
3060 
3061  do j=jsd,jed
3062  do i=isc,iec
3063  wx(i,j) = max(ws(i-3,j), ws(i-2,j), ws(i-1,j), ws(i,j), ws(i+1,j), ws(i+2,j), ws(i+3,j))
3064  enddo
3065  enddo
3066 
3067  do j=jsc,jec
3068  do i=isc,iec
3069  ws_max(i,j) = max(wx(i,j-3), wx(i,j-2), wx(i,j-1), wx(i,j), wx(i,j+1), wx(i,j+2), wx(i,j+3))
3070  enddo
3071  enddo
3072 
3073  end subroutine wind_max
3074 
3075 
3076  subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
3077  integer isd, ied, jsd, jed, npz
3078  integer isc, iec, jsc, jec
3079  real, intent(in) :: u(isd:ied, jsd:jed+1, npz), v(isd:ied+1, jsd:jed, npz)
3080  real, intent(out) :: vort(isc:iec, jsc:jec, npz)
3081  real, intent(IN) :: dx(isd:ied,jsd:jed+1)
3082  real, intent(IN) :: dy(isd:ied+1,jsd:jed)
3083  real, intent(IN) :: rarea(isd:ied,jsd:jed)
3084 ! Local
3085  real :: utmp(isc:iec, jsc:jec+1), vtmp(isc:iec+1, jsc:jec)
3086  integer :: i,j,k
3087 
3088  do k=1,npz
3089  do j=jsc,jec+1
3090  do i=isc,iec
3091  utmp(i,j) = u(i,j,k)*dx(i,j)
3092  enddo
3093  enddo
3094  do j=jsc,jec
3095  do i=isc,iec+1
3096  vtmp(i,j) = v(i,j,k)*dy(i,j)
3097  enddo
3098  enddo
3099 
3100  do j=jsc,jec
3101  do i=isc,iec
3102  vort(i,j,k) = rarea(i,j)*(utmp(i,j)-utmp(i,j+1)-vtmp(i,j)+vtmp(i+1,j))
3103  enddo
3104  enddo
3105  enddo
3106 
3107  end subroutine get_vorticity
3108 
3109 
3110  subroutine get_height_field(is, ie, js, je, ng, km, hydrostatic, delz, wz, pt, q, peln, zvir)
3111  integer, intent(in):: is, ie, js, je, km, ng
3112  real, intent(in):: peln(is:ie,km+1,js:je)
3113  real, intent(in):: pt(is-ng:ie+ng,js-ng:je+ng,km)
3114  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*) ! water vapor
3115  real, intent(in):: delz(is-ng:,js-ng:,1:)
3116  real, intent(in):: zvir
3117  logical, intent(in):: hydrostatic
3118  real, intent(out):: wz(is:ie,js:je,km+1)
3119 !
3120  integer i,j,k
3121  real gg
3122 
3123  gg = rdgas * ginv
3124 
3125  do j=js,je
3126  do i=is,ie
3127  wz(i,j,km+1) = idiag%zsurf(i,j)
3128  enddo
3129  if (hydrostatic ) then
3130  do k=km,1,-1
3131  do i=is,ie
3132 #ifdef MULTI_GASES
3133  wz(i,j,k) = wz(i,j,k+1) + gg*pt(i,j,k)*virq(q(i,j,k,1:num_gas)) &
3134  *(peln(i,k+1,j)-peln(i,k,j))
3135 #else
3136  wz(i,j,k) = wz(i,j,k+1) + gg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum)) &
3137  *(peln(i,k+1,j)-peln(i,k,j))
3138 #endif
3139  enddo
3140  enddo
3141  else
3142  do k=km,1,-1
3143  do i=is,ie
3144  wz(i,j,k) = wz(i,j,k+1) - delz(i,j,k)
3145  enddo
3146  enddo
3147  endif
3148  enddo
3149 
3150  end subroutine get_height_field
3151 
3152  subroutine range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_range)
3153  character(len=*), intent(in):: qname
3154  integer, intent(in):: is, ie, js, je
3155  integer, intent(in):: n_g, km
3156  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3157  real, intent(in):: pos(is-n_g:ie+n_g, js-n_g:je+n_g,2)
3158  real, intent(in):: q_low, q_hi
3159  logical, optional, intent(out):: bad_range
3160 !
3161  real qmin, qmax
3162  integer i,j,k
3163 
3164  if ( present(bad_range) ) bad_range = .false.
3165  qmin = q(is,js,1)
3166  qmax = qmin
3167 
3168  do k=1,km
3169  do j=js,je
3170  do i=is,ie
3171  if( q(i,j,k) < qmin ) then
3172  qmin = q(i,j,k)
3173  elseif( q(i,j,k) > qmax ) then
3174  qmax = q(i,j,k)
3175  endif
3176  enddo
3177  enddo
3178  enddo
3179 
3180  call mp_reduce_min(qmin)
3181  call mp_reduce_max(qmax)
3182 
3183  if( qmin<q_low .or. qmax>q_hi ) then
3184  if(master) write(*,*) 'Range_check Warning:', qname, ' max = ', qmax, ' min = ', qmin
3185  if ( present(bad_range) ) then
3186  bad_range = .true.
3187  endif
3188  endif
3189 
3190  if ( present(bad_range) ) then
3191 ! Print out where the bad value(s) is (are)
3192  if ( bad_range .EQV. .false. ) return
3193  do k=1,km
3194  do j=js,je
3195  do i=is,ie
3196  if( q(i,j,k)<q_low .or. q(i,j,k)>q_hi ) then
3197  write(*,*) 'Warn_K=',k,'(i,j)=',i,j, pos(i,j,1)*rad2deg, pos(i,j,2)*rad2deg, q(i,j,k)
3198  if ( k/= 1 ) write(*,*) k-1, q(i,j,k-1)
3199  if ( k/=km ) write(*,*) k+1, q(i,j,k+1)
3200  endif
3201  enddo
3202  enddo
3203  enddo
3204  call mpp_error(note,'==> Error from range_check: data out of bound')
3205  endif
3206 
3207  end subroutine range_check
3208 
3209  subroutine prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac)
3210  character(len=*), intent(in):: qname
3211  integer, intent(in):: is, ie, js, je
3212  integer, intent(in):: n_g, km
3213  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3214  real, intent(in):: fac
3215 
3216  real qmin, qmax
3217  integer i,j,k
3218  !mpp_root_pe doesn't appear to recognize nested grid
3219  master = (mpp_pe()==mpp_root_pe()) .or. is_master()
3220 
3221  qmin = q(is,js,1)
3222  qmax = qmin
3223 
3224  do k=1,km
3225  do j=js,je
3226  do i=is,ie
3227 ! qmin = min(qmin, q(i,j,k))
3228 ! qmax = max(qmax, q(i,j,k))
3229  if( q(i,j,k) < qmin ) then
3230  qmin = q(i,j,k)
3231  elseif( q(i,j,k) > qmax ) then
3232  qmax = q(i,j,k)
3233  endif
3234  enddo
3235  enddo
3236  enddo
3237 
3238  call mp_reduce_min(qmin)
3239  call mp_reduce_max(qmax)
3240 
3241  if(master) then
3242  write(*,*) qname//trim(gn), ' max = ', qmax*fac, ' min = ', qmin*fac
3243  endif
3244 
3245  end subroutine prt_maxmin
3246 
3247  subroutine prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain)
3248  character(len=*), intent(in):: qname
3249  integer, intent(in):: is, ie, js, je
3250  integer, intent(in):: n_g, km
3251  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3252  real, intent(in):: fac
3253 ! BUG !!!
3254 ! real, intent(IN):: area(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3255  real(kind=R_GRID), intent(IN):: area(is-3:ie+3, js-3:je+3)
3256  type(domain2d), intent(INOUT) :: domain
3257 !
3258  real qmin, qmax, gmean
3259  integer i,j,k
3260 
3261  !mpp_root_pe doesn't appear to recognize nested grid
3262  master = (mpp_pe()==mpp_root_pe()) .or. is_master()
3263  qmin = q(is,js,1)
3264  qmax = qmin
3265  gmean = 0.
3266 
3267  do k=1,km
3268  do j=js,je
3269  do i=is,ie
3270 ! qmin = min(qmin, q(i,j,k))
3271 ! qmax = max(qmax, q(i,j,k))
3272  if( q(i,j,k) < qmin ) then
3273  qmin = q(i,j,k)
3274  elseif( q(i,j,k) > qmax ) then
3275  qmax = q(i,j,k)
3276  endif
3277  enddo
3278  enddo
3279  enddo
3280 
3281  call mp_reduce_min(qmin)
3282  call mp_reduce_max(qmax)
3283 
3284 ! SJL: BUG!!!
3285 ! gmean = g_sum(domain, q(is,js,km), is, ie, js, je, 3, area, 1)
3286  gmean = g_sum(domain, q(is:ie,js:je,km), is, ie, js, je, 3, area, 1)
3287 
3288  if(master) write(6,*) qname, gn, qmax*fac, qmin*fac, gmean*fac
3289 
3290  end subroutine prt_mxm
3291 
3292  !Added nwat == 1 case for water vapor diagnostics
3293  subroutine prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain)
3295  integer, intent(in):: is, ie, js, je
3296  integer, intent(in):: nq, n_g, km, nwat
3297  real, intent(in):: ps(is-n_g:ie+n_g, js-n_g:je+n_g)
3298  real, intent(in):: delp(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3299  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km, nq)
3300  real(kind=R_GRID), intent(IN):: area(is-n_g:ie+n_g,js-n_g:je+n_g)
3301  type(domain2d), intent(INOUT) :: domain
3302 ! Local:
3303  real psq(is:ie,js:je,nwat), psqv(is:ie,js:je)
3304  real q_strat(is:ie,js:je)
3305  real qtot(nwat), qwat
3306  real psmo, totw, psdry
3307  integer k, n, kstrat
3308 
3309 !Needed when calling prt_mass in fv_restart?
3310  sphum = get_tracer_index(model_atmos, 'sphum')
3311  liq_wat = get_tracer_index(model_atmos, 'liq_wat')
3312  ice_wat = get_tracer_index(model_atmos, 'ice_wat')
3313 
3314  rainwat = get_tracer_index(model_atmos, 'rainwat')
3315  snowwat = get_tracer_index(model_atmos, 'snowwat')
3316  graupel = get_tracer_index(model_atmos, 'graupel')
3317 
3318  if ( nwat==0 ) then
3319  psmo = g_sum(domain, ps(is:ie,js:je), is, ie, js, je, n_g, area, 1)
3320  if( master ) write(*,*) 'Total surface pressure (mb)', trim(gn), ' = ', 0.01*psmo
3321  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,1 ), psqv(is,js))
3322  return
3323  endif
3324 
3325  psq(:,:,:) = 0.
3326  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,sphum ), psq(is,js,sphum ))
3327 
3328  if (liq_wat > 0) &
3329  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,liq_wat), psq(is,js,liq_wat))
3330 
3331  if (rainwat > 0) &
3332  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,rainwat), psq(is,js,rainwat))
3333 
3334 !nwat == 4 => KESSLER, ice is probably garbage...
3335  if (ice_wat > 0) &
3336  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,ice_wat), psq(is,js,ice_wat))
3337 
3338  if (snowwat > 0) &
3339  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,snowwat), psq(is,js,snowwat))
3340  if (graupel > 0) &
3341  call z_sum(is, ie, js, je, km, n_g, delp, q(is-n_g,js-n_g,1,graupel), psq(is,js,graupel))
3342 
3343 
3344 ! Mean water vapor in the "stratosphere" (75 mb and above):
3345  if ( idiag%phalf(2)< 75. ) then
3346  kstrat = 1
3347  do k=1,km
3348  if ( idiag%phalf(k+1) > 75. ) exit
3349  kstrat = k
3350  enddo
3351  call z_sum(is, ie, js, je, kstrat, n_g, delp, q(is-n_g,js-n_g,1,sphum), q_strat(is,js))
3352  psmo = g_sum(domain, q_strat(is,js), is, ie, js, je, n_g, area, 1) * 1.e6 &
3353  / p_sum(is, ie, js, je, kstrat, n_g, delp, area, domain)
3354  if(master) write(*,*) 'Mean specific humidity (mg/kg) above 75 mb', trim(gn), '=', psmo
3355  endif
3356 
3357 
3358 !-------------------
3359 ! Check global means
3360 !-------------------
3361  psmo = g_sum(domain, ps(is:ie,js:je), is, ie, js, je, n_g, area, 1)
3362 
3363  do n=1,nwat
3364  qtot(n) = g_sum(domain, psq(is,js,n), is, ie, js, je, n_g, area, 1)
3365  enddo
3366 
3367  totw = sum(qtot(1:nwat))
3368  psdry = psmo - totw
3369 
3370  if( master ) then
3371  write(*,*) 'Total surface pressure (mb)', trim(gn), ' = ', 0.01*psmo
3372  write(*,*) 'mean dry surface pressure', trim(gn), ' = ', 0.01*psdry
3373  write(*,*) 'Total Water Vapor (kg/m**2)', trim(gn), ' =', qtot(sphum)*ginv
3374  if ( nwat> 2 ) then
3375  write(*,*) '--- Micro Phys water substances (kg/m**2) ---'
3376  write(*,*) 'Total cloud water', trim(gn), '=', qtot(liq_wat)*ginv
3377  if (rainwat > 0) &
3378  write(*,*) 'Total rain water', trim(gn), '=', qtot(rainwat)*ginv
3379  if (ice_wat > 0) &
3380  write(*,*) 'Total cloud ice ', trim(gn), '=', qtot(ice_wat)*ginv
3381  if (snowwat > 0) &
3382  write(*,*) 'Total snow ', trim(gn), '=', qtot(snowwat)*ginv
3383  if (graupel > 0) &
3384  write(*,*) 'Total graupel ', trim(gn), '=', qtot(graupel)*ginv
3385  write(*,*) '---------------------------------------------'
3386  elseif ( nwat==2 ) then
3387  write(*,*) 'GFS condensate (kg/m^2)', trim(gn), '=', qtot(liq_wat)*ginv
3388  endif
3389  endif
3390 
3391  end subroutine prt_mass
3392 
3393 
3394  subroutine z_sum(is, ie, js, je, km, n_g, delp, q, sum2)
3395  integer, intent(in):: is, ie, js, je, n_g, km
3396  real, intent(in):: delp(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3397  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3398  real, intent(out):: sum2(is:ie,js:je)
3399 
3400  integer i,j,k
3401 
3402  do j=js,je
3403  do i=is,ie
3404  sum2(i,j) = delp(i,j,1)*q(i,j,1)
3405  enddo
3406  do k=2,km
3407  do i=is,ie
3408  sum2(i,j) = sum2(i,j) + delp(i,j,k)*q(i,j,k)
3409  enddo
3410  enddo
3411  enddo
3412 
3413  end subroutine z_sum
3414 
3415 
3416  real function p_sum(is, ie, js, je, km, n_g, delp, area, domain)
3417  integer, intent(in):: is, ie, js, je, n_g, km
3418  real, intent(in):: delp(is-n_g:ie+n_g, js-n_g:je+n_g, km)
3419  real(kind=R_GRID), intent(IN) :: area(is-n_g:ie+n_g, js-n_g:je+n_g)
3420  real :: sum2(is:ie,js:je)
3421  integer i,j,k
3422  type(domain2d), intent(INOUT) :: domain
3423 
3424 !$OMP parallel do default(none) shared(is,ie,js,je,km,sum2,delp)
3425  do j=js,je
3426  do i=is,ie
3427  sum2(i,j) = delp(i,j,1)
3428  enddo
3429  do k=2,km
3430  do i=is,ie
3431  sum2(i,j) = sum2(i,j) + delp(i,j,k)
3432  enddo
3433  enddo
3434  enddo
3435  p_sum = g_sum(domain, sum2, is, ie, js, je, n_g, area, 1)
3436 
3437  end function p_sum
3438 
3439 
3440 
3441  subroutine get_pressure_given_height(is, ie, js, je, ng, km, wz, kd, height, &
3442  ts, peln, a2, fac)
3444  integer, intent(in):: is, ie, js, je, km, ng
3445  integer, intent(in):: kd
3446  real, intent(in):: wz(is:ie,js:je,km+1)
3447  real, intent(in):: ts(is-ng:ie+ng,js-ng:je+ng)
3448  real, intent(in):: peln(is:ie,km+1,js:je)
3449  real, intent(in):: height(kd)
3450  real, intent(out):: a2(is:ie,js:je,kd)
3451  real, optional, intent(in):: fac
3452 
3453 ! local:
3454  integer n, i,j,k
3455  real ptmp, tm
3456 
3457 
3458  do n=1,kd
3459 
3460 !$OMP parallel do default(none) shared(is,ie,js,je,n,height,wz,km,peln,a2,ginv,ts,fac) &
3461 !$OMP private(ptmp, tm)
3462  do j=js,je
3463 
3464  do 1000 i=is,ie
3465 
3466  if ( height(n) >= wz(i,j,km+1) ) then
3467 !---------------------
3468 ! Search from top down
3469 !---------------------
3470  do k=1,km
3471  if( height(n) < wz(i,j,k) .and. height(n) >= wz(i,j,k+1) ) then
3472 ! Found it!
3473  ptmp = peln(i,k,j) + (peln(i,k+1,j)-peln(i,k,j)) * &
3474  (wz(i,j,k)-height(n)) / (wz(i,j,k)-wz(i,j,k+1))
3475  a2(i,j,n) = exp(ptmp)
3476  go to 500
3477  endif
3478  enddo
3479 
3480  else
3481 !-----------------------------------------
3482 ! xtrapolation: mean laspe rate 6.5 deg/km
3483 !-----------------------------------------
3484  tm = rdgas*ginv*(ts(i,j) + 3.25e-3*(wz(i,j,km)-height(n)))
3485  a2(i,j,n) = exp( peln(i,km+1,j) + (wz(i,j,km+1) - height(n))/tm )
3486  endif
3487 500 if ( present(fac) ) a2(i,j,n) = fac * a2(i,j,n)
3488 1000 continue
3489  enddo
3490  enddo
3491 
3492  end subroutine get_pressure_given_height
3493 
3494 
3495  subroutine get_height_given_pressure(is, ie, js, je, km, wz, kd, id, log_p, peln, a2)
3496  integer, intent(in):: is, ie, js, je, km
3497  integer, intent(in):: kd
3498  integer, intent(in):: id(kd)
3499  real, intent(in):: log_p(kd)
3501  real, intent(in):: wz(is:ie,js:je,km+1)
3502  real, intent(in):: peln(is:ie,km+1,js:je)
3503  real, intent(out):: a2(is:ie,js:je,kd)
3504 ! local:
3505  real, dimension(2*km+1):: pn, gz
3506  integer n,i,j,k, k1, k2, l
3507 
3508  k2 = max(12, km/2+1)
3509 
3510 !$OMP parallel do default(none) shared(k2,is,ie,js,je,km,kd,id,log_p,peln,a2,wz) &
3511 !$OMP private(i,j,n,k,k1,l,pn,gz)
3512  do j=js,je
3513  do i=is,ie
3514 !---------------
3515 ! Mirror method:
3516 !---------------
3517  do k=1,km+1
3518  pn(k) = peln(i,k,j)
3519  gz(k) = wz(i,j,k)
3520  enddo
3521  do k=km+2, km+k2
3522  l = 2*(km+1) - k
3523  gz(k) = 2.*gz(km+1) - gz(l)
3524  pn(k) = 2.*pn(km+1) - pn(l)
3525  enddo
3526  k1 = 1
3527  do 1000 n=1,kd
3528  if( id(n)<0 ) goto 1000
3529  do k=k1,km+k2-1
3530  if( log_p(n) <= pn(k+1) .and. log_p(n) >= pn(k) ) then
3531  a2(i,j,n) = gz(k) + (gz(k+1)-gz(k))*(log_p(n)-pn(k))/(pn(k+1)-pn(k))
3532  k1 = k
3533  go to 1000
3534  endif
3535  enddo
3536 1000 continue
3537  enddo
3538  enddo
3539 
3540  end subroutine get_height_given_pressure
3541 
3542  subroutine prt_height(qname, is, ie, js, je, ng, km, press, phis, delz, peln, area, lat)
3543  character(len=*), intent(in):: qname
3544  integer, intent(in):: is, ie, js, je, ng, km
3545  real, intent(in):: press
3546  real, intent(in):: peln(is:ie,km+1,js:je)
3547  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
3548  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
3549  real(kind=R_GRID), intent(in), dimension(is:ie, js:je):: area, lat
3550 ! local:
3551  real:: a2(is:ie,js:je)
3552  real(kind=R_GRID), dimension(2*km+1):: pn, gz
3553  real(kind=R_GRID):: log_p
3554  integer i,j,k, k2, l
3555 
3556  log_p = log(press)
3557  k2 = max(12, km/2+1)
3558 
3559 !$OMP parallel do default(none) shared(k2,is,ie,js,je,km,log_p,peln,phis,delz,a2) &
3560 !$OMP private(i,j,k,l,pn,gz)
3561  do j=js,je
3562  do 1000 i=is,ie
3563 !---------------
3564 ! Mirror method:
3565 !---------------
3566  do k=1,km+1
3567  pn(k) = peln(i,k,j)
3568  enddo
3569  gz(km+1) = phis(i,j)/grav
3570  do k=km,1,-1
3571  gz(k) = gz(k+1) - delz(i,j,k)
3572  enddo
3573  do k=km+2, km+k2
3574  l = 2*(km+1) - k
3575  gz(k) = 2.*gz(km+1) - gz(l)
3576  pn(k) = 2.*pn(km+1) - pn(l)
3577  enddo
3578 
3579  do k=1,km+k2-1
3580  if( log_p <= pn(k+1) .and. log_p >= pn(k) ) then
3581  a2(i,j) = gz(k) + (gz(k+1)-gz(k))*(log_p-pn(k))/(pn(k+1)-pn(k))
3582  go to 1000
3583  endif
3584  enddo
3585 1000 continue
3586  enddo
3587  call prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat)
3588 
3589  end subroutine prt_height
3590 
3591  subroutine prt_gb_nh_sh(qname, is,ie, js,je, a2, area, lat)
3592  character(len=*), intent(in):: qname
3593  integer, intent(in):: is, ie, js, je
3594  real, intent(in), dimension(is:ie, js:je):: a2
3595  real(kind=R_GRID), intent(in), dimension(is:ie, js:je):: area, lat
3596 ! Local:
3597  real(R_GRID), parameter:: rad2deg = 180./pi
3598  real(R_GRID):: slat
3599  real:: t_eq, t_nh, t_sh, t_gb
3600  real:: area_eq, area_nh, area_sh, area_gb
3601  integer:: i,j
3602 
3603  t_eq = 0. ; t_nh = 0.; t_sh = 0.; t_gb = 0.
3604  area_eq = 0.; area_nh = 0.; area_sh = 0.; area_gb = 0.
3605  do j=js,je
3606  do i=is,ie
3607  slat = lat(i,j)*rad2deg
3608  area_gb = area_gb + area(i,j)
3609  t_gb = t_gb + a2(i,j)*area(i,j)
3610  if( (slat>-20. .and. slat<20.) ) then
3611  area_eq = area_eq + area(i,j)
3612  t_eq = t_eq + a2(i,j)*area(i,j)
3613  elseif( slat>=20. .and. slat<80. ) then
3614  area_nh = area_nh + area(i,j)
3615  t_nh = t_nh + a2(i,j)*area(i,j)
3616  elseif( slat<=-20. .and. slat>-80. ) then
3617  area_sh = area_sh + area(i,j)
3618  t_sh = t_sh + a2(i,j)*area(i,j)
3619  endif
3620  enddo
3621  enddo
3622  call mp_reduce_sum(area_gb)
3623  call mp_reduce_sum( t_gb)
3624  call mp_reduce_sum(area_nh)
3625  call mp_reduce_sum( t_nh)
3626  call mp_reduce_sum(area_sh)
3627  call mp_reduce_sum( t_sh)
3628  call mp_reduce_sum(area_eq)
3629  call mp_reduce_sum( t_eq)
3630  !Bugfix for non-global domains
3631  if (area_gb <= 1.) area_gb = -1.0
3632  if (area_nh <= 1.) area_nh = -1.0
3633  if (area_sh <= 1.) area_sh = -1.0
3634  if (area_eq <= 1.) area_eq = -1.0
3635  if (is_master()) write(*,*) qname, t_gb/area_gb, t_nh/area_nh, t_sh/area_sh, t_eq/area_eq
3636 
3637  end subroutine prt_gb_nh_sh
3638 
3639  subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout, iv)
3640 ! iv =-1: winds
3641 ! iv = 0: positive definite scalars
3642 ! iv = 1: temperature
3643  integer, intent(in):: is, ie, js, je, km, iv
3644  integer, intent(in):: kd
3645  integer, intent(in):: id(kd)
3646  real, intent(in):: pout(kd) ! must be monotonically increasing with increasing k
3647  real, intent(in):: pe(is:ie,km+1,js:je)
3648  real, intent(in):: qin(is:ie,js:je,km)
3649  real, intent(in):: wz(is:ie,js:je,km+1)
3650  real, intent(out):: qout(is:ie,js:je,kd)
3651 ! local:
3652  real, parameter:: gcp = grav / cp_air
3653  real:: qe(is:ie,km+1)
3654  real, dimension(is:ie,km):: q2, dp
3655  real:: s0, a6
3656  integer:: i,j,k, n, k1
3657 
3658 !$OMP parallel do default(none) shared(iv,id,is,ie,js,je,km,kd,pout,qin,qout,pe,wz) &
3659 !$OMP private(k1,s0,a6,q2,dp,qe)
3660  do j=js,je
3661 
3662  do i=is,ie
3663  do k=1,km
3664  dp(i,k) = pe(i,k+1,j) - pe(i,k,j)
3665  q2(i,k) = qin(i,j,k)
3666  enddo
3667  enddo
3668 
3669  call cs_prof(q2, dp, qe, km, is, ie, iv)
3670 
3671  do i=is,ie
3672  k1 = 1
3673  do n=1,kd
3674  if ( id(n) > 0 ) then
3675  if( pout(n) <= pe(i,1,j) ) then
3676 ! Higher than the top:
3677  qout(i,j,n) = qe(i,1)
3678  elseif ( pout(n) >= pe(i,km+1,j) ) then
3679 ! lower than the bottom surface:
3680  if ( iv==1 ) then ! Temperature
3681 ! lower than the bottom surface:
3682 ! mean (hydro) potential temp based on lowest 2-3 layers (NCEP method)
3683 ! temp = ptm * p**cappa = ptm * exp(cappa*log(pout))
3684  qout(i,j,n) = gcp*exp(kappa*pout(n)) * (wz(i,j,km-2) - wz(i,j,km)) / &
3685  ( exp(kappa*pe(i,km,j)) - exp(kappa*pe(i,km-2,j)) )
3686  else
3687  qout(i,j,n) = qe(i,km+1)
3688  endif
3689  else
3690  do k=k1,km
3691  if ( pout(n)>=pe(i,k,j) .and. pout(n) <= pe(i,k+1,j) ) then
3692 ! PPM distribution: f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
3693  a6 = 3.*(2.*q2(i,k) - (qe(i,k)+qe(i,k+1)))
3694  s0 = (pout(n)-pe(i,k,j)) / dp(i,k)
3695  qout(i,j,n) = qe(i,k) + s0*(qe(i,k+1)-qe(i,k)+a6*(1.-s0))
3696  k1 = k ! next level
3697  go to 500
3698  endif
3699  enddo
3700  endif
3701 500 if ( iv==0 ) qout(i,j,n) = max(0., qout(i,j,n))
3702  endif
3703  enddo
3704  enddo
3705  enddo
3706 
3707 ! Send_data here
3708 
3709  end subroutine cs3_interpolator
3710 
3711  subroutine cs_interpolator(is, ie, js, je, km, qin, zout, wz, qout, qmin)
3712  integer, intent(in):: is, ie, js, je, km
3713  real, intent(in):: zout, qmin
3714  real, intent(in):: qin(is:ie,js:je,km)
3715  real, intent(in):: wz(is:ie,js:je,km+1)
3716  real, intent(out):: qout(is:ie,js:je)
3717 ! local:
3718  real:: qe(is:ie,km+1)
3719  real, dimension(is:ie,km):: q2, dz
3720  real:: s0, a6
3721  integer:: i,j,k
3722 
3723 !$OMP parallel do default(none) shared(qmin,is,ie,js,je,km,zout,qin,qout,wz) &
3724 !$OMP private(s0,a6,q2,dz,qe)
3725  do j=js,je
3726 
3727  do i=is,ie
3728  do k=1,km
3729  dz(i,k) = wz(i,j,k) - wz(i,j,k+1)
3730  q2(i,k) = qin(i,j,k)
3731  enddo
3732  enddo
3733 
3734  call cs_prof(q2, dz, qe, km, is, ie, 1)
3735 
3736  do i=is,ie
3737  if( zout >= wz(i,j,1) ) then
3738 ! Higher than the top:
3739  qout(i,j) = qe(i,1)
3740  elseif ( zout <= wz(i,j,km+1) ) then
3741  qout(i,j) = qe(i,km+1)
3742  else
3743  do k=1,km
3744  if ( zout<=wz(i,j,k) .and. zout >= wz(i,j,k+1) ) then
3745 ! PPM distribution: f(s) = AL + s*[(AR-AL) + A6*(1-s)] ( 0 <= s <= 1 )
3746  a6 = 3.*(2.*q2(i,k) - (qe(i,k)+qe(i,k+1)))
3747  s0 = (wz(i,j,k)-zout) / dz(i,k)
3748  qout(i,j) = qe(i,k) + s0*(qe(i,k+1)-qe(i,k)+a6*(1.-s0))
3749  go to 500
3750  endif
3751  enddo
3752  endif
3753 500 qout(i,j) = max(qmin, qout(i,j))
3754  enddo
3755  enddo
3756 
3757 ! Send_data here
3758 
3759  end subroutine cs_interpolator
3760 
3761  subroutine cs_prof(q2, delp, q, km, i1, i2, iv)
3762 ! Latest: Dec 2015 S.-J. Lin, NOAA/GFDL
3763  integer, intent(in):: i1, i2, km
3764  integer, intent(in):: iv
3765  real, intent(in) :: q2(i1:i2,km)
3766  real, intent(in) :: delp(i1:i2,km) ! <layer pressure thickness
3767  real, intent(out):: q(i1:i2,km+1)
3768 !-----------------------------------------------------------------------
3769  real gam(i1:i2,km)
3770  real d4(i1:i2)
3771  real bet, a_bot, grat
3772  integer i, k
3773 
3774  do i=i1,i2
3775  grat = delp(i,2) / delp(i,1) ! grid ratio
3776  bet = grat*(grat+0.5)
3777  q(i,1) = ( (grat+grat)*(grat+1.)*q2(i,1) + q2(i,2) ) / bet
3778  gam(i,1) = ( 1. + grat*(grat+1.5) ) / bet
3779  enddo
3780 
3781  do k=2,km
3782  do i=i1,i2
3783  d4(i) = delp(i,k-1) / delp(i,k)
3784  bet = 2. + d4(i) + d4(i) - gam(i,k-1)
3785  q(i,k) = ( 3.*(q2(i,k-1)+d4(i)*q2(i,k)) - q(i,k-1) )/bet
3786  gam(i,k) = d4(i) / bet
3787  enddo
3788  enddo
3789 
3790  do i=i1,i2
3791  a_bot = 1. + d4(i)*(d4(i)+1.5)
3792  q(i,km+1) = (2.*d4(i)*(d4(i)+1.)*q2(i,km)+q2(i,km-1)-a_bot*q(i,km)) &
3793  / ( d4(i)*(d4(i)+0.5) - a_bot*gam(i,km) )
3794  enddo
3795 
3796  do k=km,1,-1
3797  do i=i1,i2
3798  q(i,k) = q(i,k) - gam(i,k)*q(i,k+1)
3799  enddo
3800  enddo
3801 
3802 ! Apply *large-scale* constraints
3803  do i=i1,i2
3804  q(i,2) = min( q(i,2), max(q2(i,1), q2(i,2)) )
3805  q(i,2) = max( q(i,2), min(q2(i,1), q2(i,2)) )
3806  enddo
3807 
3808  do k=2,km
3809  do i=i1,i2
3810  gam(i,k) = q2(i,k) - q2(i,k-1)
3811  enddo
3812  enddo
3813 
3814 ! Interior:
3815  do k=3,km-1
3816  do i=i1,i2
3817  if ( gam(i,k-1)*gam(i,k+1)>0. ) then
3818 ! Apply large-scale constraint to ALL fields if not local max/min
3819  q(i,k) = min( q(i,k), max(q2(i,k-1),q2(i,k)) )
3820  q(i,k) = max( q(i,k), min(q2(i,k-1),q2(i,k)) )
3821  else
3822  if ( gam(i,k-1) > 0. ) then
3823 ! There exists a local max
3824  q(i,k) = max(q(i,k), min(q2(i,k-1),q2(i,k)))
3825  else
3826 ! There exists a local min
3827  q(i,k) = min(q(i,k), max(q2(i,k-1),q2(i,k)))
3828  if ( iv==0 ) q(i,k) = max(0., q(i,k))
3829  endif
3830  endif
3831  enddo
3832  enddo
3833 
3834 ! Bottom:
3835  do i=i1,i2
3836  q(i,km) = min( q(i,km), max(q2(i,km-1), q2(i,km)) )
3837  q(i,km) = max( q(i,km), min(q2(i,km-1), q2(i,km)) )
3838  enddo
3839 
3840  end subroutine cs_prof
3841 
3842 
3843  subroutine interpolate_vertical(is, ie, js, je, km, plev, peln, a3, a2)
3845  integer, intent(in):: is, ie, js, je, km
3846  real, intent(in):: peln(is:ie,km+1,js:je)
3847  real, intent(in):: a3(is:ie,js:je,km)
3848  real, intent(in):: plev
3849  real, intent(out):: a2(is:ie,js:je)
3850 ! local:
3851  real pm(km)
3852  real logp
3853  integer i,j,k
3854 
3855  logp = log(plev)
3856 
3857 !$OMP parallel do default(none) shared(is,ie,js,je,km,peln,logp,a2,a3) &
3858 !$OMP private(pm)
3859  do j=js,je
3860  do 1000 i=is,ie
3861 
3862  do k=1,km
3863  pm(k) = 0.5*(peln(i,k,j)+peln(i,k+1,j))
3864  enddo
3865 
3866  if( logp <= pm(1) ) then
3867  a2(i,j) = a3(i,j,1)
3868  elseif ( logp >= pm(km) ) then
3869  a2(i,j) = a3(i,j,km)
3870  else
3871  do k=1,km-1
3872  if( logp <= pm(k+1) .and. logp >= pm(k) ) then
3873  a2(i,j) = a3(i,j,k) + (a3(i,j,k+1)-a3(i,j,k))*(logp-pm(k))/(pm(k+1)-pm(k))
3874  go to 1000
3875  endif
3876  enddo
3877  endif
3878 1000 continue
3879  enddo
3880 
3881  end subroutine interpolate_vertical
3882 
3883 
3884  subroutine interpolate_z(is, ie, js, je, km, zl, hght, a3, a2)
3886  integer, intent(in):: is, ie, js, je, km
3887  real, intent(in):: hght(is:ie,js:je,km+1)
3888  real, intent(in):: a3(is:ie,js:je,km)
3889  real, intent(in):: zl
3890  real, intent(out):: a2(is:ie,js:je)
3891 ! local:
3892  real zm(km)
3893  integer i,j,k
3894 
3895 
3896 !$OMP parallel do default(none) shared(is,ie,js,je,km,hght,zl,a2,a3) private(zm)
3897  do j=js,je
3898  do 1000 i=is,ie
3899  do k=1,km
3900  zm(k) = 0.5*(hght(i,j,k)+hght(i,j,k+1))
3901  enddo
3902  if( zl >= zm(1) ) then
3903  a2(i,j) = a3(i,j,1)
3904  elseif ( zl <= zm(km) ) then
3905  a2(i,j) = a3(i,j,km)
3906  else
3907  do k=1,km-1
3908  if( zl <= zm(k) .and. zl >= zm(k+1) ) then
3909  a2(i,j) = a3(i,j,k) + (a3(i,j,k+1)-a3(i,j,k))*(zm(k)-zl)/(zm(k)-zm(k+1))
3910  go to 1000
3911  endif
3912  enddo
3913  endif
3914 1000 continue
3915  enddo
3916 
3917  end subroutine interpolate_z
3918 
3919  subroutine helicity_relative(is, ie, js, je, ng, km, zvir, sphum, srh, &
3920  ua, va, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
3921 ! !INPUT PARAMETERS:
3922  integer, intent(in):: is, ie, js, je, ng, km, sphum
3923  real, intent(in):: grav, zvir, z_bot, z_top
3924  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, ua, va
3925  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
3926  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
3927  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
3928  real, intent(in):: peln(is:ie,km+1,js:je)
3929  logical, intent(in):: hydrostatic
3930  real, intent(out):: srh(is:ie,js:je) ! unit: (m/s)**2
3931 ! real, parameter:: z_crit = 3.e3 ! lowest 3-km
3932 !---------------------------------------------------------------------------------
3933 ! SRH = 150-299 ... supercells possible with weak tornadoes
3934 ! SRH = 300-449 ... very favourable to supercells development and strong tornadoes
3935 ! SRH > 450 ... violent tornadoes
3936 !---------------------------------------------------------------------------------
3937 ! if z_top = 1E3, the threshold for supercells is 100 (m/s)**2
3938 ! Coded by S.-J. Lin for CONUS regional climate simulations
3939 !
3940  real:: rdg
3941  real, dimension(is:ie):: zh, uc, vc, dz, zh0
3942  integer i, j, k, k0, k1
3943  logical below(is:ie)
3944 
3945  rdg = rdgas / grav
3946 
3947 !$OMP parallel do default(none) shared(is,ie,js,je,km,hydrostatic,rdg,pt,zvir,sphum, &
3948 #ifdef MULTI_GASES
3949 !$OMP num_gas, &
3950 #endif
3951 !$OMP peln,delz,ua,va,srh,z_bot,z_top) &
3952 !$OMP private(zh,uc,vc,dz,k0,k1,zh0,below)
3953  do j=js,je
3954 
3955  do i=is,ie
3956  uc(i) = 0.
3957  vc(i) = 0.
3958  zh(i) = 0.
3959  srh(i,j) = 0.
3960  below(i) = .true.
3961  zh0(i) = 0.
3962 
3963 ! if ( phis(i,j)/grav < 1.E3 ) then
3964  do k=km,1,-1
3965  if ( hydrostatic ) then
3966 #ifdef MULTI_GASES
3967  dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j))
3968 #else
3969  dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
3970 #endif
3971  else
3972  dz(i) = - delz(i,j,k)
3973  endif
3974  zh(i) = zh(i) + dz(i)
3975  if (zh(i) <= z_bot ) continue
3976  if (zh(i) > z_bot .and. below(i)) then
3977  uc(i) = ua(i,j,k)*dz(i)
3978  vc(i) = va(i,j,k)*dz(i)
3979  zh0(i) = zh(i) - dz(i)
3980  k1 = k
3981  below(i) = .false.
3982 ! Compute mean winds below z_top
3983  elseif ( zh(i) < z_top ) then
3984  uc(i) = uc(i) + ua(i,j,k)*dz(i)
3985  vc(i) = vc(i) + va(i,j,k)*dz(i)
3986  k0 = k
3987  else
3988  uc(i) = uc(i) / (zh(i)-dz(i) - zh0(i))
3989  vc(i) = vc(i) / (zh(i)-dz(i) - zh0(i))
3990  goto 123
3991  endif
3992  enddo
3993 123 continue
3994 
3995 ! Lowest layer wind shear computed betw top edge and mid-layer
3996  k = k1
3997  srh(i,j) = 0.5*(va(i,j,k1)-vc(i))*(ua(i,j,k1-1)-ua(i,j,k1)) - &
3998  0.5*(ua(i,j,k1)-uc(i))*(va(i,j,k1-1)-va(i,j,k1))
3999  do k=k0, k1-1
4000  srh(i,j) = srh(i,j) + 0.5*(va(i,j,k)-vc(i))*(ua(i,j,k-1)-ua(i,j,k+1)) - &
4001  0.5*(ua(i,j,k)-uc(i))*(va(i,j,k-1)-va(i,j,k+1))
4002  enddo
4003 ! endif
4004  enddo ! i-loop
4005  enddo ! j-loop
4006 
4007  end subroutine helicity_relative
4008 
4009  subroutine helicity_relative_caps(is, ie, js, je, ng, km, zvir, sphum, srh, uc, vc, &
4010  ua, va, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
4011 ! !INPUT PARAMETERS:
4012  integer, intent(in):: is, ie, js, je, ng, km, sphum
4013  real, intent(in):: grav, zvir, z_bot, z_top
4014  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, ua, va
4015  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
4016  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
4017  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
4018  real, intent(in):: peln(is:ie,km+1,js:je)
4019  real, intent(in):: uc(is:ie,js:je), vc(is:ie,js:je)
4020  logical, intent(in):: hydrostatic
4021  real, intent(out):: srh(is:ie,js:je) ! unit: (m/s)**2
4022 !---------------------------------------------------------------------------------
4023 ! SRH = 150-299 ... supercells possible with weak tornadoes
4024 ! SRH = 300-449 ... very favourable to supercells development and strong tornadoes
4025 ! SRH > 450 ... violent tornadoes
4026 !---------------------------------------------------------------------------------
4027 ! if z_crit = 1E3, the threshold for supercells is 100 (m/s)**2
4028 ! Coded by S.-J. Lin for CONUS regional climate simulations
4029 !
4030  real:: rdg
4031  real, dimension(is:ie):: zh, dz, zh0
4032  integer i, j, k, k0, k1, n
4033  logical below
4034 
4035  rdg = rdgas / grav
4036 
4037 !$OMP parallel do default(none) shared(is,ie,js,je,km,hydrostatic,rdg,pt,zvir,sphum, &
4038 #ifdef MULTI_GASES
4039 !$OMP num_gas, &
4040 #endif
4041 !$OMP peln,delz,ua,va,srh,uc,vc,z_bot,z_top) &
4042 !$OMP private(zh,dz,k0,k1,zh0,below)
4043  do j=js,je
4044 
4045  do i=is,ie
4046  srh(i,j) = 0.
4047  zh(i) = 0.
4048  zh0 = 0.
4049  below = .true.
4050 
4051  k_loop:do k=km,1,-1
4052  if ( hydrostatic ) then
4053 #ifdef MULTI_GASES
4054  dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j))
4055 #else
4056  dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
4057 #endif
4058  else
4059  dz(i) = -delz(i,j,k)
4060  endif
4061 
4062  zh(i) = zh(i) + dz(i)
4063  if (zh(i) <= z_bot ) continue
4064  if (zh(i) > z_bot .and. below) then
4065  zh0(i) = zh(i) - dz(i)
4066  k1 = k
4067  below = .false.
4068 ! Compute mean winds below z_top
4069  elseif ( zh(i) < z_top ) then
4070  k0 = k
4071  else
4072  EXIT k_loop
4073  endif
4074 
4075  enddo k_loop
4076 
4077 ! Lowest layer wind shear computed betw top edge and mid-layer
4078  k = k1
4079  srh(i,j) = 0.5*(va(i,j,k1)-vc(i,j))*(ua(i,j,k1-1)-ua(i,j,k1)) - &
4080  0.5*(ua(i,j,k1)-uc(i,j))*(va(i,j,k1-1)-va(i,j,k1))
4081  do k=k0, k1-1
4082  srh(i,j) = srh(i,j) + 0.5*(va(i,j,k)-vc(i,j))*(ua(i,j,k-1)-ua(i,j,k+1)) - &
4083  0.5*(ua(i,j,k)-uc(i,j))*(va(i,j,k-1)-va(i,j,k+1))
4084  enddo
4085  enddo ! i-loop
4086  enddo ! j-loop
4087 
4088  end subroutine helicity_relative_caps
4089 
4090 
4091  subroutine bunkers_vector(is, ie, js, je, ng, km, zvir, sphum, uc, vc, &
4092  ua, va, delz, q, hydrostatic, pt, peln, phis, grav)
4094  integer, intent(in):: is, ie, js, je, ng, km, sphum
4095  real, intent(in):: grav, zvir
4096  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, ua, va
4097  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
4098  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
4099  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
4100  real, intent(in):: peln(is:ie,km+1,js:je)
4101  logical, intent(in):: hydrostatic
4102  real, intent(out):: uc(is:ie,js:je), vc(is:ie,js:je)
4103 
4104  real:: rdg
4105  real :: zh, dz, usfc, vsfc, u6km, v6km, umn, vmn
4106  real :: ushr, vshr, shrmag
4107  integer i, j, k, n
4108  real, parameter :: bunkers_d = 7.5 ! Empirically derived parameter
4109  logical :: has_sfc, has_6km
4110 
4111  rdg = rdgas / grav
4112 
4113 !$OMP parallel do default(none) shared(is,ie,js,je,ng,km,hydrostatic,rdg,pt,zvir,sphum, &
4114 #ifdef MULTI_GASES
4115 !$OMP num_gas, &
4116 #endif
4117 !$OMP peln,delz,ua,va,uc,vc) &
4118 !$OMP private(zh,dz,usfc,vsfc,u6km,v6km,umn,vmn, &
4119 !$OMP ushr,vshr,shrmag)
4120  do j=js,je
4121  do i=is,ie
4122  zh = 0.
4123  usfc = 0.
4124  vsfc = 0.
4125  u6km = 0.
4126  v6km = 0.
4127  umn = 0.
4128  vmn = 0.
4129 
4130  usfc = ua(i,j,km)
4131  vsfc = va(i,j,km)
4132 
4133  k_loop:do k=km,1,-1
4134  if ( hydrostatic ) then
4135 #ifdef MULTI_GASES
4136  dz = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j))
4137 #else
4138  dz = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
4139 #endif
4140  else
4141  dz = -delz(i,j,k)
4142  endif
4143  zh = zh + dz
4144 
4145  if (zh < 6000) then
4146  u6km = ua(i,j,k)
4147  v6km = va(i,j,k)
4148 
4149  umn = umn + ua(i,j,k)*dz
4150  vmn = vmn + va(i,j,k)*dz
4151  else
4152  EXIT k_loop
4153  endif
4154 
4155  enddo k_loop
4156 
4157  u6km = u6km + (ua(i,j,k) - u6km) / dz * (6000. - (zh - dz))
4158  v6km = v6km + (va(i,j,k) - v6km) / dz * (6000. - (zh - dz))
4159 
4160  umn = umn / (zh - dz)
4161  vmn = vmn / (zh - dz)
4162 
4163  ushr = u6km - usfc
4164  vshr = v6km - vsfc
4165  shrmag = sqrt(ushr * ushr + vshr * vshr)
4166  uc(i,j) = umn + bunkers_d * vshr / shrmag
4167  vc(i,j) = vmn - bunkers_d * ushr / shrmag
4168 
4169  enddo ! i-loop
4170  enddo ! j-loop
4171 
4172  end subroutine bunkers_vector
4173 
4174 
4175  subroutine updraft_helicity(is, ie, js, je, ng, km, zvir, sphum, uh, &
4176  w, vort, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
4177 ! !INPUT PARAMETERS:
4178  integer, intent(in):: is, ie, js, je, ng, km, sphum
4179  real, intent(in):: grav, zvir, z_bot, z_top
4180  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, w
4181  real, intent(in), dimension(is:ie,js:je,km):: vort
4182  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
4183  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
4184  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
4185  real, intent(in):: peln(is:ie,km+1,js:je)
4186  logical, intent(in):: hydrostatic
4187  real, intent(out):: uh(is:ie,js:je) ! unit: (m/s)**2
4188 ! Coded by S.-J. Lin for CONUS regional climate simulations
4189 ! Modified for UH by LMH
4190 !
4191  real:: rdg
4192  real, dimension(is:ie):: zh, dz, zh0
4193  integer i, j, k, n
4194  logical below(is:ie)
4195 
4196  rdg = rdgas / grav
4197 
4198 !$OMP parallel do default(none) shared(is,ie,js,je,ng,km,hydrostatic,rdg,pt,zvir,sphum, &
4199 #ifdef MULTI_GASES
4200 !$OMP num_gas, &
4201 #endif
4202 !$OMP peln,delz,w,vort,uh,z_bot,z_top) &
4203 !$OMP private(zh,dz,zh0,below)
4204  do j=js,je
4205 
4206  do i=is,ie
4207  zh(i) = 0.
4208  uh(i,j) = 0.
4209  below(i) = .true.
4210  zh0(i) = 0.
4211 
4212 ! if ( phis(i,j)/grav < 1.E3 ) then
4213  do k=km,1,-1
4214  if ( hydrostatic ) then
4215 #ifdef MULTI_GASES
4216  dz(i) = rdg*pt(i,j,k)*virq(q(i,j,k,1:num_gas))*(peln(i,k+1,j)-peln(i,k,j))
4217 #else
4218  dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
4219 #endif
4220  else
4221  dz(i) = - delz(i,j,k)
4222  endif
4223  zh(i) = zh(i) + dz(i)
4224  if (zh(i) <= z_bot ) continue
4225  if (zh(i) > z_bot .and. below(i)) then
4226  uh(i,j) = vort(i,j,k)*w(i,j,k)*(zh(i) - z_bot)
4227  below(i) = .false.
4228 ! Compute mean winds below z_top
4229  elseif ( zh(i) < z_top ) then
4230  uh(i,j) = uh(i,j) + vort(i,j,k)*w(i,j,k)*dz(i)
4231  else
4232  uh(i,j) = uh(i,j) + vort(i,j,k)*w(i,j,k)*(z_top - (zh(i)-dz(i)) )
4233  goto 123
4234  endif
4235  enddo
4236 123 continue
4237 
4238  enddo ! i-loop
4239  enddo ! j-loop
4240 
4241  end subroutine updraft_helicity
4242 
4245  subroutine pv_entropy(is, ie, js, je, ng, km, vort, f_d, pt, pkz, delp, grav)
4247 ! !INPUT PARAMETERS:
4248  integer, intent(in):: is, ie, js, je, ng, km
4249  real, intent(in):: grav
4250  real, intent(in):: pt(is-ng:ie+ng,js-ng:je+ng,km)
4251  real, intent(in):: pkz(is:ie,js:je,km)
4252  real, intent(in):: delp(is-ng:ie+ng,js-ng:je+ng,km)
4253  real, intent(in):: f_d(is-ng:ie+ng,js-ng:je+ng)
4254 
4255 ! vort is relative vorticity as input. Becomes PV on output
4256  real, intent(inout):: vort(is:ie,js:je,km)
4257 
4258 ! !DESCRIPTION:
4259 ! EPV = 1/r * (vort+f_d) * d(S)/dz; where S is a conservative scalar
4260 ! r the fluid density, and S is chosen to be the entropy here: S = log(pt)
4261 ! pt == potential temperature.
4262 ! Computation are performed assuming the input is on "x-y-z" Cartesian coordinate.
4263 ! The approximation made here is that the relative vorticity computed on constant
4264 ! z-surface is not that different from the hybrid sigma-p coordinate.
4265 ! See page 39, Pedlosky 1979: Geophysical Fluid Dynamics
4266 !
4267 ! The follwoing simplified form is strictly correct only if vort is computed on
4268 ! constant z surfaces. In addition hydrostatic approximation is made.
4269 ! EPV = - GRAV * (vort+f_d) / del(p) * del(pt) / pt
4270 ! where del() is the vertical difference operator.
4271 !
4272 ! programmer: S.-J. Lin, shian-jiann.lin@noaa.gov
4273 !
4274 !EOP
4275 !---------------------------------------------------------------------
4276 !BOC
4277  real w3d(is:ie,js:je,km)
4278  real te(is:ie,js:je,km+1), t2(is:ie,km), delp2(is:ie,km)
4279  real te2(is:ie,km+1)
4280  integer i, j, k
4281 
4282 #ifdef SW_DYNAMICS
4283 !$OMP parallel do default(none) shared(is,ie,js,je,vort,grav,f_d,delp)
4284  do j=js,je
4285  do i=is,ie
4286  vort(i,j,1) = grav * (vort(i,j,1)+f_d(i,j)) / delp(i,j,1)
4287  enddo
4288  enddo
4289 #else
4290 ! Compute PT at layer edges.
4291 !$OMP parallel do default(none) shared(is,ie,js,je,km,pt,pkz,w3d,delp,te2,te) &
4292 !$OMP private(t2, delp2)
4293  do j=js,je
4294  do k=1,km
4295  do i=is,ie
4296  t2(i,k) = pt(i,j,k) / pkz(i,j,k)
4297  w3d(i,j,k) = t2(i,k)
4298  delp2(i,k) = delp(i,j,k)
4299  enddo
4300  enddo
4301 
4302  call ppme(t2, te2, delp2, ie-is+1, km)
4303 
4304  do k=1,km+1
4305  do i=is,ie
4306  te(i,j,k) = te2(i,k)
4307  enddo
4308  enddo
4309  enddo
4310 
4311 !$OMP parallel do default(none) shared(is,ie,js,je,km,vort,f_d,te,w3d,delp,grav)
4312  do k=1,km
4313  do j=js,je
4314  do i=is,ie
4315 ! Entropy is the thermodynamic variable in the following form
4316  vort(i,j,k) = (vort(i,j,k)+f_d(i,j)) * ( te(i,j,k)-te(i,j,k+1) ) &
4317  / ( w3d(i,j,k)*delp(i,j,k) ) * grav
4318  enddo
4319  enddo
4320  enddo
4321 #endif
4322 
4323  end subroutine pv_entropy
4324 
4325 
4326  subroutine ppme(p,qe,delp,im,km)
4328  integer, intent(in):: im, km
4329  real, intent(in):: p(im,km)
4330  real, intent(in):: delp(im,km)
4331  real, intent(out)::qe(im,km+1)
4332 
4333 ! local arrays.
4334  real dc(im,km),delq(im,km), a6(im,km)
4335  real c1, c2, c3, tmp, qmax, qmin
4336  real a1, a2, s1, s2, s3, s4, ss3, s32, s34, s42
4337  real a3, b2, sc, dm, d1, d2, f1, f2, f3, f4
4338  real qm, dq
4339  integer i, k, km1
4340 
4341  km1 = km - 1
4342 
4343  do 500 k=2,km
4344  do 500 i=1,im
4345 500 a6(i,k) = delp(i,k-1) + delp(i,k)
4346 
4347  do 1000 k=1,km1
4348  do 1000 i=1,im
4349  delq(i,k) = p(i,k+1) - p(i,k)
4350 1000 continue
4351 
4352  do 1220 k=2,km1
4353  do 1220 i=1,im
4354  c1 = (delp(i,k-1)+0.5*delp(i,k))/a6(i,k+1)
4355  c2 = (delp(i,k+1)+0.5*delp(i,k))/a6(i,k)
4356  tmp = delp(i,k)*(c1*delq(i,k) + c2*delq(i,k-1)) / &
4357  (a6(i,k)+delp(i,k+1))
4358  qmax = max(p(i,k-1),p(i,k),p(i,k+1)) - p(i,k)
4359  qmin = p(i,k) - min(p(i,k-1),p(i,k),p(i,k+1))
4360  dc(i,k) = sign(min(abs(tmp),qmax,qmin), tmp)
4361 1220 continue
4362 
4363 !****6***0*********0*********0*********0*********0*********0**********72
4364 ! 4th order interpolation of the provisional cell edge value
4365 !****6***0*********0*********0*********0*********0*********0**********72
4366 
4367  do k=3,km1
4368  do i=1,im
4369  c1 = delq(i,k-1)*delp(i,k-1) / a6(i,k)
4370  a1 = a6(i,k-1) / (a6(i,k) + delp(i,k-1))
4371  a2 = a6(i,k+1) / (a6(i,k) + delp(i,k))
4372  qe(i,k) = p(i,k-1) + c1 + 2./(a6(i,k-1)+a6(i,k+1)) * &
4373  ( delp(i,k)*(c1*(a1 - a2)+a2*dc(i,k-1)) - &
4374  delp(i,k-1)*a1*dc(i,k ) )
4375  enddo
4376  enddo
4377 
4378 ! three-cell parabolic subgrid distribution at model top
4379 
4380  do i=1,im
4381 ! three-cell PP-distribution
4382 ! Compute a,b, and c of q = aP**2 + bP + c using cell averages and delp
4383 ! a3 = a / 3
4384 ! b2 = b / 2
4385  s1 = delp(i,1)
4386  s2 = delp(i,2) + s1
4387 !
4388  s3 = delp(i,2) + delp(i,3)
4389  s4 = s3 + delp(i,4)
4390  ss3 = s3 + s1
4391  s32 = s3*s3
4392  s42 = s4*s4
4393  s34 = s3*s4
4394 ! model top
4395  a3 = (delq(i,2) - delq(i,1)*s3/s2) / (s3*ss3)
4396 !
4397  if(abs(a3) .gt. 1.e-14) then
4398  b2 = delq(i,1)/s2 - a3*(s1+s2)
4399  sc = -b2/(3.*a3)
4400  if(sc .lt. 0. .or. sc .gt. s1) then
4401  qe(i,1) = p(i,1) - s1*(a3*s1 + b2)
4402  else
4403  qe(i,1) = p(i,1) - delq(i,1)*s1/s2
4404  endif
4405  else
4406 ! Linear
4407  qe(i,1) = p(i,1) - delq(i,1)*s1/s2
4408  endif
4409  dc(i,1) = p(i,1) - qe(i,1)
4410 ! compute coef. for the off-centered area preserving cubic poly.
4411  dm = delp(i,1) / (s34*ss3*(delp(i,2)+s3)*(s4+delp(i,1)))
4412  f1 = delp(i,2)*s34 / ( s2*ss3*(s4+delp(i,1)) )
4413  f2 = (delp(i,2)+s3) * (ss3*(delp(i,2)*s3+s34+delp(i,2)*s4) &
4414  + s42*(delp(i,2)+s3+s32/s2))
4415  f3 = -delp(i,2)*( ss3*(s32*(s3+s4)/(s4-delp(i,2)) &
4416  + (delp(i,2)*s3+s34+delp(i,2)*s4)) &
4417  + s42*(delp(i,2)+s3) )
4418  f4 = ss3*delp(i,2)*s32*(delp(i,2)+s3) / (s4-delp(i,2))
4419  qe(i,2) = f1*p(i,1)+(f2*p(i,2)+f3*p(i,3)+f4*p(i,4))*dm
4420  enddo
4421 
4422 ! Bottom
4423 ! Area preserving cubic with 2nd deriv. = 0 at the surface
4424  do i=1,im
4425  d1 = delp(i,km)
4426  d2 = delp(i,km1)
4427  qm = (d2*p(i,km)+d1*p(i,km1)) / (d1+d2)
4428  dq = 2.*(p(i,km1)-p(i,km)) / (d1+d2)
4429  c1 = (qe(i,km1)-qm-d2*dq) / (d2*(2.*d2*d2+d1*(d2+3.*d1)))
4430  c3 = dq - 2.0*c1*(d2*(5.*d1+d2)-3.*d1**2)
4431  qe(i,km ) = qm - c1*d1*d2*(d2+3.*d1)
4432  qe(i,km+1) = d1*(8.*c1*d1**2-c3) + qe(i,km)
4433  enddo
4434 
4435  end subroutine ppme
4436 
4437 subroutine rh_calc (pfull, t, qv, rh, do_cmip)
4439  real, intent (in), dimension(:,:) :: pfull, t, qv
4440  real, intent (out), dimension(:,:) :: rh
4441  real, dimension(size(t,1),size(t,2)) :: esat
4442  logical, intent(in), optional :: do_cmip
4443 
4444  real, parameter :: d622 = rdgas/rvgas
4445  real, parameter :: d378 = 1.-d622
4446 
4447  logical :: do_simple = .false.
4448 
4449 ! because Betts-Miller uses a simplified scheme for calculating the relative humidity
4450 
4451  if (do_simple) then
4452  call lookup_es (t, esat)
4453  rh(:,:) = pfull(:,:)
4454  rh(:,:) = max(rh(:,:),esat(:,:)) !limit where pfull ~ esat
4455  rh(:,:)=100.*qv(:,:)/(d622*esat(:,:)/rh(:,:))
4456  else
4457  if (present(do_cmip)) then
4458  call compute_qs (t, pfull, rh, q=qv, es_over_liq_and_ice = .true.)
4459  rh(:,:)=100.*qv(:,:)/rh(:,:)
4460  else
4461  call compute_qs (t, pfull, rh, q=qv)
4462  rh(:,:)=100.*qv(:,:)/rh(:,:)
4463  endif
4464  endif
4465 
4466 end subroutine rh_calc
4467 
4468 #ifdef SIMPLIFIED_THETA_E
4469 
4473 #ifdef MULTI_GASES
4474 subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, qi, is, ie, js, je, ng, npz, &
4475  hydrostatic, moist)
4476 #else
4477 subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, npz, &
4478  hydrostatic, moist)
4479 #endif
4480  integer, intent(in):: is,ie,js,je,ng,npz
4481 #ifdef MULTI_GASES
4482  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz,*):: qi
4483 #endif
4484  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: pt, delp, q
4485  real, intent(in), dimension(is-ng: ,js-ng: ,1: ):: delz
4486  real, intent(in), dimension(is:ie,npz+1,js:je):: peln
4487  real, intent(in):: pkz(is:ie,js:je,npz)
4488  logical, intent(in):: hydrostatic, moist
4489 ! Output:
4490  real, dimension(is:ie,js:je,npz), intent(out) :: theta_e
4491 ! local
4492  real, parameter:: tice = 273.16
4493  real, parameter:: c_liq = 4190.
4494 #ifdef SIM_NGGPS
4495  real, parameter:: dc_vap = 0.
4496 #else
4497  real, parameter:: dc_vap = cp_vapor - c_liq
4498 #endif
4499  real(kind=R_GRID), dimension(is:ie):: pd, rq
4500  real(kind=R_GRID) :: wfac
4501  integer :: i,j,k
4502 
4503  if ( moist ) then
4504  wfac = 1.
4505  else
4506  wfac = 0.
4507  endif
4508 #ifdef MULLTI_GASES
4509  do j=js,je
4510  do i=is,ie
4511  do k=1,npz
4512  q(i,j,k) = qi(i,j,k,1)
4513  enddo
4514  enddo
4515  enddo
4516 #endif
4517 
4518 !$OMP parallel do default(none) shared(pk0,wfac,moist,pkz,is,ie,js,je,npz,pt,q,delp,peln,delz,theta_e,hydrostatic) &
4519 !$OMP private(pd, rq)
4520  do k = 1,npz
4521  do j = js,je
4522 
4523  if ( hydrostatic ) then
4524  do i=is,ie
4525  rq(i) = max(0., wfac*q(i,j,k))
4526  pd(i) = (1.-rq(i))*delp(i,j,k) / (peln(i,k+1,j) - peln(i,k,j))
4527  enddo
4528  else
4529 ! Dry pressure: p = r R T
4530  do i=is,ie
4531  rq(i) = max(0., wfac*q(i,j,k))
4532  pd(i) = -rdgas*pt(i,j,k)*(1.-rq(i))*delp(i,j,k)/(grav*delz(i,j,k))
4533  enddo
4534  endif
4535 
4536  if ( moist ) then
4537  do i=is,ie
4538  rq(i) = max(0., q(i,j,k))
4539 ! rh(i) = max(1.e-12, rq(i)/wqs1(pt(i,j,k),den(i))) ! relative humidity
4540 ! theta_e(i,j,k) = exp(rq(i)/cp_air*((hlv+dc_vap*(pt(i,j,k)-tice))/pt(i,j,k) - &
4541 ! rvgas*log(rh(i))) + kappa*log(1.e5/pd(i))) * pt(i,j,k)
4542 ! Simplified form: (ignoring the RH term)
4543 #ifdef SIM_NGGPS
4544 #ifdef MULTI_GASES
4545  theta_e(i,j,k) = pt(i,j,k)*exp(kappa * (virqd(qi(i,j,k,:))/vicpqd(qi(i,j,k,:)))*log(1.e5/pd(i))) * &
4546  exp(rq(i)*hlv/(cp_air*vicpqd(qi(i,j,k,:))*pt(i,j,k)))
4547 #else
4548  theta_e(i,j,k) = pt(i,j,k)*exp(kappa*log(1.e5/pd(i))) * &
4549  exp(rq(i)*hlv/(cp_air*pt(i,j,k)))
4550 #endif
4551 #else
4552 #ifdef MULTI_GASES
4553  theta_e(i,j,k) = pt(i,j,k)*exp( rq(i)/(cp_air*vicpqd(q(i,j,k,:))*pt(i,j,k))*(hlv+dc_vap*(pt(i,j,k)-tice)) &
4554  + rdgas*virqd(qi(i,j,k,:)) / (cp_air*vicpqd(qi(i,j,k,:)))*log(1.e5/pd(i)) )
4555 #else
4556  theta_e(i,j,k) = pt(i,j,k)*exp( rq(i)/(cp_air*pt(i,j,k))*(hlv+dc_vap*(pt(i,j,k)-tice)) &
4557  + kappa*log(1.e5/pd(i)) )
4558 #endif
4559 #endif
4560  enddo
4561  else
4562  if ( hydrostatic ) then
4563  do i=is,ie
4564  theta_e(i,j,k) = pt(i,j,k)*pk0/pkz(i,j,k)
4565  enddo
4566  else
4567  do i=is,ie
4568 ! theta_e(i,j,k) = pt(i,j,k)*(1.e5/pd(i))**kappa
4569 #ifdef MULTI_GASES
4570  theta_e(i,j,k) = pt(i,j,k)*exp( kappa * (virqd(qi(i,j,k,:))/vicpqd(qi(i,j,k,:)))*log(1.e5/pd(i)) )
4571 #else
4572  theta_e(i,j,k) = pt(i,j,k)*exp( kappa*log(1.e5/pd(i)) )
4573 #endif
4574  enddo
4575  endif
4576  endif
4577  enddo ! j-loop
4578  enddo ! k-loop
4579 
4580 end subroutine eqv_pot
4581 
4582 #else
4583 
4588 #ifdef MULTI_GASES
4589 subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, qi, is, ie, js, je, ng, npz, &
4590 #else
4591 subroutine eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, npz, &
4592 #endif
4593  hydrostatic, moist)
4594 ! Modified by SJL
4595  integer, intent(in):: is,ie,js,je,ng,npz
4596 #ifdef MULTI_GASES
4597  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz,*):: qi
4598 #else
4599  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: q
4600 #endif
4601  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: pt, delp
4602  real, intent(in), dimension(is-ng: ,js-ng: ,1: ):: delz
4603  real, intent(in), dimension(is:ie,npz+1,js:je):: peln
4604  real, intent(in):: pkz(is:ie,js:je,npz)
4605  logical, intent(in):: hydrostatic, moist
4606 ! Output:
4607  real, dimension(is:ie,js:je,npz), intent(out) :: theta_e
4608 ! local
4609 #ifdef MULTI_GASES
4610  real, dimension(is-ng:ie+ng,js-ng:je+ng,npz):: q
4611 #endif
4612  real, parameter:: cv_vap = cp_vapor - rvgas ! 1384.5
4613  real, parameter:: cappa_b = 0.2854
4614  real(kind=R_GRID):: cv_air, cappa, zvir
4615  real(kind=R_GRID):: p_mb(is:ie)
4616  real(kind=R_GRID) :: r, e, t_l, rdg, capa
4617  integer :: i,j,k, n
4618 
4619 #ifdef MULTI_GASES
4620  q(:,:,:) = qi(:,:,:,1)
4621 #endif
4622  cv_air = cp_air - rdgas
4623  rdg = -rdgas/grav
4624  if ( moist ) then
4625  zvir = rvgas/rdgas - 1.
4626  else
4627  zvir = 0.
4628  endif
4629 
4630 !$OMP parallel do default(none) shared(moist,pk0,pkz,cv_air,zvir,rdg,is,ie,js,je,ng,npz, &
4631 #ifdef MULTI_GASES
4632 !$OMP qi,num_gas, &
4633 #endif
4634 !$OMP pt,q,delp,peln,delz,theta_e,hydrostatic) &
4635 !$OMP private(cappa,p_mb, r, e, t_l, capa)
4636  do k = 1,npz
4637  cappa = cappa_b
4638  do j = js,je
4639 ! get pressure in mb
4640  if ( hydrostatic ) then
4641  do i=is,ie
4642  p_mb(i) = 0.01*delp(i,j,k) / (peln(i,k+1,j) - peln(i,k,j))
4643  enddo
4644  else
4645  do i=is,ie
4646 #ifdef MULTI_GASES
4647  p_mb(i) = 0.01*rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)*virq(qi(i,j,k,1:num_gas))
4648 #else
4649  p_mb(i) = 0.01*rdg*delp(i,j,k)/delz(i,j,k)*pt(i,j,k)*(1.+zvir*q(i,j,k))
4650 #endif
4651  enddo
4652  endif
4653  if ( moist ) then
4654  do i = is,ie
4655 #ifdef MULTI_GASES
4656  cappa = rdgas/(rdgas+((1.-q(i,j,k))*cv_air+q(i,j,k)*cv_vap)/virq(qi(i,j,k,1:num_gas)))
4657 #else
4658  cappa = rdgas/(rdgas+((1.-q(i,j,k))*cv_air+q(i,j,k)*cv_vap)/(1.+zvir*q(i,j,k)))
4659 #endif
4660 ! get "dry" mixing ratio of m_vapor/m_tot in g/kg
4661  r = q(i,j,k)/(1.-q(i,j,k))*1000.
4662  r = max(1.e-10, r)
4663 ! get water vapor pressure
4664  e = p_mb(i)*r/(622.+r)
4665 ! get temperature at the lifting condensation level
4666 ! eq. 21 of Bolton 1980
4667  t_l = 2840./(3.5*log(pt(i,j,k))-log(e)-4.805)+55.
4668 ! get the equivalent potential temperature
4669 ! theta_e(i,j,k) = pt(i,j,k)*exp( (cappa*(1.-0.28e-3*r)*log(1000./p_mb(i))) * &
4670 ! exp( (3.376/t_l-0.00254)*r*(1.+0.81e-3*r) )
4671  capa = cappa*(1. - r*0.28e-3)
4672  theta_e(i,j,k) = exp( (3.376/t_l-0.00254)*r*(1.+r*0.81e-3) )*pt(i,j,k)*(1000./p_mb(i))**capa
4673  enddo
4674  else
4675  if ( hydrostatic ) then
4676  do i = is,ie
4677  theta_e(i,j,k) = pt(i,j,k)*pk0/pkz(i,j,k)
4678  enddo
4679  else
4680  do i = is,ie
4681 #ifdef MULTI_GASES
4682  theta_e(i,j,k) = pt(i,j,k)*exp( kappa * virqd(qi(i,j,k,1:num_gas))/vicpqd(qi(i,j,k,1:num_gas)) *log(1000./p_mb(i)) )
4683 #else
4684  theta_e(i,j,k) = pt(i,j,k)*exp( kappa*log(1000./p_mb(i)) )
4685 #endif
4686  enddo
4687  endif
4688  endif
4689  enddo ! j-loop
4690  enddo ! k-loop
4691 
4692 end subroutine eqv_pot
4693 
4694 #endif
4695 
4698  subroutine nh_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, &
4699  w, delz, pt, delp, q, hs, area, domain, &
4700  sphum, liq_wat, rainwat, ice_wat, &
4701  snowwat, graupel, nwat, ua, va, moist_phys, te)
4702 ! INPUT PARAMETERS:
4703  integer, intent(in):: km, is, ie, js, je, isd, ied, jsd, jed
4704  integer, intent(in):: nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel
4705  real, intent(in), dimension(isd:ied,jsd:jed,km):: ua, va, pt, delp, w, delz
4706  real, intent(in), dimension(isd:ied,jsd:jed,km,nwat):: q
4707  real, intent(in):: hs(isd:ied,jsd:jed)
4708  real, intent(in):: area(isd:ied, jsd:jed)
4709  logical, intent(in):: moist_phys
4710  type(domain2d), intent(INOUT) :: domain
4711  real, intent(out):: te(is:ie,js:je)
4712 ! Local
4713  real, parameter:: c_liq = 4190.
4714  real(kind=R_Grid) :: area_l(isd:ied, jsd:jed)
4715  real, parameter:: cv_vap = cp_vapor - rvgas
4716  real phiz(is:ie,km+1)
4717  real, dimension(is:ie):: cvm, qc
4718  real cv_air, psm
4719  integer i, j, k
4720 
4721  area_l = area
4722  cv_air = cp_air - rdgas
4723 
4724 !$OMP parallel do default(none) shared(te,nwat,is,ie,js,je,isd,ied,jsd,jed,km,ua,va, &
4725 #ifdef MULTI_GASES
4726 !$OMP num_gas, &
4727 #endif
4728 !$OMP w,q,pt,delp,delz,hs,cv_air,moist_phys,sphum,liq_wat,rainwat,ice_wat,snowwat,graupel) &
4729 !$OMP private(phiz,cvm, qc)
4730  do j=js,je
4731 
4732  do i=is,ie
4733  te(i,j) = 0.
4734  phiz(i,km+1) = hs(i,j)
4735  enddo
4736 
4737  do i=is,ie
4738  do k=km,1,-1
4739  phiz(i,k) = phiz(i,k+1) - grav*delz(i,j,k)
4740  enddo
4741  enddo
4742 
4743  if ( moist_phys ) then
4744  do k=1,km
4745  call moist_cv(is,ie,isd,ied,jsd,jed, km, j, k, nwat, sphum, liq_wat, rainwat, &
4746  ice_wat, snowwat, graupel, q, qc, cvm)
4747  do i=is,ie
4748  te(i,j) = te(i,j) + delp(i,j,k)*( cvm(i)*pt(i,j,k) + hlv*q(i,j,k,sphum) + &
4749  0.5*(phiz(i,k)+phiz(i,k+1)+ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2) )
4750  enddo
4751  enddo
4752  else
4753  do k=1,km
4754  do i=is,ie
4755 #ifdef MULTI_GASES
4756  te(i,j) = te(i,j) + delp(i,j,k)*( cv_air*vicvqd(q(i,j,k,1:num_gas))*pt(i,j,k) + &
4757  0.5*(phiz(i,k)+phiz(i,k+1)+ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2) )
4758 #else
4759  te(i,j) = te(i,j) + delp(i,j,k)*( cv_air*pt(i,j,k) + &
4760  0.5*(phiz(i,k)+phiz(i,k+1)+ua(i,j,k)**2+va(i,j,k)**2+w(i,j,k)**2) )
4761 #endif
4762  enddo
4763  enddo
4764  endif
4765 ! Unit: kg*(m/s)^2/m^2 = Joule/m^2
4766  do i=is,ie
4767  te(i,j) = te(i,j)/grav
4768  enddo
4769  enddo
4770 
4771  psm = g_sum(domain, te, is, ie, js, je, 3, area_l, 1)
4772  if( master ) write(*,*) 'TE ( Joule/m^2 * E9) =', psm * 1.e-9
4773 
4774  end subroutine nh_total_energy
4775 
4786  subroutine dbzcalc(q, pt, delp, peln, delz, &
4787  dbz, maxdbz, allmax, bd, npz, ncnst, &
4788  hydrostatic, zvir, in0r, in0s, in0g, iliqskin)
4790 ! Code from Mark Stoelinga's dbzcalc.f from the RIP package.
4791 ! Currently just using values taken directly from that code, which is
4792 ! consistent for the MM5 Reisner-2 microphysics. From that file:
4793 
4794 ! This routine computes equivalent reflectivity factor (in dBZ) at
4795 ! each model grid point. In calculating Ze, the RIP algorithm makes
4796 ! assumptions consistent with those made in an early version
4797 ! (ca. 1996) of the bulk mixed-phase microphysical scheme in the MM5
4798 ! model (i.e., the scheme known as "Resiner-2"). For each species:
4799 !
4800 ! 1. Particles are assumed to be spheres of constant density. The
4801 ! densities of rain drops, snow particles, and graupel particles are
4802 ! taken to be rho_r = rho_l = 1000 kg m^-3, rho_s = 100 kg m^-3, and
4803 ! rho_g = 400 kg m^-3, respectively. (l refers to the density of
4804 ! liquid water.)
4805 !
4806 ! 2. The size distribution (in terms of the actual diameter of the
4807 ! particles, rather than the melted diameter or the equivalent solid
4808 ! ice sphere diameter) is assumed to follow an exponential
4809 ! distribution of the form N(D) = N_0 * exp( lambda*D ).
4810 !
4811 ! 3. If in0X=0, the intercept parameter is assumed constant (as in
4812 ! early Reisner-2), with values of 8x10^6, 2x10^7, and 4x10^6 m^-4,
4813 ! for rain, snow, and graupel, respectively. Various choices of
4814 ! in0X are available (or can be added). Currently, in0X=1 gives the
4815 ! variable intercept for each species that is consistent with
4816 ! Thompson, Rasmussen, and Manning (2004, Monthly Weather Review,
4817 ! Vol. 132, No. 2, pp. 519-542.)
4818 !
4819 ! 4. If iliqskin=1, frozen particles that are at a temperature above
4820 ! freezing are assumed to scatter as a liquid particle.
4821 !
4822 ! More information on the derivation of simulated reflectivity in RIP
4823 ! can be found in Stoelinga (2005, unpublished write-up). Contact
4824 ! Mark Stoelinga (stoeling@atmos.washington.edu) for a copy.
4825 
4826 ! 22sep16: Modifying to use the GFDL MP parameters. If doing so remember
4827 ! that the GFDL MP assumes a constant intercept (in0X = .false.)
4828 ! Ferrier-Aligo has an option for fixed slope (rather than fixed intercept).
4829 ! Thompson presumably is an extension of Reisner MP.
4830 
4831  type(fv_grid_bounds_type), intent(IN) :: bd
4832  integer, intent(IN) :: npz, ncnst
4833  real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz) :: pt, delp, delz
4834  real, intent(IN), dimension(bd%isd:bd%ied, bd%jsd:bd%jed, npz, ncnst) :: q
4835  real, intent(IN), dimension(bd%is :bd%ie, npz+1, bd%js:bd%je) :: peln
4836  real, intent(OUT), dimension(bd%is :bd%ie, bd%js :bd%je , npz) :: dbz
4837  real, intent(OUT), dimension(bd%is :bd%ie, bd%js :bd%je) :: maxdbz
4838  logical, intent(IN) :: hydrostatic, in0r, in0s, in0g, iliqskin
4839  real, intent(IN) :: zvir
4840  real, intent(OUT) :: allmax
4841 
4842  !Parameters for constant intercepts (in0[rsg] = .false.)
4843  !Using GFDL MP values
4844  real(kind=R_GRID), parameter:: rn0_r = 8.e6 ! m^-4
4845  real(kind=R_GRID), parameter:: rn0_s = 3.e6 ! m^-4
4846  real(kind=R_GRID), parameter:: rn0_g = 4.e6 ! m^-4
4847  real(kind=R_GRID), parameter:: vconr = 2503.23638966667
4848  real(kind=R_GRID), parameter:: vcong = 87.2382675
4849  real(kind=R_GRID), parameter:: vcons = 6.6280504
4850  real(kind=R_GRID), parameter:: normr = 25132741228.7183
4851  real(kind=R_GRID), parameter:: normg = 5026548245.74367
4852  real(kind=R_GRID), parameter:: norms = 942477796.076938
4853 
4854  !Constants for variable intercepts
4855  !Will need to be changed based on MP scheme
4856  real, parameter :: r1=1.e-15
4857  real, parameter :: ron=8.e6
4858  real, parameter :: ron2=1.e10
4859  real, parameter :: son=2.e7
4860  real, parameter :: gon=5.e7
4861  real, parameter :: ron_min = 8.e6
4862  real, parameter :: ron_qr0 = 0.00010
4863  real, parameter :: ron_delqr0 = 0.25*ron_qr0
4864  real, parameter :: ron_const1r = (ron2-ron_min)*0.5
4865  real, parameter :: ron_const2r = (ron2+ron_min)*0.5
4866 
4867  !Other constants
4868  real, parameter :: gamma_seven = 720.
4869  !The following values are also used in GFDL MP
4870  real, parameter :: rho_r = 1.0e3 ! LFO83
4871  real, parameter :: rho_s = 100. ! kg m^-3
4872  real, parameter :: rho_g0 = 400. ! kg m^-3
4873  real, parameter :: rho_g = 500. ! graupel-hail mix
4874 ! real, parameter :: rho_g = 900. ! hail/frozen rain
4875  real, parameter :: alpha = 0.224
4876  real(kind=R_GRID), parameter :: factor_r = gamma_seven * 1.e18 * (1./(pi*rho_r))**1.75
4877  real(kind=R_GRID), parameter :: factor_s = gamma_seven * 1.e18 * (1./(pi*rho_s))**1.75 &
4878  * (rho_s/rho_r)**2 * alpha
4879  real(kind=R_GRID), parameter :: factor_g = gamma_seven * 1.e18 * (1./(pi*rho_g))**1.75 &
4880  * (rho_g/rho_r)**2 * alpha
4881  real, parameter :: qmin = 1.e-12
4882  real, parameter :: tice = 273.16
4883 
4884 ! Double precision
4885  real(kind=R_GRID):: rhoair(bd%is:bd%ie)
4886  real(kind=R_GRID):: qr1, qs1, qg1, t1, t2, t3, rwat, denfac, vtr, vtg, vts
4887  real(kind=R_GRID):: factorb_s, factorb_g
4888  real(kind=R_GRID):: temp_c, pres, sonv, gonv, ronv, z_e
4889 
4890  integer :: i,j,k
4891  integer :: is, ie, js, je
4892 
4893  is = bd%is
4894  ie = bd%ie
4895  js = bd%js
4896  je = bd%je
4897  if (rainwat < 1) return
4898 
4899  dbz(:,:,1:mp_top) = -20.
4900  maxdbz(:,:) = -20. !Minimum value
4901  allmax = -20.
4902 
4903 
4904 !$OMP parallel do default(shared) private(rhoair,t1,t2,t3,denfac,vtr,vtg,vts,z_e)
4905  do k=mp_top+1, npz
4906  do j=js, je
4907  if (hydrostatic) then
4908  do i=is, ie
4909 #ifdef MULTI_GASES
4910  rhoair(i) = delp(i,j,k)/( (peln(i,k+1,j)-peln(i,k,j)) * rdgas * pt(i,j,k) * virq(q(i,j,k,1:num_gas)) )
4911 #else
4912  rhoair(i) = delp(i,j,k)/( (peln(i,k+1,j)-peln(i,k,j)) * rdgas * pt(i,j,k) * ( 1. + zvir*q(i,j,k,sphum) ) )
4913 #endif
4914  enddo
4915  else
4916  do i=is, ie
4917  rhoair(i) = -delp(i,j,k)/(grav*delz(i,j,k)) ! moist air density
4918  enddo
4919  endif
4920  do i=is, ie
4921 ! The following form vectorizes better & more consistent with GFDL_MP
4922 ! SJL notes: Marshall-Palmer, dBZ = 200*precip**1.6, precip = 3.6e6*t1/rho_r*vtr ! [mm/hr]
4923 ! GFDL_MP terminal fall speeds are used
4924 ! Date modified 20170701
4925 ! Account for excessively high cloud water -> autoconvert (diag only) excess cloud water
4926  t1 = rhoair(i)*max(qmin, q(i,j,k,rainwat)+dim(q(i,j,k,liq_wat), 1.0e-3))
4927  t2 = rhoair(i)*max(qmin, q(i,j,k,snowwat))
4928  if (graupel > 0) then
4929  t3 = rhoair(i)*max(qmin, q(i,j,k,graupel))
4930  else
4931  t3 = rhoair(i)*qmin
4932  endif
4933  denfac = sqrt(min(10., 1.2/rhoair(i)))
4934  vtr = max(1.e-3, vconr*denfac*exp(0.2 *log(t1/normr)))
4935  vtg = max(1.e-3, vcong*denfac*exp(0.125 *log(t3/normg)))
4936 ! vts = max(1.e-3, vcons*denfac*exp(0.0625*log(t2/norms)))
4937  z_e = 200.*(exp(1.6*log(3.6e6*t1/rho_r*vtr)) + exp(1.6*log(3.6e6*t3/rho_g0*vtg))) + (factor_s/alpha)*t2*exp(0.75*log(t2/rn0_s))
4938 ! z_e = 200.*(exp(1.6*log(3.6e6*t1/rho_r*vtr)) + exp(1.6*log(3.6e6*t3/rho_g*vtg)) + exp(1.6*log(3.6e6*t2/rho_s*vts)))
4939  dbz(i,j,k) = 10.*log10( max(0.01, z_e) )
4940  enddo
4941  enddo
4942  enddo
4943 
4944 !$OMP parallel do default(shared)
4945  do j=js, je
4946  do k=mp_top+1, npz
4947  do i=is, ie
4948  maxdbz(i,j) = max(dbz(i,j,k), maxdbz(i,j))
4949  enddo
4950  enddo
4951  enddo
4952 
4953  do j=js, je
4954  do i=is, ie
4955  allmax = max(maxdbz(i,j), allmax)
4956  enddo
4957  enddo
4958 
4959  end subroutine dbzcalc
4960 !
4961  subroutine max_vorticity_hy1(is, ie, js, je, km, vort, maxvorthy1)
4962  integer, intent(in):: is, ie, js, je, km
4963  real, intent(in), dimension(is:ie,js:je,km):: vort
4964  real, intent(inout), dimension(is:ie,js:je):: maxvorthy1
4965  integer i, j, k
4966 
4967  do j=js,je
4968  do i=is,ie
4969  maxvorthy1(i,j)=max(maxvorthy1(i,j),vort(i,j,km))
4970  enddo ! i-loop
4971  enddo ! j-loop
4972  end subroutine max_vorticity_hy1
4973 !
4974 ! subroutine max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostatic, &
4975 ! pt, peln, phis, grav, vort, maxvorthy1, maxvort, z_bot, z_top)
4976  subroutine max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostatic, &
4977  pt, peln, phis, grav, vort, maxvort, z_bot, z_top)
4978  integer, intent(in):: is, ie, js, je, ng, km, sphum
4979  real, intent(in):: grav, zvir, z_bot, z_top
4980  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt
4981  real, intent(in), dimension(is:ie,js:je,km):: vort
4982  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
4983  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
4984  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
4985  real, intent(in):: peln(is:ie,km+1,js:je)
4986  logical, intent(in):: hydrostatic
4987 ! real, intent(inout), dimension(is:ie,js:je):: maxvorthy1,maxvort
4988  real, intent(inout), dimension(is:ie,js:je):: maxvort
4989 
4990  real:: rdg
4991  real, dimension(is:ie):: zh, dz, zh0
4992  integer i, j, k,klevel
4993  logical below(is:ie)
4994 
4995  rdg = rdgas / grav
4996 
4997  do j=js,je
4998 
4999  do i=is,ie
5000  zh(i) = 0.
5001  below(i) = .true.
5002  zh0(i) = 0.
5003 
5004  k_loop:do k=km,1,-1
5005  if ( hydrostatic ) then
5006  dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
5007  else
5008  dz(i) = - delz(i,j,k)
5009  endif
5010  zh(i) = zh(i) + dz(i)
5011  if (zh(i) <= z_bot ) continue
5012  if (zh(i) > z_bot .and. below(i)) then
5013  maxvort(i,j) = max(maxvort(i,j),vort(i,j,k))
5014  below(i) = .false.
5015  elseif ( zh(i) < z_top ) then
5016  maxvort(i,j) = max(maxvort(i,j),vort(i,j,k))
5017  else
5018  maxvort(i,j) = max(maxvort(i,j),vort(i,j,k))
5019  EXIT k_loop
5020  endif
5021  enddo k_loop
5022 ! maxvorthy1(i,j)=max(maxvorthy1(i,j),vort(i,j,km))
5023  enddo ! i-loop
5024  enddo ! j-loop
5025 
5026 
5027  end subroutine max_vorticity
5028 
5029  subroutine max_uh(is, ie, js, je, ng, km, zvir, sphum, uphmax,uphmin, &
5030  w, vort, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
5031 ! !INPUT PARAMETERS:
5032  integer, intent(in):: is, ie, js, je, ng, km, sphum
5033  real, intent(in):: grav, zvir, z_bot, z_top
5034  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, w
5035  real, intent(in), dimension(is:ie,js:je,km):: vort
5036  real, intent(in):: delz(is-ng:ie+ng,js-ng:je+ng,km)
5037  real, intent(in):: q(is-ng:ie+ng,js-ng:je+ng,km,*)
5038  real, intent(in):: phis(is-ng:ie+ng,js-ng:je+ng)
5039  real, intent(in):: peln(is:ie,km+1,js:je)
5040  logical, intent(in):: hydrostatic
5041  real :: uh(is:ie,js:je) ! unit: (m/s)**2
5042  real, intent(inout), dimension(is:ie,js:je):: uphmax,uphmin
5043 ! Coded by S.-J. Lin for CONUS regional climate simulations
5044 ! Modified for UH by LMH
5045 !
5046  real:: rdg
5047  real, dimension(is:ie):: zh, dz, zh0
5048  integer i, j, k
5049  logical below(is:ie)
5050 
5051  rdg = rdgas / grav
5052  do j=js,je
5053 
5054  do i=is,ie
5055  zh(i) = 0.
5056  uh(i,j) = 0.
5057  below(i) = .true.
5058  zh0(i) = 0.
5059 
5060 ! if ( phis(i,j)/grav < 1.E3 ) then
5061  k_loop:do k=km,1,-1
5062  if ( hydrostatic ) then
5063  dz(i) = rdg*pt(i,j,k)*(1.+zvir*q(i,j,k,sphum))*(peln(i,k+1,j)-peln(i,k,j))
5064  else
5065  dz(i) = - delz(i,j,k)
5066  endif
5067  zh(i) = zh(i) + dz(i)
5068  if (zh(i) <= z_bot ) continue
5069  if (zh(i) > z_bot .and. below(i)) then
5070  if(w(i,j,k).lt.0)then
5071  uh(i,j) = 0.
5072  EXIT k_loop
5073  endif
5074  uh(i,j) = vort(i,j,k)*w(i,j,k)*(zh(i) - z_bot)
5075  below(i) = .false.
5076 ! Compute mean winds below z_top
5077  elseif ( zh(i) < z_top ) then
5078  if(w(i,j,k).lt.0)then
5079  uh(i,j) = 0.
5080  EXIT k_loop
5081  endif
5082  uh(i,j) = uh(i,j) + vort(i,j,k)*w(i,j,k)*dz(i)
5083  else
5084  if(w(i,j,k).lt.0)then
5085  uh(i,j) = 0.
5086  EXIT k_loop
5087  endif
5088  uh(i,j) = uh(i,j) + vort(i,j,k)*w(i,j,k)*(z_top - (zh(i)-dz(i)) )
5089  EXIT k_loop
5090  endif
5091  enddo k_loop
5092  if (uh(i,j) > uphmax(i,j)) then
5093  uphmax(i,j) = uh(i,j)
5094  elseif (uh(i,j) < uphmin(i,j)) then
5095  uphmin(i,j) = uh(i,j)
5096  endif
5097  enddo ! i-loop
5098  enddo ! j-loop
5099 
5100  end subroutine max_uh
5101  subroutine max_vv(is,ie,js,je,npz,ng,up2,dn2,pe,w)
5102 ! !INPUT PARAMETERS:
5103  integer, intent(in):: is, ie, js, je, ng, npz
5104  integer :: i,j,k
5105  real, intent(in), dimension(is-ng:ie+ng,js-ng:je+ng,npz):: w
5106  real, intent(in):: pe(is-1:ie+1,npz+1,js-1:je+1)
5107  real, intent(inout), dimension(is:ie,js:je):: up2,dn2
5108  do j=js,je
5109  do i=is,ie
5110  do k=3,npz
5111  if (pe(i,k,j) >= 100.e2) then
5112  up2(i,j) = max(up2(i,j),w(i,j,k))
5113  dn2(i,j) = min(dn2(i,j),w(i,j,k))
5114  endif
5115  enddo
5116  enddo
5117  enddo
5118  end subroutine max_vv
5119 
5120  subroutine fv_diag_init_gn(Atm)
5121  type(fv_atmos_type), intent(inout), target :: Atm
5122 
5123  if (atm%grid_Number > 1) then
5124  write(gn,"(A2,I1)") " g", atm%grid_number
5125  else
5126  gn = ""
5127  end if
5128 
5129  end subroutine fv_diag_init_gn
5130 
5139  subroutine getcape( nk , p , t , dz, q, the, cape , cin, source_in )
5140  implicit none
5141 
5142  integer, intent(in) :: nk
5143  real, dimension(nk), intent(in) :: p,t,dz,q,the
5144  real, intent(out) :: cape,cin
5145  integer, intent(IN), OPTIONAL :: source_in
5146 
5147 !-----------------------------------------------------------------------
5148 !
5149 ! getcape - a fortran90 subroutine to calculate Convective Available
5150 ! Potential Energy (CAPE) from a sounding.
5151 !
5152 ! Version 1.02 Last modified: 10 October 2008
5153 !
5154 ! Author: George H. Bryan
5155 ! Mesoscale and Microscale Meteorology Division
5156 ! National Center for Atmospheric Research
5157 ! Boulder, Colorado, USA
5158 ! gbryan@ucar.edu
5159 !
5160 ! Disclaimer: This code is made available WITHOUT WARRANTY.
5161 !
5162 ! References: Bolton (1980, MWR, p. 1046) (constants and definitions)
5163 ! Bryan and Fritsch (2004, MWR, p. 2421) (ice processes)
5164 !
5165 !-----------------------------------------------------------------------
5166 !
5167 ! Input: nk - number of levels in the sounding (integer)
5168 !
5169 ! p - one-dimensional array of pressure (Pa) (real)
5170 !
5171 ! t - one-dimensional array of temperature (K) (real)
5172 !
5173 ! dz - one-dimensional array of height thicknesses (m) (real)
5174 !
5175 ! q - one-dimensional array of specific humidity (kg/kg) (real)
5176 !
5177 ! source - source parcel:
5178 ! 1 = surface (default)
5179 ! 2 = most unstable (max theta-e)
5180 ! 3 = mixed-layer (specify ml_depth)
5181 !
5182 ! Output: cape - Convective Available Potential Energy (J/kg) (real)
5183 !
5184 ! cin - Convective Inhibition (J/kg) (real)
5185 !
5186 !-----------------------------------------------------------------------
5187 ! User options:
5188 
5189  real, parameter :: pinc = 10000.0
5190  ! (smaller number yields more accurate
5191  ! results,larger number makes code
5192  ! go faster)
5193 
5194 
5195  real, parameter :: ml_depth = 200.0
5197 
5198  integer, parameter :: adiabat = 1
5203 
5204 !-----------------------------------------------------------------------
5205 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
5206 !-----------------------------------------------------------------------
5207 ! No need to modify anything below here:
5208 !-----------------------------------------------------------------------
5209 
5210  integer :: source = 1
5211  logical :: doit,ice,cloud,not_converged
5212  integer :: k,kmin,n,nloop,i,orec
5213  real, dimension(nk) :: pi,th,thv,z,pt,pb,pc,pn,ptv
5214 
5215  real :: maxthe,parea,narea,lfc
5216  real :: th1,p1,t1,qv1,ql1,qi1,b1,pi1,thv1,qt,dp,frac
5217  real :: th2,p2,t2,qv2,ql2,qi2,b2,pi2,thv2
5218  real :: thlast,fliq,fice,tbar,qvbar,qlbar,qibar,lhv,lhs,lhf,rm,cpm
5219  real*8 :: avgth,avgqv
5220 
5221 !-----------------------------------------------------------------------
5222 
5223  real, parameter :: g = 9.81
5224  real, parameter :: p00 = 100000.0
5225  real, parameter :: cp = 1005.7
5226  real, parameter :: rd = 287.04
5227  real, parameter :: rv = 461.5
5228  real, parameter :: xlv = 2501000.0
5229  real, parameter :: xls = 2836017.0
5230  real, parameter :: t0 = 273.15
5231  real, parameter :: cpv = 1875.0
5232  real, parameter :: cpl = 4190.0
5233  real, parameter :: cpi = 2118.636
5234  real, parameter :: lv1 = xlv+(cpl-cpv)*t0
5235  real, parameter :: lv2 = cpl-cpv
5236  real, parameter :: ls1 = xls+(cpi-cpv)*t0
5237  real, parameter :: ls2 = cpi-cpv
5238 
5239  real, parameter :: rp00 = 1.0/p00
5240  real, parameter :: eps = rd/rv
5241  real, parameter :: reps = rv/rd
5242  real, parameter :: rddcp = rd/cp
5243  real, parameter :: cpdrd = cp/rd
5244  real, parameter :: cpdg = cp/g
5245 
5246  real, parameter :: converge = 0.1
5247 
5248  integer, parameter :: debug_level = 0
5249 
5250  if (present(source_in)) source = source_in
5251 
5252 !-----------------------------------------------------------------------
5253 
5254 !---- convert p,t to mks units; get pi,th,thv ----!
5255 
5256  do k=1,nk
5257  pi(k) = (p(k)*rp00)**rddcp
5258  th(k) = t(k)/pi(k)
5259  thv(k) = th(k)*(1.0+reps*q(k))/(1.0+q(k))
5260  enddo
5261 
5262 !---- get height using the hydrostatic equation ----!
5263 
5264  z(nk) = 0.5*dz(nk)
5265  do k=nk-1,1,-1
5266  z(k) = z(k+1) + 0.5*(dz(k+1)+dz(k))
5267  enddo
5268 
5269 !---- find source parcel ----!
5270 
5271  IF(source.eq.1)THEN
5272  ! use surface parcel
5273  kmin = nk
5274 
5275  ELSEIF(source.eq.2)THEN
5276  ! use most unstable parcel (max theta-e)
5277 
5278  IF(p(1).lt.50000.0)THEN
5279  ! first report is above 500 mb ... just use the first level reported
5280  kmin = nk
5281  maxthe = the(nk)
5282  ELSE
5283  ! find max thetae below 500 mb
5284  maxthe = 0.0
5285  do k=nk,1,-1
5286  if(p(k).ge.50000.0)then
5287  if( the(nk).gt.maxthe )then
5288  maxthe = the(nk)
5289  kmin = k
5290  endif
5291  endif
5292  enddo
5293  ENDIF
5294  if(debug_level.ge.100) print *,' kmin,maxthe = ',kmin,maxthe
5295 
5296 !!$ ELSEIF(source.eq.3)THEN
5297 !!$ ! use mixed layer
5298 !!$
5299 !!$ IF( dz(nk).gt.ml_depth )THEN
5300 !!$ ! the second level is above the mixed-layer depth: just use the
5301 !!$ ! lowest level
5302 !!$
5303 !!$ avgth = th(nk)
5304 !!$ avgqv = q(nk)
5305 !!$ kmin = nk
5306 !!$
5307 !!$ ELSEIF( z(1).lt.ml_depth )THEN
5308 !!$ ! the top-most level is within the mixed layer: just use the
5309 !!$ ! upper-most level (not
5310 !!$
5311 !!$ avgth = th(1)
5312 !!$ avgqv = q(1)
5313 !!$ kmin = 1
5314 !!$
5315 !!$ ELSE
5316 !!$ ! calculate the mixed-layer properties:
5317 !!$
5318 !!$ avgth = 0.0
5319 !!$ avgqv = 0.0
5320 !!$ k = nk-1
5321 !!$ if(debug_level.ge.100) print *,' ml_depth = ',ml_depth
5322 !!$ if(debug_level.ge.100) print *,' k,z,th,q:'
5323 !!$ if(debug_level.ge.100) print *,nk,z(nk),th(nk),q(nk)
5324 !!$
5325 !!$ do while( (z(k).le.ml_depth) .and. (k.ge.1) )
5326 !!$
5327 !!$ if(debug_level.ge.100) print *,k,z(k),th(k),q(k)
5328 !!$
5329 !!$ avgth = avgth + dz(k)*th(k)
5330 !!$ avgqv = avgqv + dz(k)*q(k)
5331 !!$
5332 !!$ k = k - 1
5333 !!$
5334 !!$ enddo
5335 !!$
5336 !!$ th2 = th(k+1)+(th(k)-th(k+1))*(ml_depth-z(k-1))/dz(k)
5337 !!$ qv2 = q(k+1)+( q(k)- q(k+1))*(ml_depth-z(k-1))/dz(k)
5338 !!$
5339 !!$ if(debug_level.ge.100) print *,999,ml_depth,th2,qv2
5340 !!$
5341 !!$ avgth = avgth + 0.5*(ml_depth-z(k-1))*(th2+th(k-1))
5342 !!$ avgqv = avgqv + 0.5*(ml_depth-z(k-1))*(qv2+q(k-1))
5343 !!$
5344 !!$ if(debug_level.ge.100) print *,k,z(k),th(k),q(k)
5345 !!$
5346 !!$ avgth = avgth/ml_depth
5347 !!$ avgqv = avgqv/ml_depth
5348 !!$
5349 !!$ kmin = nk
5350 !!$
5351 !!$ ENDIF
5352 !!$
5353 !!$ if(debug_level.ge.100) print *,avgth,avgqv
5354 
5355  ELSE
5356 
5357  print *
5358  print *,' Unknown value for source'
5359  print *
5360  print *,' source = ',source
5361  print *
5362  call mpp_error(fatal, " Unknown CAPE source")
5363 
5364  ENDIF
5365 
5366 !---- define parcel properties at initial location ----!
5367  narea = 0.0
5368 
5369  if( (source.eq.1).or.(source.eq.2) )then
5370  k = kmin
5371  th2 = th(kmin)
5372  pi2 = pi(kmin)
5373  p2 = p(kmin)
5374  t2 = t(kmin)
5375  thv2 = thv(kmin)
5376  qv2 = q(kmin)
5377  b2 = 0.0
5378  elseif( source.eq.3 )then
5379  k = kmin
5380  th2 = avgth
5381  qv2 = avgqv
5382  thv2 = th2*(1.0+reps*qv2)/(1.0+qv2)
5383  pi2 = pi(kmin)
5384  p2 = p(kmin)
5385  t2 = th2*pi2
5386  b2 = g*( thv2-thv(kmin) )/thv(kmin)
5387  endif
5388 
5389  ql2 = 0.0
5390  qi2 = 0.0
5391  qt = qv2
5392 
5393  cape = 0.0
5394  cin = 0.0
5395  lfc = 0.0
5396 
5397  doit = .true.
5398  cloud = .false.
5399  if(adiabat.eq.1.or.adiabat.eq.2)then
5400  ice = .false.
5401  else
5402  ice = .true.
5403  endif
5404 
5405 ! the = getthe(p2,t2,t2,qv2)
5406 ! if(debug_level.ge.100) print *,' the = ',the
5407 
5408 !---- begin ascent of parcel ----!
5409 
5410  if(debug_level.ge.100)then
5411  print *,' Start loop:'
5412  print *,' p2,th2,qv2 = ',p2,th2,qv2
5413  endif
5414 
5415  do while( doit .and. (k.gt.1) )
5416 
5417  k = k-1
5418  b1 = b2
5419 
5420  dp = p(k)-p(k-1)
5421 
5422  if( dp.lt.pinc )then
5423  nloop = 1
5424  else
5425  nloop = 1 + int( dp/pinc )
5426  dp = dp/float(nloop)
5427  endif
5428 
5429  do n=1,nloop
5430 
5431  p1 = p2
5432  t1 = t2
5433  pi1 = pi2
5434  th1 = th2
5435  qv1 = qv2
5436  ql1 = ql2
5437  qi1 = qi2
5438  thv1 = thv2
5439 
5440  p2 = p2 - dp
5441  pi2 = (p2*rp00)**rddcp
5442 
5443  thlast = th1
5444  i = 0
5445  not_converged = .true.
5446 
5447  do while( not_converged )
5448  i = i + 1
5449  t2 = thlast*pi2
5450  if(ice)then
5451  fliq = max(min((t2-233.15)/(273.15-233.15),1.0),0.0)
5452  fice = 1.0-fliq
5453  else
5454  fliq = 1.0
5455  fice = 0.0
5456  endif
5457  qv2 = min( qt , fliq*getqvs(p2,t2) + fice*getqvi(p2,t2) )
5458  qi2 = max( fice*(qt-qv2) , 0.0 )
5459  ql2 = max( qt-qv2-qi2 , 0.0 )
5460 
5461  tbar = 0.5*(t1+t2)
5462  qvbar = 0.5*(qv1+qv2)
5463  qlbar = 0.5*(ql1+ql2)
5464  qibar = 0.5*(qi1+qi2)
5465 
5466  lhv = lv1-lv2*tbar
5467  lhs = ls1-ls2*tbar
5468  lhf = lhs-lhv
5469 
5470  rm=rd+rv*qvbar
5471  cpm=cp+cpv*qvbar+cpl*qlbar+cpi*qibar
5472  th2=th1*exp( lhv*(ql2-ql1)/(cpm*tbar) &
5473  +lhs*(qi2-qi1)/(cpm*tbar) &
5474  +(rm/cpm-rd/cp)*alog(p2/p1) )
5475 
5476  if(i.gt.90) print *,i,th2,thlast,th2-thlast
5477  if(i.gt.100)then
5478  print *
5479  print *,' Error: lack of convergence'
5480  print *
5481  print *,' ... stopping iteration '
5482  print *
5483  stop 1001
5484  endif
5485  if( abs(th2-thlast).gt.converge )then
5486  thlast=thlast+0.3*(th2-thlast)
5487  else
5488  not_converged = .false.
5489  endif
5490  enddo
5491 
5492  ! Latest pressure increment is complete. Calculate some
5493  ! important stuff:
5494 
5495  if( ql2.ge.1.0e-10 ) cloud = .true.
5496 
5497  IF(adiabat.eq.1.or.adiabat.eq.3)THEN
5498  ! pseudoadiabat
5499  qt = qv2
5500  ql2 = 0.0
5501  qi2 = 0.0
5502  ELSEIF(adiabat.le.0.or.adiabat.ge.5)THEN
5503  print *
5504  print *,' Undefined adiabat'
5505  print *
5506  stop 10000
5507  ENDIF
5508 
5509  enddo
5510 
5511  thv2 = th2*(1.0+reps*qv2)/(1.0+qv2+ql2+qi2)
5512  b2 = g*( thv2-thv(k) )/thv(k)
5513 
5514 ! the = getthe(p2,t2,t2,qv2)
5515 
5516  ! Get contributions to CAPE and CIN:
5517 
5518  if( (b2.ge.0.0) .and. (b1.lt.0.0) )then
5519  ! first trip into positive area
5520  !ps = p(k-1)+(p(k)-p(k-1))*(0.0-b1)/(b2-b1)
5521  frac = b2/(b2-b1)
5522  parea = 0.5*b2*dz(k)*frac
5523  narea = narea-0.5*b1*dz(k)*(1.0-frac)
5524  if(debug_level.ge.200)then
5525  print *,' b1,b2 = ',b1,b2
5526  !print *,' p1,ps,p2 = ',p(k-1),ps,p(k)
5527  print *,' frac = ',frac
5528  print *,' parea = ',parea
5529  print *,' narea = ',narea
5530  endif
5531  cin = cin + narea
5532  narea = 0.0
5533  elseif( (b2.lt.0.0) .and. (b1.gt.0.0) )then
5534  ! first trip into neg area
5535  !ps = p(k-1)+(p(k)-p(k-1))*(0.0-b1)/(b2-b1)
5536  frac = b1/(b1-b2)
5537  parea = 0.5*b1*dz(k)*frac
5538  narea = -0.5*b2*dz(k)*(1.0-frac)
5539  if(debug_level.ge.200)then
5540  print *,' b1,b2 = ',b1,b2
5541  !print *,' p1,ps,p2 = ',p(k-1),ps,p(k)
5542  print *,' frac = ',frac
5543  print *,' parea = ',parea
5544  print *,' narea = ',narea
5545  endif
5546  elseif( b2.lt.0.0 )then
5547  ! still collecting negative buoyancy
5548  parea = 0.0
5549  narea = narea-0.5*dz(k)*(b1+b2)
5550  else
5551  ! still collecting positive buoyancy
5552  parea = 0.5*dz(k)*(b1+b2)
5553  narea = 0.0
5554  endif
5555 
5556  cape = cape + max(0.0,parea)
5557 
5558  if(debug_level.ge.200)then
5559  write(6,102) p2,b1,b2,cape,cin,cloud
5560 102 format(5(f13.4),2x,l1)
5561  endif
5562 
5563  if( (p(k).le.10000.0).and.(b2.lt.0.0) )then
5564  ! stop if b < 0 and p < 100 mb
5565  doit = .false.
5566  endif
5567 
5568  enddo
5569 
5570 !---- All done ----!
5571 
5572  return
5573  end subroutine getcape
5574 !-----------------------------------------------------------------------
5575 
5576 
5577  real function getqvs(p,t)
5578  implicit none
5579 
5580  real :: p,t,es
5581 
5582  real, parameter :: eps = 287.04/461.5
5583 
5584  es = 611.2*exp(17.67*(t-273.15)/(t-29.65))
5585  getqvs = eps*es/(p-es)
5586 
5587  return
5588  end function getqvs
5589 !-----------------------------------------------------------------------
5590 
5591 
5592  real function getqvi(p,t)
5593  implicit none
5594 
5595  real :: p,t,es
5596 
5597  real, parameter :: eps = 287.04/461.5
5598 
5599  es = 611.2*exp(21.8745584*(t-273.15)/(t-7.66))
5600  getqvi = eps*es/(p-es)
5601 
5602  return
5603  end function getqvi
5604 !-----------------------------------------------------------------------
5605 
5606 end module fv_diagnostics_mod
character(len=256) tlongname
subroutine, public prt_height(qname, is, ie, js, je, ng, km, press, phis, delz, peln, area, lat)
integer, parameter nplev
pure real function, public vicpqd(q)
real, parameter missing_value3
for variables where we look for smallest values
subroutine cs_prof(q2, delp, q, km, i1, i2, iv)
The module &#39;fv_mp_mod&#39; is a single program multiple data (SPMD) parallel decompostion/communication m...
Definition: fv_mp_mod.F90:24
subroutine, public max_uh(is, ie, js, je, ng, km, zvir, sphum, uphmax, uphmin, w, vort, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
The type &#39;fv_grid_type&#39; is made up of grid-dependent information from fv_grid_tools and fv_grid_utils...
Definition: fv_arrays.F90:120
real, parameter missing_value2
for variables with many missing values
real, dimension(:,:), allocatable, public zs_g
subroutine, public moist_cv(is, ie, isd, ied, jsd, jed, km, j, k, nwat, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, q, qd, cvm, t1)
The subroutine &#39;moist_cv&#39; computes the FV3-consistent moist heat capacity under constant volume...
Definition: fv_mapz.F90:3415
real, public sphum_ll_fix
integer, public num_gas
Definition: multi_gases.F90:44
subroutine getcape(nk, p, t, dz, q, the, cape, cin, source_in)
The subroutine &#39;getcape&#39; calculates the Convective Available Potential Energy (CAPE) from a Sounding...
The module &#39;multi_gases&#39; peforms multi constitutents computations.
Definition: multi_gases.F90:25
subroutine, public a2b_ord2(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge.F90:698
subroutine, public eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, npz, hydrostatic, moist)
The subroutine &#39;eqv_pot&#39; calculates the equivalent potential temperature.
subroutine, public get_eta_level(npz, p_s, pf, ph, ak, bk, pscale)
The subroutine &#39;get_eta_level&#39; returns the interface and layer-mean pressures for reference...
Definition: fv_eta.F90:2588
real, parameter missing_value
subroutine get_height_given_pressure(is, ie, js, je, km, wz, kd, id, log_p, peln, a2)
real function, public g_sum(domain, p, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce)
The function &#39;g_sum&#39; is the fast version of &#39;globalsum&#39;.
integer, parameter max_step
Definition: fv_arrays.F90:43
subroutine wind_max(isc, iec, jsc, jec, isd, ied, jsd, jed, us, vs, ws_max, domain)
subroutine get_pressure_given_height(is, ie, js, je, ng, km, wz, kd, height, ts, peln, a2, fac)
integer, parameter, public r_grid
Definition: fv_arrays.F90:35
character(len=256) tunits
subroutine, public gw_1d(km, p0, ak, bk, ptop, ztop, pt1)
Definition: fv_eta.F90:3015
The module &#39;fv_sg&#39; performs FV sub-grid mixing.
Definition: fv_sg.F90:54
subroutine, public bunkers_vector(is, ie, js, je, ng, km, zvir, sphum, uc, vc, ua, va, delz, q, hydrostatic, pt, peln, phis, grav)
subroutine, public fv_diag_init_gn(Atm)
pure real function, public virqd(q)
subroutine, public prt_mxm(qname, q, is, ie, js, je, n_g, km, fac, area, domain)
subroutine, public max_vorticity_hy1(is, ie, js, je, km, vort, maxvorthy1)
pure real function, public virq(q)
subroutine interpolate_z(is, ie, js, je, km, zl, hght, a3, a2)
The module &#39;a2b_edge&#39; performs FV-consistent interpolation of pressure to corners.
Definition: a2b_edge.F90:24
subroutine, public z_sum(is, ie, js, je, km, n_g, delp, q, sum2)
subroutine, public fv_diag_init(Atm, axes, Time, npx, npy, npz, p_ref)
subroutine cs_interpolator(is, ie, js, je, km, qin, zout, wz, qout, qmin)
subroutine cs3_interpolator(is, ie, js, je, km, qin, kd, pout, wz, pe, id, qout, iv)
subroutine, public ppme(p, qe, delp, im, km)
subroutine init_mq(phis, gridstruct, npx, npy, is, ie, js, je, ng)
The module &#39;fv_mapz&#39; contains the vertical mapping routines .
Definition: fv_mapz.F90:27
subroutine, public qsmith(im, km, k1, t, p, q, qs, dqdt)
Definition: fv_sg.F90:1320
logical, public prt_minmax
The module &#39;fv_arrays&#39; contains the &#39;fv_atmos_type&#39; and associated datatypes.
Definition: fv_arrays.F90:24
subroutine, public get_height_field(is, ie, js, je, ng, km, hydrostatic, delz, wz, pt, q, peln, zvir)
The module &#39;fv_eta&#39; contains routine to set up the reference (Eulerian) pressure coordinate.
Definition: fv_eta.F90:25
real, parameter rad2deg
subroutine, public fv_diag(Atm, zvir, Time, print_freq)
subroutine updraft_helicity(is, ie, js, je, ng, km, zvir, sphum, uh, w, vort, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
subroutine pv_entropy(is, ie, js, je, ng, km, vort, f_d, pt, pkz, delp, grav)
The subroutine &#39;pv_entropy&#39; computes potential vorticity.
type(time_type), public fv_time
real function getqvi(p, t)
real function getqvs(p, t)
integer, dimension(nplev) levs
subroutine, public range_check(qname, q, is, ie, js, je, n_g, km, pos, q_low, q_hi, bad_range)
subroutine, public dbzcalc(q, pt, delp, peln, delz, dbz, maxdbz, allmax, bd, npz, ncnst, hydrostatic, zvir, in0r, in0s, in0g, iliqskin)
The subroutine &#39;dbzcalc&#39; computes equivalent reflectivity factor (in dBZ) at each model grid point...
@ The module &#39;fv_diagnostics&#39; contains routines to compute diagnosic fields.
The module &#39;fv_grid_utils&#39; contains routines for setting up and computing grid-related quantities...
character(len=3), public gn
subroutine, public prt_gb_nh_sh(qname, is, ie, js, je, a2, area, lat)
subroutine, public prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac)
subroutine, public helicity_relative_caps(is, ie, js, je, ng, km, zvir, sphum, srh, uc, vc, ua, va, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
subroutine, public rh_calc(pfull, t, qv, rh, do_cmip)
subroutine, public max_vorticity(is, ie, js, je, ng, km, zvir, sphum, delz, q, hydrostatic, pt, peln, phis, grav, vort, maxvort, z_bot, z_top)
subroutine, public a2b_ord4(qin, qout, gridstruct, npx, npy, is, ie, js, je, ng, replace)
Definition: a2b_edge.F90:70
real function p_sum(is, ie, js, je, km, n_g, delp, area, domain)
type(fv_diag_type), pointer idiag
subroutine, public interpolate_vertical(is, ie, js, je, km, plev, peln, a3, a2)
real(kind=4), public e_flux
Definition: fv_mapz.F90:127
subroutine, public prt_mass(km, nq, is, ie, js, je, n_g, nwat, ps, delp, q, area, domain)
subroutine nh_total_energy(is, ie, js, je, isd, ied, jsd, jed, km, w, delz, pt, delp, q, hs, area, domain, sphum, liq_wat, rainwat, ice_wat, snowwat, graupel, nwat, ua, va, moist_phys, te)
The subroutine &#39;nh_total_energy computes vertically-integrated total energy per column.
subroutine, public max_vv(is, ie, js, je, npz, ng, up2, dn2, pe, w)
subroutine helicity_relative(is, ie, js, je, ng, km, zvir, sphum, srh, ua, va, delz, q, hydrostatic, pt, peln, phis, grav, z_bot, z_top)
pure real function, public vicvqd(q)
character(len=128) tname
subroutine, public get_vorticity(isc, iec, jsc, jec, isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)