FV3DYCORE  Version1.0.0
test_cases.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the FV3 dynamical core.
5 !*
6 !* The FV3 dynamical core is free software: you can redistribute it
7 !* and/or modify it under the terms of the
8 !* GNU Lesser General Public License as published by the
9 !* Free Software Foundation, either version 3 of the License, or
10 !* (at your option) any later version.
11 !*
12 !* The FV3 dynamical core is distributed in the hope that it will be
13 !* useful, but WITHOUT ANYWARRANTY; without even the implied warranty
14 !* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
15 !* See the GNU General Public License for more details.
16 !*
17 !* You should have received a copy of the GNU Lesser General Public
18 !* License along with the FV3 dynamical core.
19 !* If not, see <http://www.gnu.org/licenses/>.
20 !***********************************************************************
21 
22  module test_cases_mod
23 
24 ! <table>
25 ! <tr>
26 ! <th>Module Name</th>
27 ! <th>Functions Included</th>
28 ! </tr>
29 ! <tr>
30 ! <td>constants_mod</td>
31 ! <td>cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas</td>
32 ! </tr>
33 ! <tr>
34 ! <td>diag_manager_mod</td>
35 ! <td>diag_axis_init, register_diag_field,
36 ! register_static_field, send_data, diag_grid_init</td>
37 ! </tr>
38 ! <tr>
39 ! <td>field_manager_mod</td>
40 ! <td>MODEL_ATMOS</td>
41 ! </tr>
42 ! <tr>
43 ! <td>fv_arrays_mod</td>
44 ! <td>fv_grid_type, fv_flags_type, fv_grid_bounds_type, R_GRID</td>
45 ! </tr>
46 ! <tr>
47 ! <td>fv_diagnostics_mod</td>
48 ! <td>prt_maxmin, ppme, eqv_pot, qcly0</td>
49 ! </tr>
50 ! <tr>
51 ! <td>fv_grid_tools_mod</td>
52 ! <td>todeg, missing, spherical_to_cartesian</td>
53 ! </tr>
54 ! <tr>
55 ! <td>fv_eta_mod</td>
56 ! <td>compute_dz_L32, compute_dz_L101, set_hybrid_z,
57 ! gw_1d,hybrid_z_dz</td>
58 ! </tr>
59 ! <tr>
60 ! <td>fv_mp_mod</td>
61 ! <td>ng, is_master,is,js,ie,je, isd,jsd,ied,jed,
62 ! domain_decomp, fill_corners, XDir, YDir, mp_stop,
63 ! mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst</td>
64 ! </tr>
65 ! <tr>
66 ! <td>fv_sg_mod</td>
67 ! <td>qsmith</td>
68 ! </tr>
69 ! <tr>
70 ! <td>fv_surf_map_mod</td>
71 ! <td>surfdrv</td>
72 ! </tr>
73 ! <tr>
74 ! <td>init_hydro_mod</td>
75 ! <td>p_var, hydro_eq</td>
76 ! </tr>
77 ! <tr>
78 ! <td>mpp_mod</td>
79 ! <td>mpp_error, FATAL, mpp_root_pe, mpp_broadcast, mpp_sum,
80 ! mpp_pe, mpp_chksum, stdout</td>
81 ! </tr>
82 ! <tr>
83 ! <td>mpp_domains_mod</td>
84 ! <td>mpp_update_domains, domain2d</td>
85 ! </tr>>
86 ! <tr>
87 ! <td>mpp_parameter_mod</td>
88 ! <td>AGRID_PARAM=>AGRID,CGRID_NE_PARAM=>CGRID_NE,SCALAR_PAIR</td>
89 ! </tr>
90 ! <tr>
91 ! <td>time_manager_mod</td>
92 ! <td>time_type, get_date, get_time</td>
93 ! </tr>
94 ! <tr>
95 ! <td>tracer_manager_mod</td>
96 ! <td>get_tracer_index</td>
97 ! </tr>
98 ! </table>
99 
100  use constants_mod, only: cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas
101  use init_hydro_mod, only: p_var, hydro_eq
102  use fv_mp_mod, only: ng, is_master, &
103  is,js,ie,je, isd,jsd,ied,jed, &
104  domain_decomp, fill_corners, xdir, ydir, &
105  mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst
106  use fv_grid_utils_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere, &
107  ptop_min, inner_prod, get_latlon_vector, get_unit_vect2, &
108  g_sum, latlon2xyz, cart_to_latlon, make_eta_level, f_p, project_sphere_v
109  use fv_surf_map_mod, only: surfdrv
110 
111  use fv_grid_tools_mod, only: todeg, missing, spherical_to_cartesian
112  use fv_eta_mod, only: compute_dz_l32, compute_dz_l101, set_hybrid_z, gw_1d, &
113  hybrid_z_dz
114 
115  use mpp_mod, only: mpp_error, fatal, mpp_root_pe, mpp_broadcast, mpp_sum
116  use mpp_domains_mod, only: mpp_update_domains, domain2d
117  use mpp_parameter_mod, only: agrid_param=>agrid,cgrid_ne_param=>cgrid_ne, &
118  scalar_pair
119  use fv_sg_mod, only: qsmith
120  use fv_diagnostics_mod, only: prt_maxmin, ppme, eqv_pot, qcly0
121 !!! DEBUG CODE
122  use mpp_mod, only: mpp_pe, mpp_chksum, stdout
123 !!! END DEBUG CODE
124  use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, r_grid
125  use tracer_manager_mod, only: get_tracer_index
126  use field_manager_mod, only: model_atmos
127  implicit none
128  private
129 
130 ! Test Case Number
131 ! -1 = Divergence conservation test
132 ! 0 = Idealized non-linear deformational flow
133 ! 1 = Cosine Bell advection
134 ! 2 = Zonal geostrophically balanced flow
135 ! 3 = non-rotating potential flow
136 ! 4 = Tropical cyclones (merger of Rankine vortices)
137 ! 5 = Zonal geostrophically balanced flow over an isolated mountain
138 ! 6 = Rossby Wave number 4
139 ! 7 = Barotropic instability
140 ! ! 8 = Potential flow (as in 5 but no rotation and initially at rest)
141 ! 8 = "Soliton" propagation twin-vortex along equator
142 ! 9 = Polar vortex
143 ! 10 = hydrostatically balanced 3D test with idealized mountain
144 ! 11 = Use this for cold starting the climate model with USGS terrain
145 ! 12 = Jablonowski & Williamson Baroclinic test case (Steady State)
146 ! 13 = Jablonowski & Williamson Baroclinic test case Perturbation
147 ! -13 = DCMIP 2016 J&W BC Wave, with perturbation
148 ! 14 = Use this for cold starting the Aqua-planet model
149 ! 15 = Small Earth density current
150 ! 16 = 3D hydrostatic non-rotating Gravity waves
151 ! 17 = 3D hydrostatic rotating Inertial Gravity waves (case 6-3-0)
152 ! 18 = 3D mountain-induced Rossby wave
153 ! 19 = As in 15 but without rotation
154 ! 20 = 3D non-hydrostatic lee vortices; non-rotating (small planet)
155 ! 21 = 3D non-hydrostatic lee vortices; rotating (small planet)
156 ! 30 = Super-Cell storm, curved hodograph, centered at OKC, no rotation
157 ! 31 = Super-Cell storm, curved hodograph, centered at OKC, with rotation
158 ! 32 = Super-Cell storm, straight hodograph, centered at OKC, no rotation
159 ! 33 = HIWPP Schar mountain waves, Ridge mountain (M1)
160 ! 34 = HIWPP Schar mountain waves, Circular mountain (M2)
161 ! 35 = HIWPP Schar mountain waves, Circular mountain with shear (M3)
162 ! 36 = HIWPP Super_Cell; no perturbation
163 ! 37 = HIWPP Super_Cell; with the prescribed thermal
164 ! 44 = Lock-exchange on the sphere; atm at rest with no mountain
165 ! 45 = New test
166 ! 51 = 3D tracer advection (deformational nondivergent flow)
167 ! 55 = TC
168 ! 101 = 3D non-hydrostatic Large-Eddy-Simulation (LES) with hybrid_z IC
169 
170  integer :: sphum, theta_d
171  real(kind=R_GRID), parameter :: radius = cnst_radius
172  real(kind=R_GRID), parameter :: one = 1.d0
173  integer :: test_case
174  logical :: bubble_do
175  real :: alpha
176  integer :: nsolitons
177  real :: soliton_size = 750.e3, soliton_umax = 50.
178 
179 ! Case 0 parameters
180  real :: p0_c0 = 3.0
181  real :: rgamma = 5.0
182  real :: lat0 = pi/2.0
183  real :: lon0 = 0.0
184 
185 ! pi_shift moves the initial location of the cosine bell for Case 1
186  real, parameter :: pi_shift = 0.0
187 
188  ! -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
189  integer, parameter :: initwindscase0 =-1
190  integer, parameter :: initwindscase1 = 1
191  integer, parameter :: initwindscase2 = 5
192  integer, parameter :: initwindscase5 = 5
193  integer, parameter :: initwindscase6 =-1
194  integer, parameter :: initwindscase9 =-1
195 
196  real, allocatable, dimension(:) :: pz0, zz0
197 
198  integer :: tracer_test, wind_field
199 
200  ! Ubar = initial wind speed parameter
201  real :: ubar, vbar
202  ! gh0 = initial surface height parameter
203  real :: gh0
204 
205  ! case 9 parameters
206  real , allocatable :: case9_b(:,:)
207  real :: aoft(2)
208 
209 
210  ! Validating fields used in statistics
211  real , allocatable :: phi0(:,:,:)
212  real , allocatable :: ua0(:,:,:)
213  real , allocatable :: va0(:,:,:)
214 
215  real , allocatable :: gh_table(:), lats_table(:)
216  logical :: gh_initialized = .false.
217 
218  ! Initial Conservation statistics ; total mass ; enstrophy ; energy
219  real :: tmass_orig
220  real :: tvort_orig
221  real :: tener_orig
222 
223  integer, parameter :: interporder = 1
224 
225  public :: pz0, zz0
226  public :: test_case, bubble_do, alpha, tracer_test, wind_field, nsolitons, soliton_umax, soliton_size
227  public :: init_case, get_stats, check_courant_numbers
228 #ifdef NCDF_OUTPUT
229  public :: output, output_ncdf
230 #endif
231  public :: case9_forcing1, case9_forcing2, case51_forcing
232  public :: init_double_periodic, init_latlon
233  public :: checker_tracers
234 
235  INTERFACE mp_update_dwinds
236  MODULE PROCEDURE mp_update_dwinds_2d
237  MODULE PROCEDURE mp_update_dwinds_3d
238  END INTERFACE
239 
240  contains
241 
242 !-------------------------------------------------------------------------------
243 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
244  subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions, nested, gridstruct, domain, tile)
245  ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
246 
247  real , intent(INOUT) :: UBar
248  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1)
249  real , intent(INOUT) :: v(isd:ied+1,jsd:jed )
250  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed )
251  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
252  real , intent(INOUT) :: ua(isd:ied ,jsd:jed )
253  real , intent(INOUT) :: va(isd:ied ,jsd:jed )
254  integer, intent(IN) :: defOnGrid
255  integer, intent(IN) :: npx, npy
256  integer, intent(IN) :: ng
257  integer, intent(IN) :: ndims
258  integer, intent(IN) :: nregions
259  logical, intent(IN) :: nested
260  type(fv_grid_type), intent(IN), target :: gridstruct
261  type(domain2d), intent(INOUT) :: domain
262  integer, intent(IN) :: tile
263 
264  real(kind=R_GRID) :: p1(2), p2(2), p3(2), p4(2), pt(2)
265  real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3)
266 
267  real :: dist, r, r0
268  integer :: i,j,k,n
269  real :: utmp, vtmp
270 
271  real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
272  integer :: is2, ie2, js2, je2
273 
274  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
275  real, pointer, dimension(:,:) :: area, rarea, fC, f0
276  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
277  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
278  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
279 
280  logical, pointer :: cubed_sphere, latlon
281 
282  logical, pointer :: have_south_pole, have_north_pole
283 
284  integer, pointer :: ntiles_g
285  real, pointer :: acapN, acapS, globalarea
286 
287  grid => gridstruct%grid_64
288  agrid=> gridstruct%agrid_64
289 
290  area => gridstruct%area
291  rarea => gridstruct%rarea
292 
293  fc => gridstruct%fC
294  f0 => gridstruct%f0
295 
296  ee1 => gridstruct%ee1
297  ee2 => gridstruct%ee2
298  ew => gridstruct%ew
299  es => gridstruct%es
300  en1 => gridstruct%en1
301  en2 => gridstruct%en2
302 
303  dx => gridstruct%dx
304  dy => gridstruct%dy
305  dxa => gridstruct%dxa
306  dya => gridstruct%dya
307  rdxa => gridstruct%rdxa
308  rdya => gridstruct%rdya
309  dxc => gridstruct%dxc
310  dyc => gridstruct%dyc
311 
312  cubed_sphere => gridstruct%cubed_sphere
313  latlon => gridstruct%latlon
314 
315  have_south_pole => gridstruct%have_south_pole
316  have_north_pole => gridstruct%have_north_pole
317 
318  ntiles_g => gridstruct%ntiles_g
319  acapn => gridstruct%acapN
320  acaps => gridstruct%acapS
321  globalarea => gridstruct%globalarea
322 
323  if (nested) then
324 
325  is2 = is-2
326  ie2 = ie+2
327  js2 = js-2
328  je2 = je+2
329 
330  else
331 
332  is2 = is
333  ie2 = ie
334  js2 = js
335  je2 = je
336 
337  end if
338 
339  200 format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
340 
341  psi(:,:) = 1.e25
342  psi_b(:,:) = 1.e25
343  do j=jsd,jed
344  do i=isd,ied
345  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
346  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
347  enddo
348  enddo
349  call mpp_update_domains( psi, domain )
350  do j=jsd,jed+1
351  do i=isd,ied+1
352  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
353  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
354  enddo
355  enddo
356 
357  if ( (cubed_sphere) .and. (defongrid==0) ) then
358  do j=js,je+1
359  do i=is,ie
360  dist = dx(i,j)
361  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
362  if (dist==0) vc(i,j) = 0.
363  enddo
364  enddo
365  do j=js,je
366  do i=is,ie+1
367  dist = dy(i,j)
368  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
369  if (dist==0) uc(i,j) = 0.
370  enddo
371  enddo
372  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
373  call fill_corners(uc, vc, npx, npy, vector=.true., cgrid=.true.)
374  do j=js,je
375  do i=is,ie+1
376  dist = dxc(i,j)
377  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
378  if (dist==0) v(i,j) = 0.
379  enddo
380  enddo
381  do j=js,je+1
382  do i=is,ie
383  dist = dyc(i,j)
384  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
385  if (dist==0) u(i,j) = 0.
386  enddo
387  enddo
388  call mp_update_dwinds(u, v, npx, npy, domain)
389  do j=js,je
390  do i=is,ie
391  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
392  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
393  dist = dya(i,j)
394  ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
395  if (dist==0) ua(i,j) = 0.
396  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
397  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
398  dist = dxa(i,j)
399  va(i,j) = (psi2 - psi1) / (dist)
400  if (dist==0) va(i,j) = 0.
401  enddo
402  enddo
403 
404  elseif ( (cubed_sphere) .and. (defongrid==1) ) then
405  do j=js,je+1
406  do i=is,ie
407  dist = dx(i,j)
408  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
409  if (dist==0) vc(i,j) = 0.
410  enddo
411  enddo
412  do j=js,je
413  do i=is,ie+1
414  dist = dy(i,j)
415  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
416  if (dist==0) uc(i,j) = 0.
417  enddo
418  enddo
419  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
420  call fill_corners(uc, vc, npx, npy, vector=.true., cgrid=.true.)
421  call ctoa(uc,vc,ua,va,dx, dy, dxc,dyc,dxa,dya,npx,npy,ng)
422  call atod(ua,va,u ,v ,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
423  ! call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd),v(isd,jsd), &
424  ! ua(isd,jsd),va(isd,jsd), uc(isd,jsd),vc(isd,jsd))
425  elseif ( (cubed_sphere) .and. (defongrid==2) ) then
426  do j=js2,je2
427  do i=is2,ie2+1
428  dist = dxc(i,j)
429  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
430  if (dist==0) v(i,j) = 0.
431  enddo
432  enddo
433  do j=js2,je2+1
434  do i=is2,ie2
435  dist = dyc(i,j)
436  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
437  if (dist==0) u(i,j) = 0.
438  enddo
439  enddo
440  call mp_update_dwinds(u, v, npx, npy, domain)
441  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
442  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
443  elseif ( (cubed_sphere) .and. (defongrid==3) ) then
444  do j=js,je
445  do i=is,ie
446  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
447  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
448  dist = dya(i,j)
449  ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
450  if (dist==0) ua(i,j) = 0.
451  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
452  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
453  dist = dxa(i,j)
454  va(i,j) = (psi2 - psi1) / (dist)
455  if (dist==0) va(i,j) = 0.
456  enddo
457  enddo
458  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
459  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
460  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested,domain)
461  elseif ( (latlon) .or. (defongrid==4) ) then
462 
463  do j=js,je
464  do i=is,ie
465  ua(i,j) = ubar * ( cos(agrid(i,j,2))*cos(alpha) + &
466  sin(agrid(i,j,2))*cos(agrid(i,j,1))*sin(alpha) )
467  va(i,j) = -ubar * sin(agrid(i,j,1))*sin(alpha)
468  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
469  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
470  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
471  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
472  if (cubed_sphere) call rotate_winds(ua(i,j), va(i,j), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
473 
474  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
475  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
476  dist = dya(i,j)
477  if ( (tile==1) .and.(i==1) ) print*, ua(i,j), -1.0 * (psi2 - psi1) / (dist)
478 
479  enddo
480  enddo
481  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
482  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
483  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
484  elseif ( (latlon) .or. (defongrid==5) ) then
485 ! SJL mods:
486 ! v-wind:
487  do j=js2,je2
488  do i=is2,ie2+1
489  p1(:) = grid(i ,j ,1:2)
490  p2(:) = grid(i,j+1 ,1:2)
491  call mid_pt_sphere(p1, p2, pt)
492  call get_unit_vect2 (p1, p2, e2)
493  call get_latlon_vector(pt, ex, ey)
494  utmp = ubar * ( cos(pt(2))*cos(alpha) + &
495  sin(pt(2))*cos(pt(1))*sin(alpha) )
496  vtmp = -ubar * sin(pt(1))*sin(alpha)
497  v(i,j) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
498  enddo
499  enddo
500 ! D grid u-wind:
501  do j=js2,je2+1
502  do i=is2,ie2
503  p1(:) = grid(i ,j ,1:2)
504  p2(:) = grid(i+1,j ,1:2)
505  call mid_pt_sphere(p1, p2, pt)
506  call get_unit_vect2 (p1, p2, e1)
507  call get_latlon_vector(pt, ex, ey)
508  utmp = ubar * ( cos(pt(2))*cos(alpha) + &
509  sin(pt(2))*cos(pt(1))*sin(alpha) )
510  vtmp = -ubar * sin(pt(1))*sin(alpha)
511  u(i,j) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
512  enddo
513  enddo
514 
515  call mp_update_dwinds(u, v, npx, npy, domain)
516  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
517  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
518  else
519  !print*, 'Choose an appropriate grid to define the winds on'
520  !stop
521  endif
522 
523  end subroutine init_winds
524 !
525 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
526 !-------------------------------------------------------------------------------
527 
528 !-------------------------------------------------------------------------------
529 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
530 ! init_case :: initialize the Williamson test cases:
531 ! case 1 (2-D advection of a cosine bell)
532 ! case 2 (Steady State Zonal Geostrophic Flow)
533 ! case 5 (Steady State Zonal Geostrophic Flow over Mountain)
534 ! case 6 (Rossby Wave-4 Case)
535 ! case 9 (Stratospheric Vortex Breaking Case)
536 !
537  subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
538  gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, &
539  dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, adiabatic, &
540  ks, npx_global, ptop, domain_in, tile_in, bd)
541 
542  type(fv_grid_bounds_type), intent(IN) :: bd
543  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
544  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
545  real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
546  real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
547  real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
548  real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
549 
550  real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
551 
552  real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
553  real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
554  real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
555  real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
556  real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
557 
558  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
559  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
560  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
561  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
562  real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:)
563  real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
564 
565  real , intent(inout) :: ak(npz+1)
566  real , intent(inout) :: bk(npz+1)
567 
568  integer, intent(IN) :: npx, npy, npz
569  integer, intent(IN) :: ng, ncnst, nwat
570  integer, intent(IN) :: ndims
571  integer, intent(IN) :: nregions
572 
573  real, intent(IN) :: dry_mass
574  logical, intent(IN) :: mountain
575  logical, intent(IN) :: moist_phys
576  logical, intent(IN) :: hydrostatic
577  logical, intent(IN) :: hybrid_z
578  logical, intent(IN) :: adiabatic
579  integer, intent(IN) :: ks
580 
581  type(fv_grid_type), target :: gridstruct
582  type(fv_flags_type), target, intent(IN) :: flagstruct
583 
584  integer, intent(IN) :: npx_global
585  integer, intent(IN), target :: tile_in
586  real, intent(INOUT) :: ptop
587 
588  type(domain2d), intent(IN), target :: domain_in
589 
590  real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
591  real :: tmp1(1 :npx ,1 :npy ,1:nregions)
592 
593  real(kind=R_GRID) :: p0(2) ! Temporary Point
594  real(kind=R_GRID) :: p1(2) ! Temporary Point
595  real(kind=R_GRID) :: p2(2) ! Temporary Point
596  real(kind=R_GRID) :: p3(2) ! Temporary Point
597  real(kind=R_GRID) :: p4(2) ! Temporary Point
598  real(kind=R_GRID) :: pa(2) ! Temporary Point
599  real(kind=R_GRID) :: pb(2) ! Temporary Point
600  real(kind=R_GRID) :: pcen(2) ! Temporary Point
601  real(kind=R_GRID) :: e1(3), e2(3), e3(3), ex(3), ey(3)
602  real :: dist, r, r1, r2, r0, omg, a, b, c
603  integer :: i,j,k,nreg,z,zz
604  integer :: i0,j0,n0, nt
605  real :: utmp,vtmp,ftmp
606  real :: rk
607 
608  integer, parameter :: jm = 5761
609  real :: ll_phi(jm)
610  real :: ll_u(jm)
611  real :: ll_j(jm)
612  real :: cose(jm)
613  real :: sine(jm)
614  real :: cosp(jm)
615  real :: ddeg, deg, ddp, dp, ph5
616  real :: myb, myc, yy
617  integer :: jj,jm1
618 
619  real :: vtx, p, w_p
620  real :: x1,y1,z1,x2,y2,z2,ang
621 
622  integer :: initwindscase
623 
624  real :: dummy
625  real :: ftop
626  real :: v1,v2
627  real :: m=1
628  real :: n=1
629  real :: l1_norm
630  real :: l2_norm
631  real :: linf_norm
632  real :: pmin, pmin1
633  real :: pmax, pmax1
634  real :: grad(bd%isd:bd%ied ,bd%jsd:bd%jed,2)
635  real :: div0(bd%isd:bd%ied ,bd%jsd:bd%jed )
636  real :: vor0(bd%isd:bd%ied ,bd%jsd:bd%jed )
637  real :: divg(bd%isd:bd%ied ,bd%jsd:bd%jed )
638  real :: vort(bd%isd:bd%ied ,bd%jsd:bd%jed )
639  real :: ztop, rgrav, p00, pturb, zmid, pk0, t00
640  real :: dz1(npz), ppt(npz)
641  real :: ze1(npz+1), pe1(npz+1)
642 
643  integer :: nlon,nlat
644  character(len=80) :: oflnm, hgtflnm
645  integer :: is2, ie2, js2, je2
646 
647  real :: psi(bd%isd:bd%ied,bd%jsd:bd%jed)
648  real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1)
649  real :: psi1, psi2
650 
651 ! Baroclinic Test Case 12
652  real :: eta(npz), eta_0, eta_s, eta_t
653  real :: eta_v(npz), press, anti_rot
654  real :: t_0, t_mean, delta_t, lapse_rate, n2, zeta, s0
655  real :: pt1,pt2,pt3,pt4,pt5,pt6, pt7, pt8, pt9, u1, pt0
656  real :: uu1, uu2, uu3, vv1, vv2, vv3
657 ! real wbuffer(npx+1,npz)
658 ! real sbuffer(npy+1,npz)
659  real wbuffer(npy+2,npz)
660  real sbuffer(npx+2,npz)
661 
662  real :: gz(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1), zt, zdist
663  real :: zvir
664 
665  integer :: cl, cl2
666 
667 ! Super-Cell
668  real :: us0 = 30.
669  real, dimension(npz):: pk1, ts1, qs1, uz1, zs1, dudz
670  real:: zm, zc
671  real(kind=R_GRID):: pp0(2) ! center position
672 
673 !Test case 35
674  real:: cs_m3
675 !Test case 51
676  real :: omega0, k_cell, z0, h, px
677  real :: d1, d2, p1p(2), rt, s
678  real :: wind_alpha, period, h0, rm, zp3(3), dz3(3), k0, lp
679 
680 
681 !Test case 55
682  real, dimension(npz+1) :: pe0, gz0, ue, ve, we, pte, qe
683  real :: d, cor, exppr, exppz, gamma, ts0, q00, exponent, ztrop, height, zp, rp
684  real :: qtrop, ttrop, zq1, zq2
685  real :: dum, dum1, dum2, dum3, dum4, dum5, dum6, ptmp, uetmp, vetmp
686  real :: pe_u(bd%is:bd%ie,npz+1,bd%js:bd%je+1)
687  real :: pe_v(bd%is:bd%ie+1,npz+1,bd%js:bd%je)
688  real :: ps_u(bd%is:bd%ie,bd%js:bd%je+1)
689  real :: ps_v(bd%is:bd%ie+1,bd%js:bd%je)
690 
691 
692  real :: dz, zetam
693 
694  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
695  real(kind=R_GRID), pointer, dimension(:,:) :: area
696  real, pointer, dimension(:,:) :: rarea, fc, f0
697  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
698  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
699  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
700 
701  logical, pointer :: cubed_sphere, latlon
702 
703  type(domain2d), pointer :: domain
704  integer, pointer :: tile
705 
706  logical, pointer :: have_south_pole, have_north_pole
707 
708  integer, pointer :: ntiles_g
709  real, pointer :: acapn, acaps, globalarea
710 
711  is = bd%is
712  ie = bd%ie
713  js = bd%js
714  je = bd%je
715  isd = bd%isd
716  ied = bd%ied
717  jsd = bd%jsd
718  jed = bd%jed
719 
720  grid => gridstruct%grid_64
721  agrid=> gridstruct%agrid_64
722 
723  area => gridstruct%area_64
724  rarea => gridstruct%rarea
725 
726  fc => gridstruct%fC
727  f0 => gridstruct%f0
728 
729  ee1 => gridstruct%ee1
730  ee2 => gridstruct%ee2
731  ew => gridstruct%ew
732  es => gridstruct%es
733  en1 => gridstruct%en1
734  en2 => gridstruct%en2
735 
736  dx => gridstruct%dx
737  dy => gridstruct%dy
738  dxa => gridstruct%dxa
739  dya => gridstruct%dya
740  rdxa => gridstruct%rdxa
741  rdya => gridstruct%rdya
742  dxc => gridstruct%dxc
743  dyc => gridstruct%dyc
744 
745  cubed_sphere => gridstruct%cubed_sphere
746  latlon => gridstruct%latlon
747 
748  domain => domain_in
749  tile => tile_in
750 
751  have_south_pole => gridstruct%have_south_pole
752  have_north_pole => gridstruct%have_north_pole
753 
754  ntiles_g => gridstruct%ntiles_g
755  acapn => gridstruct%acapN
756  acaps => gridstruct%acapS
757  globalarea => gridstruct%globalarea
758 
759  if (gridstruct%nested) then
760  is2 = isd
761  ie2 = ied
762  js2 = jsd
763  je2 = jed
764  else
765  is2 = is
766  ie2 = ie
767  js2 = js
768  je2 = je
769  end if
770 
771  pe(:,:,:) = 0.0
772  pt(:,:,:) = 1.0
773  f0(:,:) = huge(dummy)
774  fc(:,:) = huge(dummy)
775  do j=jsd,jed+1
776  do i=isd,ied+1
777  fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
778  sin(grid(i,j,2))*cos(alpha) )
779  enddo
780  enddo
781  do j=jsd,jed
782  do i=isd,ied
783  f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
784  sin(agrid(i,j,2))*cos(alpha) )
785  enddo
786  enddo
787  call mpp_update_domains( f0, domain )
788  if (cubed_sphere) call fill_corners(f0, npx, npy, ydir)
789 
790  delp(isd:is-1,jsd:js-1,1:npz)=0.
791  delp(isd:is-1,je+1:jed,1:npz)=0.
792  delp(ie+1:ied,jsd:js-1,1:npz)=0.
793  delp(ie+1:ied,je+1:jed,1:npz)=0.
794 
795 #if defined(SW_DYNAMICS)
796  select case (test_case)
797  case(-2)
798  case(-1)
799  ubar = (2.0*pi*radius)/(12.0*86400.0)
800  gh0 = 2.94e4
801  phis = 0.0
802  do j=js,je
803  do i=is,ie
804  delp(i,j,1) = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
805  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
806  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
807  enddo
808  enddo
809  call init_winds(ubar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
810 
811 ! Test Divergence operator at cell centers
812  do j=js,je
813  do i=is,ie
814  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
815  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
816  if ( (tile==1) .and. (i==1) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
817  enddo
818  enddo
819 ! Test Vorticity operator at cell centers
820  do j=js,je
821  do i=is,ie
822  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
823  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
824  enddo
825  enddo
826  div0(:,:) = 1.e-20
827  ! call mpp_update_domains( div0, domain )
828  ! call mpp_update_domains( vor0, domain )
829  ! call mpp_update_domains( divg, domain )
830  ! call mpp_update_domains( vort, domain )
831  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
832  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
833  200 format(i4.4,'x',i4.4,'x',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
834  201 format(' ',a,e21.14,' ',e21.14)
835  202 format(' ',a,i4.4,'x',i4.4,'x',i4.4)
836  if ( is_master() ) then
837  write(*,*) ' Error Norms of Analytical Divergence field C-Winds initialized'
838  write(*,201) 'Divergence MAX error : ', pmax
839  write(*,201) 'Divergence MIN error : ', pmin
840  write(*,201) 'Divergence L1_norm : ', l1_norm
841  write(*,201) 'Divergence L2_norm : ', l2_norm
842  write(*,201) 'Divergence Linf_norm : ', linf_norm
843  endif
844 
845  call init_winds(ubar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
846 ! Test Divergence operator at cell centers
847  do j=js,je
848  do i=is,ie
849  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
850  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
851  if ( (tile==1) .and. (i==1) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
852  enddo
853  enddo
854 ! Test Vorticity operator at cell centers
855  do j=js,je
856  do i=is,ie
857  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
858  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
859  enddo
860  enddo
861  ua0 = ua
862  va0 = va
863  div0(:,:) = 1.e-20
864  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
865  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
866  if ( is_master() ) then
867  write(*,*) ' Error Norms of Analytical Divergence field A-Winds initialized'
868  write(*,201) 'Divergence MAX error : ', pmax
869  write(*,201) 'Divergence MIN error : ', pmin
870  write(*,201) 'Divergence L1_norm : ', l1_norm
871  write(*,201) 'Divergence L2_norm : ', l2_norm
872  write(*,201) 'Divergence Linf_norm : ', linf_norm
873  endif
874 
875  call init_winds(ubar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
876  !call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd,1),v(isd,jsd,1), &
877  ! ua(isd,jsd,1),va(isd,jsd,1), uc(isd,jsd,1),vc(isd,jsd,1))
878 ! Test Divergence operator at cell centers
879  do j=js,je
880  do i=is,ie
881  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
882  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
883  if ( (tile==1) .and. ((i==1) .or.(i==npx-1)) ) write(*,200) i,j,tile, divg(i,j), uc(i,j,1), uc(i+1,j,1), vc(i,j,1), vc(i,j+1,1)
884  enddo
885  enddo
886 ! Test Vorticity operator at cell centers
887  do j=js,je
888  do i=is,ie
889  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
890  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
891  enddo
892  enddo
893  div0(:,:) = 1.e-20
894  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
895  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
896  if ( is_master() ) then
897  write(*,*) ' Error Norms of Analytical Divergence field D-Winds initialized'
898  write(*,201) 'Divergence MAX error : ', pmax
899  write(*,201) 'Divergence MIN error : ', pmin
900  write(*,201) 'Divergence L1_norm : ', l1_norm
901  write(*,201) 'Divergence L2_norm : ', l2_norm
902  write(*,201) 'Divergence Linf_norm : ', linf_norm
903  endif
904 
905  call mp_stop()
906  stop
907  case(0)
908  do j=jsd,jed
909  do i=isd,ied
910 
911  x1 = agrid(i,j,1)
912  y1 = agrid(i,j,2)
913  z1 = radius
914 
915  p = p0_c0 * cos(y1)
916  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
917  w_p = 0.0
918  if (p /= 0.0) w_p = vtx/p
919  delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*0.0) )
920  ua(i,j,1) = w_p*(sin(lat0)*cos(agrid(i,j,2)) + cos(lat0)*cos(agrid(i,j,1) - lon0)*sin(agrid(i,j,2)))
921  va(i,j,1) = w_p*cos(lat0)*sin(agrid(i,j,1) - lon0)
922  ua(i,j,1) = ua(i,j,1)*radius/86400.0
923  va(i,j,1) = va(i,j,1)*radius/86400.0
924 
925  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
926  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
927  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
928  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
929  if (cubed_sphere) call rotate_winds(ua(i,j,1),va(i,j,1), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
930 
931  enddo
932  enddo
933  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
934  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain)
935  call mp_update_dwinds(u, v, npx, npy, npz, domain)
936  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
937  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
938  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
939  initwindscase=initwindscase0
940  case(1)
941  ubar = (2.0*pi*radius)/(12.0*86400.0)
942  gh0 = 1.0
943  phis = 0.0
944  r0 = radius/3. !RADIUS radius/3.
945  p1(1) = pi/2. + pi_shift
946  p1(2) = 0.
947  do j=jsd,jed
948  do i=isd,ied
949  p2(1) = agrid(i,j,1)
950  p2(2) = agrid(i,j,2)
951  r = great_circle_dist( p1, p2, radius )
952  if (r < r0) then
953  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
954  else
955  delp(i,j,1) = phis(i,j)
956  endif
957  enddo
958  enddo
959  initwindscase=initwindscase1
960  case(2)
961 #ifdef TEST_TRACER
962 !!$ do j=js2,je2
963 !!$ do i=is2,ie2
964 !!$ q(i,j,1,:) = 1.e-3*cos(agrid(i,j,2))!*(1.+cos(agrid(i,j,1)))
965 !!$ enddo
966 !!$ enddo
967  gh0 = 1.0e-6
968  r0 = radius/3. !RADIUS radius/3.
969  p1(2) = 35./180.*pi !0.
970  p1(1) = pi/4.!pi/2.
971  do j=jsd,jed
972  do i=isd,ied
973  p2(1) = agrid(i,j,1)
974  p2(2) = agrid(i,j,2)
975  r = great_circle_dist( p1, p2, radius )
976  if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.)) then
977  !q(i,j,k,1) = max(gh0*0.5*(1.0+cos(PI*r/r0))*exp(real(k-npz)),0.)
978  q(i,j,1,1) = gh0
979  else
980  q(i,j,1,1) = 0.
981  endif
982  enddo
983  enddo
984 #endif
985  ubar = (2.0*pi*radius)/(12.0*86400.0)
986  gh0 = 2.94e4
987  phis = 0.0
988  do j=js2,je2
989  do i=is2,ie2
990 ! do j=jsd,jed
991 ! do i=isd,ied
992 #ifdef FIVE_AVG
993  pt5 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
994  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
995  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
996  pt1 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
997  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
998  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0
999  pt2 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1000  ( -1.*cos(grid(i+1,j ,1))*cos(grid(i+1,j ,2))*sin(alpha) + &
1001  sin(grid(i+1,j ,2))*cos(alpha) ) ** 2.0
1002  pt3 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1003  ( -1.*cos(grid(i+1,j+1,1))*cos(grid(i+1,j+1,2))*sin(alpha) + &
1004  sin(grid(i+1,j+1,2))*cos(alpha) ) ** 2.0
1005  pt4 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1006  ( -1.*cos(grid(i,j+1,1))*cos(grid(i,j+1,2))*sin(alpha) + &
1007  sin(grid(i,j+1,2))*cos(alpha) ) ** 2.0
1008  delp(i,j,1) = (0.25*(pt1+pt2+pt3+pt4) + 3.*pt5) / 4.
1009 #else
1010  delp(i,j,1) = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1011  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1012  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
1013 #endif
1014  enddo
1015  enddo
1016  initwindscase=initwindscase2
1017  case(3)
1018 !----------------------------
1019 ! Non-rotating potential flow
1020 !----------------------------
1021 #ifdef NO_WIND
1022  ubar = 0.
1023 #else
1024  ubar = 40.
1025 #endif
1026  gh0 = 1.0e3 * grav
1027  phis = 0.0
1028  r0 = radius/3. !RADIUS radius/3.
1029  p1(1) = pi*1.5
1030  p1(2) = 0.
1031  do j=jsd,jed
1032  do i=isd,ied
1033  p2(1) = agrid(i,j,1)
1034  p2(2) = agrid(i,j,2)
1035  r = great_circle_dist( p1, p2, radius )
1036  if (r < r0) then
1037  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
1038  else
1039  delp(i,j,1) = phis(i,j)
1040  endif
1041 ! Add a constant:
1042  delp(i,j,1) = delp(i,j,1) + grav*2.e3
1043  enddo
1044  enddo
1045 
1046 #ifdef NO_WIND
1047  u = 0.; v = 0.
1048  f0 = 0.; fc = 0.
1049 #else
1050 
1051  do j=js,je
1052  do i=is,ie+1
1053  p1(:) = grid(i ,j ,1:2)
1054  p2(:) = grid(i,j+1 ,1:2)
1055  call mid_pt_sphere(p1, p2, p3)
1056  call get_unit_vect2(p1, p2, e2)
1057  call get_latlon_vector(p3, ex, ey)
1058  utmp = ubar * cos(p3(2))
1059  vtmp = 0.
1060  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1061  enddo
1062  enddo
1063  do j=js,je+1
1064  do i=is,ie
1065  p1(:) = grid(i, j,1:2)
1066  p2(:) = grid(i+1,j,1:2)
1067  call mid_pt_sphere(p1, p2, p3)
1068  call get_unit_vect2(p1, p2, e1)
1069  call get_latlon_vector(p3, ex, ey)
1070  utmp = ubar * cos(p3(2))
1071  vtmp = 0.
1072  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1073  enddo
1074  enddo
1075 
1076  anti_rot = -ubar/ radius
1077  do j=jsd,jed+1
1078  do i=isd,ied+1
1079  fc(i,j) = 2.*anti_rot*sin(grid(i,j,2))
1080  enddo
1081  enddo
1082  do j=jsd,jed
1083  do i=isd,ied
1084  f0(i,j) = 2.*anti_rot*sin(agrid(i,j,2))
1085  enddo
1086  enddo
1087 #endif
1088  initwindscase= -1
1089 
1090  case(4)
1091 
1092 !----------------------------
1093 ! Tropical cyclones
1094 !----------------------------
1095 ! f0 = 0.; fC = 0. ! non-rotating planet setup
1096  u = 0.
1097  v = 0.
1098  phis = 0.0 ! flat terrain
1099 
1100  ubar = 50. ! maxmium wind speed (m/s)
1101  r0 = 250.e3 ! RADIUS of the maximum wind of the Rankine vortex
1102  gh0 = grav * 1.e3
1103 
1104  do j=jsd,jed
1105  do i=isd,ied
1106  delp(i,j,1) = gh0
1107  enddo
1108  enddo
1109 
1110 ! ddeg = 2.*r0/radius ! no merger
1111  ddeg = 1.80*r0/radius ! merged
1112 
1113  p1(1) = pi*1.5 - ddeg
1114  p1(2) = pi/18. ! 10 N
1115  call rankine_vortex(ubar, r0, p1, u, v, grid)
1116 
1117  p2(1) = pi*1.5 + ddeg
1118  p2(2) = pi/18. ! 10 N
1119  call rankine_vortex(ubar, r0, p2, u, v, grid)
1120 
1121 #ifndef SINGULAR_VORTEX
1122 !-----------
1123 ! Anti-pole:
1124 !-----------
1125  ubar = -ubar
1126  call latlon2xyz(p1, e1)
1127  do i=1,3
1128  e1(i) = -e1(i)
1129  enddo
1130  call cart_to_latlon(1, e1, p3(1), p3(2))
1131  call rankine_vortex(ubar, r0, p3, u, v, grid)
1132 
1133  call latlon2xyz(p2, e1)
1134  do i=1,3
1135  e1(i) = -e1(i)
1136  enddo
1137  call cart_to_latlon(1, e1, p4(1), p4(2))
1138  call rankine_vortex(ubar, r0, p4, u, v, grid)
1139 #endif
1140  call mp_update_dwinds(u, v, npx, npy, npz, domain)
1141  initwindscase=-1 ! do nothing
1142 
1143  case(5)
1144 
1145  ubar = 20.
1146  gh0 = 5960.*grav
1147  phis = 0.0
1148  r0 = pi/9.
1149  p1(1) = pi/2.
1150  p1(2) = pi/6.
1151  do j=js2,je2
1152  do i=is2,ie2
1153  p2(1) = agrid(i,j,1)
1154  p2(2) = agrid(i,j,2)
1155  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1156  r = sqrt(r)
1157  phis(i,j) = 2000.0*grav*(1.0-(r/r0))
1158  enddo
1159  enddo
1160  do j=js2,je2
1161  do i=is2,ie2
1162  delp(i,j,1) =gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1163  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1164  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2 - phis(i,j)
1165  enddo
1166  enddo
1167  initwindscase=initwindscase5
1168  case(6)
1169  gh0 = 8.e3*grav
1170  r = 4.
1171  omg = 7.848e-6
1172  rk = 7.848e-6
1173  phis = 0.0
1174  do j=js,je
1175  do i=is,ie
1176  a = 0.5*omg*(2.*omega+omg)*(cos(agrid(i,j,2))**2) + &
1177  0.25*rk*rk*(cos(agrid(i,j,2))**(r+r)) * &
1178  ( (r+1)*(cos(agrid(i,j,2))**2) + (2.*r*r-r-2.) - &
1179  2.*(r*r)*cos(agrid(i,j,2))**(-2.) )
1180  b = (2.*(omega+omg)*rk / ((r+1)*(r+2))) * (cos(agrid(i,j,2))**r) * &
1181  ( (r*r+2.*r+2.) - ((r+1.)*cos(agrid(i,j,2)))**2 )
1182  c = 0.25*rk*rk*(cos(agrid(i,j,2))**(2.*r)) * ( &
1183  (r+1) * (cos(agrid(i,j,2))**2.) - (r+2.) )
1184  delp(i,j,1) =gh0 + radius*radius*(a+b*cos(r*agrid(i,j,1))+c*cos(2.*r*agrid(i,j,1)))
1185  delp(i,j,1) = delp(i,j,1) - phis(i,j)
1186  enddo
1187  enddo
1188  do j=js,je
1189  do i=is,ie+1
1190  p1(:) = grid(i ,j ,1:2)
1191  p2(:) = grid(i,j+1 ,1:2)
1192  call mid_pt_sphere(p1, p2, p3)
1193  call get_unit_vect2(p1, p2, e2)
1194  call get_latlon_vector(p3, ex, ey)
1195  utmp = radius*omg*cos(p3(2)) + &
1196  radius*rk*(cos(p3(2))**(r-1))*(r*sin(p3(2))**2-cos(p3(2))**2)*cos(r*p3(1))
1197  vtmp = -radius*rk*r*sin(p3(2))*sin(r*p3(1))*cos(p3(2))**(r-1)
1198  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1199  enddo
1200  enddo
1201  do j=js,je+1
1202  do i=is,ie
1203  p1(:) = grid(i, j,1:2)
1204  p2(:) = grid(i+1,j,1:2)
1205  call mid_pt_sphere(p1, p2, p3)
1206  call get_unit_vect2(p1, p2, e1)
1207  call get_latlon_vector(p3, ex, ey)
1208  utmp = radius*omg*cos(p3(2)) + &
1209  radius*rk*(cos(p3(2))**(r-1))*(r*sin(p3(2))**2-cos(p3(2))**2)*cos(r*p3(1))
1210  vtmp = -radius*rk*r*sin(p3(2))*sin(r*p3(1))*cos(p3(2))**(r-1)
1211  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1212  enddo
1213  enddo
1214  call mp_update_dwinds(u, v, npx, npy, npz, domain)
1215  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
1216  !call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
1217  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
1218  initwindscase=initwindscase6
1219  case(7)
1220 ! Barotropically unstable jet
1221  gh0 = 10.e3*grav
1222  phis = 0.0
1223  r0 = radius/12.
1224  p2(1) = pi/2.
1225  p2(2) = pi/4.
1226  do j=js,je
1227  do i=is,ie
1228 ! ftmp = gh0
1229 ! 9-point average:
1230 ! 9 4 8
1231 !
1232 ! 5 1 3
1233 !
1234 ! 6 2 7
1235  pt1 = gh_jet(npy, agrid(i,j,2))
1236  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), pa)
1237  pt2 = gh_jet(npy, pa(2))
1238  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), pa)
1239  pt3 = gh_jet(npy, pa(2))
1240  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), pa)
1241  pt4 = gh_jet(npy, pa(2))
1242  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), pa)
1243  pt5 = gh_jet(npy, pa(2))
1244  pt6 = gh_jet(npy, grid(i, j, 2))
1245  pt7 = gh_jet(npy, grid(i+1,j, 2))
1246  pt8 = gh_jet(npy, grid(i+1,j+1,2))
1247  pt9 = gh_jet(npy, grid(i ,j+1,2))
1248  ftmp = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1249 #ifndef NEW_PERT
1250  delp(i,j,1) = ftmp + 120.*grav*cos(agrid(i,j,2)) * &
1251  exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1252 ! phis(i,j) = ftmp
1253 ! delp(i,j,1) = 10.E3*grav + 120.*grav*cos(agrid(i,j,2)) * &
1254 ! exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1255 #else
1256 ! Using great circle dist:
1257  p1(:) = agrid(i,j,1:2)
1258  delp(i,j,1) = ftmp
1259  r = great_circle_dist(p1, p2, radius)
1260  if ( r < 3.*r0 ) then
1261  delp(i,j,1) = delp(i,j,1) + 1000.*grav*exp(-(r/r0)**2)
1262  endif
1263 #endif
1264  enddo
1265  enddo
1266 
1267 ! v-wind:
1268  do j=js,je
1269  do i=is,ie+1
1270  p2(:) = grid(i,j+1,1:2)
1271  vv1 = u_jet(p2(2))*(ee2(2,i,j+1)*cos(p2(1)) - ee2(1,i,j+1)*sin(p2(1)))
1272  p1(:) = grid(i,j,1:2)
1273  vv3 = u_jet(p1(2))*(ee2(2,i,j)*cos(p1(1)) - ee2(1,i,j)*sin(p1(1)))
1274 ! Mid-point:
1275  call mid_pt_sphere(p1, p2, pa)
1276  vv2 = u_jet(pa(2))*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1277 ! 3-point average:
1278  v(i,j,1) = 0.25*(vv1 + 2.*vv2 + vv3)
1279 ! v(i,j,1) = vv2
1280  enddo
1281  enddo
1282 ! U-wind:
1283  do j=js,je+1
1284  do i=is,ie
1285  p1(:) = grid(i,j,1:2)
1286  uu1 = u_jet(p1(2))*(ee1(2,i,j)*cos(p1(1)) - ee1(1,i,j)*sin(p1(1)))
1287  p2(:) = grid(i+1,j,1:2)
1288  uu3 = u_jet(p2(2))*(ee1(2,i+1,j)*cos(p2(1)) - ee1(1,i+1,j)*sin(p2(1)))
1289 ! Mid-point:
1290  call mid_pt_sphere(p1, p2, pa)
1291  uu2 = u_jet(pa(2))*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1292 ! 3-point average:
1293  u(i,j,1) = 0.25*(uu1 + 2.*uu2 + uu3)
1294 ! u(i,j,1) = uu2
1295  enddo
1296  enddo
1297  initwindscase=initwindscase6 ! shouldn't do anything with this
1298 !initialize tracer with shallow-water PV
1299  !Compute vorticity
1300  call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,1), dx, dy, rarea)
1301  do j=jsd,jed+1
1302  do i=isd,ied+1
1303  fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
1304  sin(grid(i,j,2))*cos(alpha) )
1305  enddo
1306  enddo
1307  do j=jsd,jed
1308  do i=isd,ied
1309  f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
1310  sin(agrid(i,j,2))*cos(alpha) )
1311  enddo
1312  enddo
1313  call mpp_update_domains( f0, domain )
1314  if (cubed_sphere) call fill_corners(f0, npx, npy, ydir)
1315  do j=js,je
1316  do i=is,ie
1317  q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) / delp(i,j,npz) * 1.e6 ! PVU
1318  !q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) * grav / delp(i,j,npz)
1319  enddo
1320  enddo
1321 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
1322 
1323  case(8)
1324 #ifdef USE_OLD
1325 !----------------------------
1326 ! Non-rotating potential flow
1327 !----------------------------
1328  gh0 = 5960.*grav
1329  phis = 0.0
1330  r0 = pi/9.
1331  p1(1) = pi/2.
1332  p1(2) = pi/6.
1333  do j=js,je
1334  do i=is,ie
1335  p2(1) = agrid(i,j,1)
1336  p2(2) = agrid(i,j,2)
1337  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1338  r = sqrt(r)
1339  phis(i,j) = 2000.0*grav*(1.0-(r/r0))
1340  enddo
1341  enddo
1342  do j=js,je
1343  do i=is,ie
1344  delp(i,j,1) = gh0
1345  enddo
1346  enddo
1347  u = 0.; v = 0.
1348  f0 = 0.; fc = 0.
1349  initwindscase= -1
1350 #endif
1351 !----------------------------
1352 ! Soliton twin-vortex
1353 !----------------------------
1354  if ( is_master() ) write(*,*) 'Initialzing case-8: soliton twin cycolne...'
1355  f0 = 0.; fc = 0. ! non-rotating planet setup
1356  phis = 0.0 ! flat terrain
1357  gh0 = 5.e3*grav
1358  do j=js,je
1359  do i=is,ie
1360  delp(i,j,1) = gh0
1361  enddo
1362  enddo
1363 
1364 ! Initiate the westerly-wind-burst:
1365  ubar = soliton_umax
1366  r0 = soliton_size
1367 !!$ ubar = 200. ! maxmium wind speed (m/s)
1368 !!$ r0 = 250.e3
1369 !!$ ubar = 50. ! maxmium wind speed (m/s)
1370 !!$ r0 = 750.e3
1371 ! #1 1: westerly
1372  p0(1) = pi*0.5
1373  p0(2) = 0.
1374 
1375  do j=js,je
1376  do i=is,ie+1
1377  p1(:) = grid(i ,j ,1:2)
1378  p2(:) = grid(i,j+1 ,1:2)
1379  call mid_pt_sphere(p1, p2, p3)
1380  r = great_circle_dist( p0, p3, radius )
1381  utmp = ubar*exp(-(r/r0)**2)
1382  call get_unit_vect2(p1, p2, e2)
1383  call get_latlon_vector(p3, ex, ey)
1384  v(i,j,1) = utmp*inner_prod(e2,ex)
1385  enddo
1386  enddo
1387  do j=js,je+1
1388  do i=is,ie
1389  p1(:) = grid(i, j,1:2)
1390  p2(:) = grid(i+1,j,1:2)
1391  call mid_pt_sphere(p1, p2, p3)
1392  r = great_circle_dist( p0, p3, radius )
1393  utmp = ubar*exp(-(r/r0)**2)
1394  call get_unit_vect2(p1, p2, e1)
1395  call get_latlon_vector(p3, ex, ey)
1396  u(i,j,1) = utmp*inner_prod(e1,ex)
1397  enddo
1398  enddo
1399 
1400 ! #1 2: easterly
1401  p0(1) = p0(1) + pi
1402  p0(2) = 0.
1403 
1404  do j=js,je
1405  do i=is,ie+1
1406  p1(:) = grid(i ,j ,1:2)
1407  p2(:) = grid(i,j+1 ,1:2)
1408  call mid_pt_sphere(p1, p2, p3)
1409  r = great_circle_dist( p0, p3, radius )
1410  utmp = ubar*exp(-(r/r0)**2)
1411  call get_unit_vect2(p1, p2, e2)
1412  call get_latlon_vector(p3, ex, ey)
1413  v(i,j,1) = v(i,j,1) - utmp*inner_prod(e2,ex)
1414  enddo
1415  enddo
1416  do j=js,je+1
1417  do i=is,ie
1418  p1(:) = grid(i, j,1:2)
1419  p2(:) = grid(i+1,j,1:2)
1420  call mid_pt_sphere(p1, p2, p3)
1421  r = great_circle_dist( p0, p3, radius )
1422  utmp = ubar*exp(-(r/r0)**2)
1423  call get_unit_vect2(p1, p2, e1)
1424  call get_latlon_vector(p3, ex, ey)
1425  u(i,j,1) = u(i,j,1) - utmp*inner_prod(e1,ex)
1426  enddo
1427  enddo
1428  initwindscase= -1
1429 
1430  case(9)
1431 #ifdef USE_OLD
1432  jm1 = jm - 1
1433  ddp = pi/dble(jm1)
1434  dp = ddp
1435  ll_j(1) = -0.5*pi
1436  do j=2,jm
1437  ph5 = -0.5*pi + (dble(j-1)-0.5)*ddp
1438  ll_j(j) = -0.5*pi + (dble(j-1)*ddp)
1439  sine(j) = sin(ph5)
1440  enddo
1441  cosp( 1) = 0.
1442  cosp(jm) = 0.
1443  do j=2,jm1
1444  cosp(j) = (sine(j+1)-sine(j)) / dp
1445  enddo
1446  do j=2,jm
1447  cose(j) = 0.5 * (cosp(j-1) + cosp(j))
1448  enddo
1449  cose(1) = cose(2)
1450  ddeg = 180./float(jm-1)
1451  do j=2,jm
1452  deg = -90. + (float(j-1)-0.5)*ddeg
1453  if (deg <= 0.) then
1454  ll_u(j) = -10.*(deg+90.)/90.
1455  elseif (deg <= 60.) then
1456  ll_u(j) = -10. + deg
1457  else
1458  ll_u(j) = 50. - (50./30.)* (deg - 60.)
1459  endif
1460  enddo
1461  ll_phi(1) = 6000. * grav
1462  do j=2,jm1
1463  ll_phi(j)=ll_phi(j-1) - dp*sine(j) * &
1464  (radius*2.*omega + ll_u(j)/cose(j))*ll_u(j)
1465  enddo
1466  phis = 0.0
1467  do j=js,je
1468  do i=is,ie
1469  do jj=1,jm1
1470  if ( (ll_j(jj) <= agrid(i,j,2)) .and. (agrid(i,j,2) <= ll_j(jj+1)) ) then
1471  delp(i,j,1)=0.5*(ll_phi(jj)+ll_phi(jj+1))
1472  endif
1473  enddo
1474  enddo
1475  enddo
1476 
1477  do j=js,je
1478  do i=is,ie
1479  if (agrid(i,j,2)*todeg <= 0.0) then
1480  ua(i,j,1) = -10.*(agrid(i,j,2)*todeg + 90.)/90.
1481  elseif (agrid(i,j,2)*todeg <= 60.0) then
1482  ua(i,j,1) = -10. + agrid(i,j,2)*todeg
1483  else
1484  ua(i,j,1) = 50. - (50./30.)* (agrid(i,j,2)*todeg - 60.)
1485  endif
1486  va(i,j,1) = 0.0
1487  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1488  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
1489  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
1490  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
1491  if (cubed_sphere) call rotate_winds(ua(i,j,1), va(i,j,1), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
1492  enddo
1493  enddo
1494 
1495  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
1496  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
1497  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
1498  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
1499  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain)
1500  call mp_update_dwinds(u, v, npx, npy, npz, domain)
1501  initwindscase=initwindscase9
1502 
1503 
1504  call get_case9_b(case9_b, agrid)
1505  aoft(:) = 0.0
1506 #else
1507 !----------------------------
1508 ! Soliton twin-vortex
1509 !----------------------------
1510  if ( is_master() ) write(*,*) 'Initialzing case-9: soliton cyclones...'
1511  f0 = 0.; fc = 0. ! non-rotating planet setup
1512  phis = 0.0 ! flat terrain
1513  gh0 = 5.e3*grav
1514  do j=js,je
1515  do i=is,ie
1516  delp(i,j,1) = gh0
1517  enddo
1518  enddo
1519 
1520 ! Initiate the westerly-wind-burst:
1521  ubar = soliton_umax
1522  r0 = soliton_size
1523 !!$ ubar = 200. ! maxmium wind speed (m/s)
1524 !!$ r0 = 250.e3
1525 !!$ ubar = 50. ! maxmium wind speed (m/s)
1526 !!$ r0 = 750.e3
1527  p0(1) = pi*0.5
1528  p0(2) = 0.
1529 
1530  do j=js,je
1531  do i=is,ie+1
1532  p1(:) = grid(i ,j ,1:2)
1533  p2(:) = grid(i,j+1 ,1:2)
1534  call mid_pt_sphere(p1, p2, p3)
1535  r = great_circle_dist( p0, p3, radius )
1536  utmp = ubar*exp(-(r/r0)**2)
1537  call get_unit_vect2(p1, p2, e2)
1538  call get_latlon_vector(p3, ex, ey)
1539  v(i,j,1) = utmp*inner_prod(e2,ex)
1540  enddo
1541  enddo
1542  do j=js,je+1
1543  do i=is,ie
1544  p1(:) = grid(i, j,1:2)
1545  p2(:) = grid(i+1,j,1:2)
1546  call mid_pt_sphere(p1, p2, p3)
1547  r = great_circle_dist( p0, p3, radius )
1548  utmp = ubar*exp(-(r/r0)**2)
1549  call get_unit_vect2(p1, p2, e1)
1550  call get_latlon_vector(p3, ex, ey)
1551  u(i,j,1) = utmp*inner_prod(e1,ex)
1552  enddo
1553  enddo
1554  initwindscase= -1
1555 #endif
1556  end select
1557 !--------------- end s-w cases --------------------------
1558 
1559 ! Copy 3D data for Shallow Water Tests
1560  do z=2,npz
1561  delp(:,:,z) = delp(:,:,1)
1562  enddo
1563 
1564  call mpp_update_domains( delp, domain )
1565  call mpp_update_domains( phis, domain )
1566  phi0 = delp
1567 
1568  call init_winds(ubar, u,v,ua,va,uc,vc, initwindscase, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
1569 ! Copy 3D data for Shallow Water Tests
1570  do z=2,npz
1571  u(:,:,z) = u(:,:,1)
1572  v(:,:,z) = v(:,:,1)
1573  enddo
1574 
1575  do j=js,je
1576  do i=is,ie
1577  ps(i,j) = delp(i,j,1)
1578  enddo
1579  enddo
1580 ! -------- end s-w section ----------------------------------
1581 #else
1582 
1583  if (test_case==10 .or. test_case==14) then
1584 
1585  alpha = 0.
1586 
1587  ! Initialize dry atmosphere
1588  q(:,:,:,:) = 3.e-6
1589  u(:,:,:) = 0.0
1590  v(:,:,:) = 0.0
1591  if (.not.hydrostatic) w(:,:,:)= 0.0
1592 
1593  if ( test_case==14 ) then
1594 ! Aqua-planet case: mean SLP=1.E5
1595  phis = 0.0
1596  call hydro_eq(npz, is, ie, js, je, ps, phis, 1.e5, &
1597  delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
1598  else
1599 ! Initialize topography
1600  gh0 = 5960.*grav
1601  phis = 0.0
1602  r0 = pi/9.
1603  p1(1) = pi/4.
1604  p1(2) = pi/6. + (7.5/180.0)*pi
1605  do j=js2,je2
1606  do i=is2,ie2
1607  p2(1) = agrid(i,j,1)
1608  p2(2) = agrid(i,j,2)
1609  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1610  r = sqrt(r)
1611  phis(i,j) = gh0*(1.0-(r/r0))
1612  enddo
1613  enddo
1614  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1615  delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1616  endif
1617 
1618  else if (test_case==11) then
1619  call surfdrv(npx, npy, gridstruct%grid_64, gridstruct%agrid_64, &
1620  gridstruct%area_64, dx, dy, dxa, dya, dxc, dyc, &
1621  gridstruct%sin_sg, phis, &
1622  flagstruct%stretch_fac, gridstruct%nested, &
1623  npx_global, domain, flagstruct%grid_number, bd, flagstruct%regional)
1624  call mpp_update_domains( phis, domain )
1625 
1626  if ( hybrid_z ) then
1627  rgrav = 1./ grav
1628  if( npz==32 ) then
1629  call compute_dz_l32( npz, ztop, dz1 )
1630  else
1631 ! call mpp_error(FATAL, 'You must provide a routine for hybrid_z')
1632  if ( is_master() ) write(*,*) 'Using const DZ'
1633  ztop = 45.e3 ! assuming ptop = 100.
1634  dz1(1) = ztop / real(npz)
1635  dz1(npz) = 0.5*dz1(1)
1636  do z=2,npz-1
1637  dz1(z) = dz1(1)
1638  enddo
1639  dz1(1) = 2.*dz1(2)
1640  endif
1641 
1642  call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
1643  phis, ze0, delz)
1644 ! call prt_maxmin('ZE0', ze0, is, ie, js, je, 0, npz, 1.E-3)
1645 ! call prt_maxmin('DZ0', delz, is, ie, js, je, 0, npz, 1. )
1646  endif
1647 
1648 ! Initialize dry atmosphere
1649  u = 0.
1650  v = 0.
1651  q(:,:,:,:) = 0.
1652  q(:,:,:,1) = 3.e-6
1653 
1654  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1655  delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1656 
1657  else if ( (test_case==12) .or. (test_case==13) ) then
1658 
1659 #ifdef HIWPP_TRACER
1660  if (is_master()) print*, 'TEST TRACER enabled for this test case'
1661 #ifdef HIWPP
1662  call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
1663  ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
1664 #else
1665  !For consistency with earlier single-grid simulations use gh0 = 1.0e-6 and p1(1) = 195.*pi/180.
1666  q(:,:,:,:) = 0.
1667  gh0 = 1.0e-3
1668  r0 = radius/3. !RADIUS radius/3.
1669  p1(2) = 51.*pi/180.
1670  p1(1) = 205.*pi/180. !231.*pi/180.
1671  do k=1,npz
1672  do j=jsd,jed
1673  do i=isd,ied
1674  p2(1) = agrid(i,j,1)
1675  p2(2) = agrid(i,j,2)
1676  r = great_circle_dist( p1, p2, radius )
1677  if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.) .and. k > 16) then
1678  q(i,j,k,1) = gh0
1679  else
1680  q(i,j,k,1) = 0.
1681  endif
1682  enddo
1683  enddo
1684  enddo
1685 #endif
1686 
1687 #else
1688 
1689  q(:,:,:,:) = 0.
1690 
1691 #ifdef HIWPP
1692 
1693  cl = get_tracer_index(model_atmos, 'cl')
1694  cl2 = get_tracer_index(model_atmos, 'cl2')
1695  if (cl > 0 .and. cl2 > 0) then
1696  call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
1697  q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2))
1698  call mpp_update_domains(q,domain)
1699  endif
1700 
1701 #endif
1702 #endif
1703  ! Initialize surface Pressure
1704  ps(:,:) = 1.e5
1705  ! Initialize detla-P
1706 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,ak,ps,bk)
1707  do z=1,npz
1708  do j=js,je
1709  do i=is,ie
1710  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
1711  enddo
1712  enddo
1713  enddo
1714 
1715 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,ptop,peln,pk,delp)
1716  do j=js,je
1717  do i=is, ie
1718  pe(i,1,j) = ptop
1719  peln(i,1,j) = log(ptop)
1720  pk(i,j,1) = ptop**kappa
1721  enddo
1722 ! Top down
1723  do k=2,npz+1
1724  do i=is,ie
1725  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
1726  pk(i,j,k) = exp( kappa*log(pe(i,k,j)) )
1727  peln(i,k,j) = log(pe(i,k,j))
1728  enddo
1729  enddo
1730  enddo
1731 
1732 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,pk,peln)
1733  do k=1,npz
1734  do j=js,je
1735  do i=is,ie
1736  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
1737  enddo
1738  enddo
1739  enddo
1740 
1741  ! Setup ETA auxil variable
1742  eta_0 = 0.252
1743  do k=1,npz
1744  eta(k) = 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
1745  eta_v(k) = (eta(k) - eta_0)*pi*0.5
1746  enddo
1747 
1748  if ( .not. adiabatic ) then
1749  !Set up moisture
1750  sphum = get_tracer_index(model_atmos, 'sphum')
1751  pcen(1) = pi/9.
1752  pcen(2) = 2.0*pi/9.
1753 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pe,q,agrid,pcen,delp,peln) &
1754 !$OMP private(ptmp)
1755  do k=1,npz
1756  do j=js,je
1757  do i=is,ie
1758  !r = great_circle_dist(pcen, agrid(i,j,:), radius)
1759  !ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j)) - 100000.
1760  !q(i,j,k,1) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1761  ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - 100000.
1762  q(i,j,k,sphum) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1763 ! SJL:
1764 ! q(i,j,k,sphum) = max(1.e-25, q(i,j,k,sphum))
1765  enddo
1766  enddo
1767  enddo
1768  endif
1769 
1770  ! Initialize winds
1771  ubar = 35.0
1772  r0 = 1.0
1773  pcen(1) = pi/9.
1774  pcen(2) = 2.0*pi/9.
1775  if (test_case == 13) then
1776 #ifdef ALT_PERT
1777  u1 = 0.0
1778  pt0 = 3.0
1779 #else
1780  u1 = 1.0
1781  pt0 = 0.0
1782 #endif
1783  r0 = radius/10.0
1784  endif
1785 
1786 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta_v,grid,Ubar,pcen,r0,ee2,v,ee1,es,u,u1,ew) &
1787 !$OMP private(utmp,r,vv1,vv3,p1,p2,vv2,uu1,uu2,uu3,pa)
1788  do z=1,npz
1789  do j=js,je
1790  do i=is,ie+1
1791  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j+1,2))**2.0
1792  ! Perturbation if Case==13
1793  r = great_circle_dist( pcen, grid(i,j+1,1:2), radius )
1794  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1795  vv1 = utmp*(ee2(2,i,j+1)*cos(grid(i,j+1,1)) - ee2(1,i,j+1)*sin(grid(i,j+1,1)))
1796 
1797  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j,2))**2.0
1798  ! Perturbation if Case==13
1799  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1800  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1801  vv3 = utmp*(ee2(2,i,j)*cos(grid(i,j,1)) - ee2(1,i,j)*sin(grid(i,j,1)))
1802 ! Mid-point:
1803  p1(:) = grid(i ,j ,1:2)
1804  p2(:) = grid(i,j+1 ,1:2)
1805  call mid_pt_sphere(p1, p2, pa)
1806  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*pa(2))**2.0
1807  ! Perturbation if Case==13
1808  r = great_circle_dist( pcen, pa, radius )
1809  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1810  vv2 = utmp*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1811 ! 3-point average:
1812  v(i,j,z) = 0.25*(vv1 + 2.*vv2 + vv3)
1813  enddo
1814  enddo
1815  do j=js,je+1
1816  do i=is,ie
1817  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j,2))**2.0
1818  ! Perturbation if Case==13
1819  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1820  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1821  uu1 = utmp*(ee1(2,i,j)*cos(grid(i,j,1)) - ee1(1,i,j)*sin(grid(i,j,1)))
1822 
1823  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i+1,j,2))**2.0
1824  ! Perturbation if Case==13
1825  r = great_circle_dist( pcen, grid(i+1,j,1:2), radius )
1826  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1827  uu3 = utmp*(ee1(2,i+1,j)*cos(grid(i+1,j,1)) - ee1(1,i+1,j)*sin(grid(i+1,j,1)))
1828 ! Mid-point:
1829  p1(:) = grid(i ,j ,1:2)
1830  p2(:) = grid(i+1,j ,1:2)
1831  call mid_pt_sphere(p1, p2, pa)
1832  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*pa(2))**2.0
1833  ! Perturbation if Case==13
1834  r = great_circle_dist( pcen, pa, radius )
1835  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1836  uu2 = utmp*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1837 ! 3-point average:
1838  u(i,j,z) = 0.25*(uu1 + 2.*uu2 + uu3)
1839  enddo
1840  enddo
1841  enddo ! z-loop
1842 
1843  ! Temperature
1844  eta_s = 1.0 ! Surface Level
1845  eta_t = 0.2 ! Tropopause
1846  t_0 = 288.0
1847  delta_t = 480000.0
1848  lapse_rate = 0.005
1849 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta,ak,bk,T_0,lapse_rate,eta_t, &
1850 !$OMP delta_T,ptop,delp,Ubar,eta_v,agrid,grid,pcen,pt,r0) &
1851 !$OMP private(T_mean,press,pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1,r)
1852  do z=1,npz
1853  eta(z) = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
1854  ! if (is_master()) print*, z, eta
1855  t_mean = t_0 * eta(z)**(rdgas*lapse_rate/grav)
1856  if (eta_t > eta(z)) t_mean = t_mean + delta_t*(eta_t - eta(z))**5.0
1857 
1858  230 format(i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
1859  press = ptop
1860  do zz=1,z
1861  press = press + delp(is,js,zz)
1862  enddo
1863  if (is_master()) write(*,230) z, eta(z), press/100., t_mean
1864  do j=js,je
1865  do i=is,ie
1866 ! A-grid cell center: i,j
1867  pt1 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1868  ( -2.0*(sin(agrid(i,j,2))**6.0) *(cos(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1869  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1870  ( (8.0/5.0)*(cos(agrid(i,j,2))**3.0)*(sin(agrid(i,j,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1871 #ifndef NO_AVG13
1872 ! 9-point average: should be 2nd order accurate for a rectangular cell
1873 !
1874 ! 9 4 8
1875 !
1876 ! 5 1 3
1877 !
1878 ! 6 2 7
1879 !
1880  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1881  pt2 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1882  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1883  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1884  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1885  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1886  pt3 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1887  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1888  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1889  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1890  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1891  pt4 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1892  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1893  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1894  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1895  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1896  pt5 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1897  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1898  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1899  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1900 
1901  pt6 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1902  ( -2.0*(sin(grid(i,j,2))**6.0) *(cos(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1903  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1904  ( (8.0/5.0)*(cos(grid(i,j,2))**3.0)*(sin(grid(i,j,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1905  pt7 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1906  ( -2.0*(sin(grid(i+1,j,2))**6.0) *(cos(grid(i+1,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1907  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1908  ( (8.0/5.0)*(cos(grid(i+1,j,2))**3.0)*(sin(grid(i+1,j,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1909  pt8 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1910  ( -2.0*(sin(grid(i+1,j+1,2))**6.0) *(cos(grid(i+1,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1911  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1912  ( (8.0/5.0)*(cos(grid(i+1,j+1,2))**3.0)*(sin(grid(i+1,j+1,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1913  pt9 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1914  ( -2.0*(sin(grid(i,j+1,2))**6.0) *(cos(grid(i,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1915  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1916  ( (8.0/5.0)*(cos(grid(i,j+1,2))**3.0)*(sin(grid(i,j+1,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1917  pt(i,j,z) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1918 #else
1919  pt(i,j,z) = pt1
1920 #endif
1921 
1922 #ifdef ALT_PERT
1923  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
1924  if ( (r/r0)**2 < 40. ) then
1925  pt(i,j,z) = pt(i,j,z) + pt0*exp(-(r/r0)**2)
1926  endif
1927 #endif
1928 
1929  enddo
1930  enddo
1931  enddo
1932  if (is_master()) print*,' '
1933  ! Surface Geopotential
1934  phis(:,:)=1.e25
1935 !$OMP parallel do default(none) shared(is2,ie2,js2,je2,Ubar,eta_s,eta_0,agrid,grid,phis) &
1936 !$OMP private(pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1)
1937  do j=js2,je2
1938  do i=is2,ie2
1939  pt1 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1940  ( -2.0*(sin(agrid(i,j,2))**6.0) *(cos(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1941  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1942  ( (8.0/5.0)*(cos(agrid(i,j,2))**3.0)*(sin(agrid(i,j,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1943 #ifndef NO_AVG13
1944 ! 9-point average:
1945 !
1946 ! 9 4 8
1947 !
1948 ! 5 1 3
1949 !
1950 ! 6 2 7
1951 !
1952  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1953  pt2 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1954  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1955  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1956  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1957  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1958  pt3 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1959  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1960  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1961  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1962  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1963  pt4 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1964  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1965  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1966  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1967  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1968  pt5 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1969  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1970  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1971  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1972 
1973  pt6 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1974  ( -2.0*(sin(grid(i,j,2))**6.0) *(cos(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1975  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1976  ( (8.0/5.0)*(cos(grid(i,j,2))**3.0)*(sin(grid(i,j,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1977  pt7 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1978  ( -2.0*(sin(grid(i+1,j,2))**6.0) *(cos(grid(i+1,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1979  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1980  ( (8.0/5.0)*(cos(grid(i+1,j,2))**3.0)*(sin(grid(i+1,j,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1981  pt8 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1982  ( -2.0*(sin(grid(i+1,j+1,2))**6.0) *(cos(grid(i+1,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1983  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1984  ( (8.0/5.0)*(cos(grid(i+1,j+1,2))**3.0)*(sin(grid(i+1,j+1,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1985  pt9 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1986  ( -2.0*(sin(grid(i,j+1,2))**6.0) *(cos(grid(i,j+1,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1987  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1988  ( (8.0/5.0)*(cos(grid(i,j+1,2))**3.0)*(sin(grid(i,j+1,2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1989  phis(i,j) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1990 #else
1991  phis(i,j) = pt1
1992 #endif
1993  enddo
1994  enddo
1995 
1996  if ( .not.hydrostatic ) then
1997 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,delz,peln,w)
1998  do k=1,npz
1999  do j=js,je
2000  do i=is,ie
2001  w(i,j,k) = 0.
2002  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
2003  enddo
2004  enddo
2005  enddo
2006  endif
2007  !Assume pt is virtual temperature at this point; then convert to regular temperature
2008  if (.not. adiabatic) then
2009  zvir = rvgas/rdgas - 1.
2010 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pt,zvir,q)
2011  do k=1,npz
2012  do j=js,je
2013  do i=is,ie
2014  pt(i,j,k) = pt(i,j,k)/(1. + zvir*q(i,j,k,sphum))
2015  enddo
2016  enddo
2017  enddo
2018  endif
2019 
2020  !Set up tracer #2 to be the initial EPV
2021 ! call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,2))
2022 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
2023 
2024  write(stdout(), *) 'PI:', pi
2025  write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
2026 
2027  else if ( (test_case==-12) .or. (test_case==-13) ) then
2028 
2029  call dcmip16_bc(delp,pt,u,v,q,w,delz, &
2030  is,ie,js,je,isd,ied,jsd,jed,npz,ncnst,ak,bk,ptop, &
2031  pk,peln,pe,pkz,gz,phis,ps,grid,agrid,hydrostatic, &
2032  nwat, adiabatic, test_case == -13, domain)
2033 
2034  write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
2035 
2036  else if ( test_case==15 .or. test_case==19 ) then
2037 !------------------------------------
2038 ! Non-hydrostatic 3D density current:
2039 !------------------------------------
2040 ! C100_L64; hybrid_z = .T., make_nh = .F. , make_hybrid_z = .false.
2041 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
2042 
2043  if ( test_case == 19 ) then
2044  f0(:,:) = 0.
2045  fc(:,:) = 0.
2046  endif
2047 
2048  phis = 0.
2049  u = 0.
2050  v = 0.
2051  w = 0.
2052  t00 = 300.
2053  p00 = 1.e5
2054  pk0 = p00**kappa
2055 ! Set up vertical coordinare with constant del-z spacing:
2056  ztop = 6.4e3
2057  ze1( 1) = ztop
2058  ze1(npz+1) = 0.
2059  do k=npz,2,-1
2060  ze1(k) = ze1(k+1) + ztop/real(npz)
2061  enddo
2062 
2063 ! Provide some room for the top layer
2064  ze1(1) = ztop + 1.5*ztop/real(npz)
2065 
2066  do j=js,je
2067  do i=is,ie
2068  ps(i,j) = p00
2069  pe(i,npz+1,j) = p00
2070  pk(i,j,npz+1) = pk0
2071  enddo
2072  enddo
2073 
2074  do k=npz,1,-1
2075  do j=js,je
2076  do i=is,ie
2077  delz(i,j,k) = ze1(k+1) - ze1(k)
2078  pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
2079  pe(i,k,j) = pk(i,j,k)**(1./kappa)
2080  enddo
2081  enddo
2082  enddo
2083 
2084  ptop = pe(is,1,js)
2085  if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
2086 
2087  do k=1,npz+1
2088  do j=js,je
2089  do i=is,ie
2090  peln(i,k,j) = log(pe(i,k,j))
2091  ze0(i,j,k) = ze1(k)
2092  enddo
2093  enddo
2094  enddo
2095 
2096  do k=1,npz
2097  do j=js,je
2098  do i=is,ie
2099  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2100  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2101  pt(i,j,k) = t00/pk0 ! potential temp
2102  enddo
2103  enddo
2104  enddo
2105 
2106 ! Perturbation: center at 3 km from the ground
2107  pturb = 15.
2108  p1(1) = pi
2109  p1(2) = 0.
2110 
2111  do k=1,npz
2112 #ifndef STD_BUBBLE
2113  r0 = 0.5*(ze1(k)+ze1(k+1)) - 3.2e3
2114 #else
2115  r0 = (0.5*(ze1(k)+ze1(k+1)) - 3.0e3) / 2.e3
2116 #endif
2117  do j=js,je
2118  do i=is,ie
2119 ! Impose perturbation in potential temperature: pturb
2120  p2(1) = agrid(i,j,1)
2121  p2(2) = agrid(i,j,2)
2122 #ifndef STD_BUBBLE
2123  r = great_circle_dist( p1, p2, radius )
2124  dist = sqrt( r**2 + r0**2 ) / 3.2e3
2125 #else
2126  r = great_circle_dist( p1, p2, radius ) / 4.e3
2127  dist = sqrt( r**2 + r0**2 )
2128 #endif
2129  if ( dist<=1. ) then
2130  q(i,j,k,1) = pk0 * pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2131  pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2132  else
2133  q(i,j,k,1) = 0.
2134  endif
2135 ! Transform back to temperature:
2136  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
2137  enddo
2138  enddo
2139  enddo
2140 
2141  else if ( test_case==16 ) then
2142 
2143 ! Non-rotating:
2144  f0(:,:) = 0.
2145  fc(:,:) = 0.
2146 ! Initialize dry atmosphere
2147  phis = 0.
2148  u = 0.
2149  v = 0.
2150  p00 = 1000.e2
2151 ! Set up vertical coordinare with constant del-z spacing:
2152  ztop = 10.e3
2153  call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2154 
2155  do z=1,npz+1
2156  pe1(z) = ak(z) + bk(z)*p00
2157  enddo
2158 
2159  ze1(npz+1) = 0.
2160  do z=npz,2,-1
2161  ze1(z) = ze1(z+1) + ztop/real(npz)
2162  enddo
2163  ze1(1) = ztop
2164 
2165  if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2166 
2167  do j=jsd,jed
2168  do i=isd,ied
2169  ps(i,j) = pe1(npz+1)
2170  enddo
2171  enddo
2172 
2173  do z=1,npz+1
2174  do j=js,je
2175  do i=is,ie
2176  pe(i,z,j) = pe1(z)
2177  peln(i,z,j) = log(pe1(z))
2178  pk(i,j,z) = exp(kappa*peln(i,z,j))
2179  enddo
2180  enddo
2181  enddo
2182 
2183 ! Horizontal shape function
2184  p1(1) = pi
2185  p1(2) = 0.
2186  r0 = radius / 3.
2187  do j=js,je
2188  do i=is,ie
2189  r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2190  if ( r<r0 ) then
2191  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2192  else
2193  vort(i,j) = 0
2194  endif
2195  enddo
2196  enddo
2197 
2198  q = 0.
2199  pk0 = p00**kappa
2200  pturb = 10./pk0
2201  do z=1,npz
2202  zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2203  do j=js,je
2204  do i=is,ie
2205  pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2206  delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2207 ! Impose perturbation in potential temperature: pturb
2208  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2209  q(i,j,z,1) = q(i,j,z,1) + vort(i,j)*zmid
2210  enddo
2211  enddo
2212  enddo
2213 
2214  elseif ( test_case==17 ) then
2215 ! Initialize dry atmosphere
2216  phis = 0.
2217  u = 0.
2218  v = 0.
2219  p00 = 1000.e2
2220 ! Set up vertical coordinare with constant del-z spacing:
2221  ztop = 10.e3
2222  call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2223 
2224  do z=1,npz+1
2225  pe1(z) = ak(z) + bk(z)*p00
2226  enddo
2227 
2228  ze1(npz+1) = 0.
2229  do z=npz,2,-1
2230  ze1(z) = ze1(z+1) + ztop/real(npz)
2231  enddo
2232  ze1(1) = ztop
2233 
2234  if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2235 
2236  do j=jsd,jed
2237  do i=isd,ied
2238  ps(i,j) = pe1(npz+1)
2239  enddo
2240  enddo
2241 
2242  do z=1,npz+1
2243  do j=js,je
2244  do i=is,ie
2245  pe(i,z,j) = pe1(z)
2246  peln(i,z,j) = log(pe1(z))
2247  pk(i,j,z) = exp(kappa*peln(i,z,j))
2248  enddo
2249  enddo
2250  enddo
2251 
2252 ! Horizontal shape function
2253  p1(1) = pi
2254  p1(2) = pi/4.
2255  r0 = radius / 3.
2256  do j=js,je
2257  do i=is,ie
2258  r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2259  if ( r<r0 ) then
2260  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2261  else
2262  vort(i,j) = 0
2263  endif
2264  enddo
2265  enddo
2266 
2267  pk0 = p00**kappa
2268  pturb = 10./pk0
2269  do z=1,npz
2270  zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2271  do j=js,je
2272  do i=is,ie
2273  pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2274  delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2275 ! Impose perturbation in potential temperature: pturb
2276  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2277  enddo
2278  enddo
2279  enddo
2280 
2281  elseif ( test_case==18 ) then
2282  ubar = 20.
2283  pt0 = 288.
2284  n2 = grav**2 / (cp_air*pt0)
2285 
2286  pcen(1) = pi/2.
2287  pcen(2) = pi/6.
2288 
2289  ! Initialize surface Pressure
2290  do j=js2,je2
2291  do i=is2,ie2
2292  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
2293  phis(i,j) = grav*2.e3*exp( -(r/1500.e3)**2 )
2294  ps(i,j) = 930.e2 * exp( -radius*n2*ubar/(2.*grav*grav*kappa)*(ubar/radius+2.*omega)* &
2295  (sin(agrid(i,j,2))**2-1.) - n2/(grav*grav*kappa)*phis(i,j))
2296  enddo
2297  enddo
2298 
2299  do z=1,npz
2300  do j=js,je
2301  do i=is,ie
2302  pt(i,j,z) = pt0
2303  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
2304  enddo
2305  enddo
2306 ! v-wind:
2307  do j=js,je
2308  do i=is,ie+1
2309  p1(:) = grid(i ,j ,1:2)
2310  p2(:) = grid(i,j+1 ,1:2)
2311  call mid_pt_sphere(p1, p2, p3)
2312  call get_unit_vect2(p1, p2, e2)
2313  call get_latlon_vector(p3, ex, ey)
2314  utmp = ubar * cos(p3(2))
2315  vtmp = 0.
2316  v(i,j,z) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2317  enddo
2318  enddo
2319 
2320 ! u-wind
2321  do j=js,je+1
2322  do i=is,ie
2323  p1(:) = grid(i, j,1:2)
2324  p2(:) = grid(i+1,j,1:2)
2325  call mid_pt_sphere(p1, p2, p3)
2326  call get_unit_vect2(p1, p2, e1)
2327  call get_latlon_vector(p3, ex, ey)
2328  utmp = ubar * cos(p3(2))
2329  vtmp = 0.
2330  u(i,j,z) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2331  enddo
2332  enddo
2333  enddo
2334 
2335  else if ( test_case==20 .or. test_case==21 ) then
2336 !------------------------------------
2337 ! Non-hydrostatic 3D lee vortices
2338 !------------------------------------
2339  f0(:,:) = 0.
2340  fc(:,:) = 0.
2341 
2342  if ( test_case == 20 ) then
2343  ubar = 4. ! u = Ubar * cos(lat)
2344  ftop = 2.0e3 * grav
2345  else
2346  ubar = 8. ! u = Ubar * cos(lat)
2347  ftop = 4.0e3 * grav
2348  endif
2349 
2350  w = 0.
2351 
2352  do j=js,je
2353  do i=is,ie+1
2354  p1(:) = grid(i ,j ,1:2)
2355  p2(:) = grid(i,j+1 ,1:2)
2356  call mid_pt_sphere(p1, p2, p3)
2357  call get_unit_vect2(p1, p2, e2)
2358  call get_latlon_vector(p3, ex, ey)
2359  utmp = ubar * cos(p3(2))
2360  vtmp = 0.
2361  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2362  enddo
2363  enddo
2364  do j=js,je+1
2365  do i=is,ie
2366  p1(:) = grid(i, j,1:2)
2367  p2(:) = grid(i+1,j,1:2)
2368  call mid_pt_sphere(p1, p2, p3)
2369  call get_unit_vect2(p1, p2, e1)
2370  call get_latlon_vector(p3, ex, ey)
2371  utmp = ubar * cos(p3(2))
2372  vtmp = 0.
2373  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2374  enddo
2375  enddo
2376 
2377 ! copy vertically; no wind shear
2378  do k=2,npz
2379  do j=js,je+1
2380  do i=is,ie
2381  u(i,j,k) = u(i,j,1)
2382  enddo
2383  enddo
2384  do j=js,je
2385  do i=is,ie+1
2386  v(i,j,k) = v(i,j,1)
2387  enddo
2388  enddo
2389  enddo
2390 
2391 ! Center of the mountain:
2392  p1(1) = (0.5-0.125) * pi
2393  p1(2) = 0.
2394  call latlon2xyz(p1, e1)
2395  uu1 = 5.0e3
2396  uu2 = 10.0e3
2397  do j=js2,je2
2398  do i=is2,ie2
2399  p2(:) = agrid(i,j,1:2)
2400  r = great_circle_dist( p1, p2, radius )
2401  if ( r < pi*radius ) then
2402  p4(:) = p2(:) - p1(:)
2403  if ( abs(p4(1)) > 1.e-12 ) then
2404  zeta = asin( p4(2) / sqrt(p4(1)**2 + p4(2)**2) )
2405  else
2406  zeta = pi/2.
2407  endif
2408  if ( p4(1) <= 0. ) zeta = pi - zeta
2409  zeta = zeta + pi/6.
2410  v1 = r/uu1 * cos( zeta )
2411  v2 = r/uu2 * sin( zeta )
2412  phis(i,j) = ftop / ( 1. + v1**2 + v2**2 )
2413  else
2414  phis(i,j) = 0.
2415  endif
2416  enddo
2417  enddo
2418 
2419  if ( hybrid_z ) then
2420  rgrav = 1./ grav
2421  if( npz==32 ) then
2422  call compute_dz_l32( npz, ztop, dz1 )
2423  elseif( npz.eq.31 .or. npz.eq.41 .or. npz.eq.51 ) then
2424  ztop = 16.e3
2425  call hybrid_z_dz(npz, dz1, ztop, 1.0)
2426  else
2427  if ( is_master() ) write(*,*) 'Using const DZ'
2428  ztop = 15.e3
2429  dz1(1) = ztop / real(npz)
2430  do k=2,npz
2431  dz1(k) = dz1(1)
2432  enddo
2433 ! Make top layer thicker
2434  dz1(1) = max( 1.0e3, 3.*dz1(2) ) ! min 1 km
2435  endif
2436 
2437 ! Re-compute ztop
2438  ze1(npz+1) = 0.
2439  do k=npz,1,-1
2440  ze1(k) = ze1(k+1) + dz1(k)
2441  enddo
2442  ztop = ze1(1)
2443 
2444  call set_hybrid_z( is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
2445  phis, ze0, delz )
2446  else
2447  call mpp_error(fatal, 'This test case is only currently setup for hybrid_z')
2448  endif
2449 
2450  do k=1,npz
2451  do j=js,je
2452  do i=is,ie
2453  delz(i,j,k) = ze0(i,j,k+1) - ze0(i,j,k)
2454  enddo
2455  enddo
2456  enddo
2457 
2458  p00 = 1.e5 ! mean SLP
2459  pk0 = p00**kappa
2460  t00 = 300.
2461  pt0 = t00/pk0
2462  n2 = 1.e-4
2463  s0 = grav*grav / (cp_air*n2)
2464 
2465 ! For constant N2, Given z --> p
2466  do k=1,npz+1
2467  pe1(k) = p00*( (1.-s0/t00) + s0/t00*exp(-n2*ze1(k)/grav) )**(1./kappa)
2468  enddo
2469 
2470  ptop = pe1(1)
2471  if ( is_master() ) write(*,*) 'Lee vortex testcase: model top (mb)=', ptop/100.
2472 
2473 ! Set up fake "sigma" coordinate
2474  ak(1) = pe1(1)
2475  bk(1) = 0.
2476  do k=2,npz
2477  bk(k) = (pe1(k) - pe1(1)) / (pe1(npz+1)-pe1(1)) ! bk == sigma
2478  ak(k) = pe1(1)*(1.-bk(k))
2479  enddo
2480  ak(npz+1) = 0.
2481  bk(npz+1) = 1.
2482 
2483 ! Assuming constant N
2484  do k=2,npz+1
2485  do j=js,je
2486  do i=is,ie
2487  pk(i,j,k) = pk0 - (1.-exp(-n2/grav*ze0(i,j,k))) * (grav*grav)/(n2*cp_air*pt0)
2488  pe(i,k,j) = pk(i,j,k) ** (1./kappa)
2489  peln(i,k,j) = log(pe(i,k,j))
2490  enddo
2491  enddo
2492  enddo
2493 
2494  do j=js,je
2495  do i=is,ie
2496  pe(i,1,j) = ptop
2497  peln(i,1,j) = log(pe(i,1,j))
2498  pk(i,j,1) = pe(i,1,j) ** kappa
2499  ps(i,j) = pe(i,npz+1,j)
2500  enddo
2501  enddo
2502 
2503  do k=1,npz
2504  do j=js,je
2505  do i=is,ie
2506  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2507  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2508  pt(i,j,k) = pkz(i,j,k)*grav*delz(i,j,k) / ( cp_air*(pk(i,j,k)-pk(i,j,k+1)) )
2509  enddo
2510  enddo
2511  enddo
2512 
2513  else if (test_case == 51) then
2514 
2515  alpha = 0.
2516  t00 = 300.
2517 
2518 
2519  if (.not.hydrostatic) w(:,:,:)= 0.0
2520 
2521 
2522  select case (tracer_test)
2523  case (1) !DCMIP 11
2524 
2525  !Need to set up pressure arrays
2526 !!$ p00 = 1.e5
2527 !!$ ps = p00
2528 !!$ phis = 0.
2529 
2530  !NOTE: since we have an isothermal atmosphere and specify constant height-thickness layers we will disregard ak and bk and specify the initial pressures in a different way
2531 
2532  dz = 12000./real(npz)
2533 
2534  allocate(zz0(npz+1))
2535  allocate(pz0(npz+1))
2536 
2537  zz0(1) = 12000.
2538  do k=2,npz
2539  zz0(k) = zz0(k-1) - dz
2540  enddo
2541  zz0(npz+1) = 0.
2542 
2543  if (is_master()) print*, 'TRACER ADVECTION TEST CASE'
2544  if (is_master()) print*, 'INITIAL LEVELS'
2545  !This gets interface pressure from input z-levels
2546  do k=1,npz+1
2547  !call test1_advection_deformation(agrid(is,js,1), agrid(is,js,2), pz0(k), zz0(k), 1, &
2548  ! ua(is,js,1), va(is,js,1), dum1, pt(is,js,1), phis(is,js), &
2549  ! ps(is,js), dum2, dum3, q(is,js,1,1), q(is,js,1,2), q(is,js,1,3), q(is,js,1,4))
2550  if (is_master()) write(*,*) k, pz0(k), zz0(k)
2551  enddo
2552 
2553  !Pressure
2554  do j=js,je
2555  do k=1,npz+1
2556  do i=is,ie
2557  pe(i,k,j) = pz0(k)
2558  enddo
2559  enddo
2560  enddo
2561 
2562  do k=1,npz
2563  ptmp = 0.5*(pz0(k) + pz0(k+1))
2564  do j=js,je
2565  do i=is,ie
2566  !This gets level-mean values from input pressures
2567  !call test1_advection_deformation(agrid(i,j,1),agrid(i,j,2),ptmp,dum,0, &
2568  ! ua(i,j,k), va(i,j,k), dum4, pt(i,j,k), phis(i,j), &
2569  ! ps(i,j), dum2, dum3, q(i,j,k,1), q(i,j,k,2), q(i,j,k,3), q(i,j,k,4))
2570  delp(i,j,k) = pz0(k+1)-pz0(k)
2571  enddo
2572  enddo
2573  enddo
2574 
2575  ptop = 100000.*exp(-12000.*grav/t00/rdgas)
2576 
2577 
2578  psi(:,:) = 1.e25
2579  psi_b(:,:) = 1.e25
2580  do j=jsd,jed
2581  do i=isd,ied
2582  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
2583  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
2584  enddo
2585  enddo
2586  call mpp_update_domains( psi, domain )
2587  do j=jsd,jed+1
2588  do i=isd,ied+1
2589  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
2590  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
2591  enddo
2592  enddo
2593 
2594  k = 1
2595  do j=js,je+1
2596  do i=is,ie
2597  dist = dx(i,j)
2598  vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
2599  if (dist==0) vc(i,j,k) = 0.
2600  enddo
2601  enddo
2602  do j=js,je
2603  do i=is,ie+1
2604  dist = dy(i,j)
2605  uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
2606  if (dist==0) uc(i,j,k) = 0.
2607  enddo
2608  enddo
2609 
2610  do j=js,je
2611  do i=is,ie+1
2612  dist = dxc(i,j)
2613  v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
2614  if (dist==0) v(i,j,k) = 0.
2615  enddo
2616  enddo
2617  do j=js,je+1
2618  do i=is,ie
2619  dist = dyc(i,j)
2620  u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
2621  if (dist==0) u(i,j,k) = 0.
2622  enddo
2623  enddo
2624 
2625  do j=js,je
2626  do i=is,ie
2627  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
2628  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
2629  dist = dya(i,j)
2630  ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
2631  if (dist==0) ua(i,j,k) = 0.
2632  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
2633  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
2634  dist = dxa(i,j)
2635  va(i,j,k) = (psi2 - psi1) / (dist)
2636  if (dist==0) va(i,j,k) = 0.
2637  enddo
2638  enddo
2639 
2640  do k=2,npz
2641  u(:,:,k) = u(:,:,1)
2642  v(:,:,k) = v(:,:,1)
2643  uc(:,:,k) = uc(:,:,1)
2644  vc(:,:,k) = vc(:,:,1)
2645  ua(:,:,k) = ua(:,:,1)
2646  va(:,:,k) = va(:,:,1)
2647  enddo
2648 
2649  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
2650  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
2651  call mp_update_dwinds(u, v, npx, npy, npz, domain)
2652 
2653  case (2) !DCMIP 12
2654 
2655  case (3) !DCMIP 13
2656 
2657  case default
2658  call mpp_error(fatal, 'Value of tracer_test not implemented ')
2659  end select
2660 
2661  else if (test_case == 52) then
2662 
2663  !Orography and steady-state test: DCMIP 20
2664 
2665 
2666  f0 = 0.
2667  fc = 0.
2668 
2669  u = 0.
2670  v = 0.
2671 
2672  p00 = 1.e5
2673 
2674  wind_field = tracer_test
2675 
2676  if (.not.hydrostatic) w(:,:,:)= 0.0
2677 
2678  !Set up ak and bk
2679 
2680  dz = 12000./real(npz)
2681  t00 = 300.
2682  p00 = 1.e5
2683  h = rdgas*t00/grav
2684  gamma = 0.0065
2685  exponent = rdgas*gamma/grav
2686  px = ((t00-9000.*gamma)/t00)**(1./exponent) !p00 not multiplied in
2687 
2688 
2689  do k=1,npz+1
2690  height = 12000. - dz*real(k-1)
2691  if (height >= 9000. ) then
2692  ak(k) = p00*((t00-height*gamma)/t00)**(1./exponent)
2693  bk(k) = 0.
2694  else
2695  ak(k) = (((t00-height*gamma)/t00)**(1./exponent)-1.)/(px - 1.)*px*p00
2696  bk(k) = (((t00-height*gamma)/t00)**(1./exponent)-px)/(1.-px)
2697  endif
2698  if (is_master()) write(*,*) k, ak(k), bk(k), height, ak(k)+bk(k)*p00
2699  enddo
2700 
2701  ptop = ak(1)
2702 
2703  !Need to set up uniformly-spaced levels
2704  p1(1) = 3.*pi/2. ; p1(2) = 0.
2705  r0 = 0.75*pi
2706  zetam = pi/16.
2707 
2708  !Topography
2709  do j=js,je
2710  do i=is,ie
2711  p2(:) = agrid(i,j,1:2)
2712  r = great_circle_dist( p1, p2, one )
2713  if (r < r0) then
2714  phis(i,j) = grav*0.5*2000.*(1. + cos(pi*r/r0))*cos(pi*r/zetam)**2.
2715  pe(i,npz+1,j) = p00*(1.-gamma/t00*phis(i,j)/grav)**(1./exponent)
2716  else
2717  phis(i,j) = 0.
2718  pe(i,npz+1,j) = p00
2719  endif
2720  ps(i,j) = pe(i,npz+1,j)
2721  enddo
2722  enddo
2723 
2724  do j=js,je
2725  do k=1,npz
2726  do i=is,ie
2727  pe(i,k,j) = ak(k) + bk(k)*ps(i,j)
2728  gz(i,j,k) = t00/gamma*(1. - (pe(i,k,j)/p00)**exponent)
2729  enddo
2730  enddo
2731  enddo
2732 
2733  do k=1,npz
2734  do j=js,je
2735  do i=is,ie
2736 
2737  !call test2_steady_state_mountain(agrid(i,j,1),agrid(i,j,2),dum, dum2, 0, .true., &
2738  ! 0.5*(ak(k)+ak(k+1)), 0.5*(bk(k)+bk(k+1)), dum3, dum4, dum5, &
2739  ! pt(i,j,k), phis(i,j), ps(i,j), dum6, q(i,j,k,1))
2740  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
2741  !Analytic point-value
2742 !!$ ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
2743 !!$ pt(i,j,k) = t00*(ptmp/p00)**exponent
2744  !ANalytic layer-mean
2745  pt(i,j,k) = -grav*t00*p00/(rdgas*gamma + grav)/delp(i,j,k) * &
2746  ( (pe(i,k,j)/p00)**(exponent+1.) - (pe(i,k+1,j)/p00)**(exponent+1.) )
2747 
2748 
2749  enddo
2750  enddo
2751  enddo
2752 
2753  else if ( abs(test_case)==30 .or. abs(test_case)==31 ) then
2754 !------------------------------------
2755 ! Super-Cell; with or with rotation
2756 !------------------------------------
2757  if ( abs(test_case)==30) then
2758  f0(:,:) = 0.
2759  fc(:,:) = 0.
2760  endif
2761 
2762  zvir = rvgas/rdgas - 1.
2763  p00 = 1000.e2
2764  ps(:,:) = p00
2765  phis(:,:) = 0.
2766  do j=js,je
2767  do i=is,ie
2768  pk(i,j,1) = ptop**kappa
2769  pe(i,1,j) = ptop
2770  peln(i,1,j) = log(ptop)
2771  enddo
2772  enddo
2773 
2774  do k=1,npz
2775  do j=js,je
2776  do i=is,ie
2777  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
2778  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
2779  peln(i,k+1,j) = log(pe(i,k+1,j))
2780  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
2781  enddo
2782  enddo
2783  enddo
2784 
2785  i = is
2786  j = js
2787  do k=1,npz
2788  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2789  enddo
2790 
2791 
2792  w(:,:,:) = 0.
2793  q(:,:,:,:) = 0.
2794 
2795  pp0(1) = 262.0/180.*pi ! OKC
2796  pp0(2) = 35.0/180.*pi
2797 
2798  do k=1,npz
2799  do j=js,je
2800  do i=is,ie
2801  pt(i,j,k) = ts1(k)
2802  q(i,j,k,1) = qs1(k)
2803  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
2804  enddo
2805  enddo
2806  enddo
2807 
2808  ze1(npz+1) = 0.
2809  do k=npz,1,-1
2810  ze1(k) = ze1(k+1) - delz(is,js,k)
2811  enddo
2812 
2813  us0 = 30.
2814  if (is_master()) then
2815  if (test_case > 0) then
2816  write(6,*) 'Toy supercell winds, piecewise approximation'
2817  else
2818  write(6,*) 'Toy supercell winds, tanh approximation'
2819  endif
2820  endif
2821  do k=1,npz
2822 
2823  zm = 0.5*(ze1(k)+ze1(k+1))
2824  ! Quarter-circle hodograph (Harris approximation)
2825 
2826  if (test_case > 0) then
2827  ! SRH = 40
2828  if ( zm .le. 2.e3 ) then
2829  utmp = 8.*(1.-cos(pi*zm/4.e3))
2830  vtmp = 8.*sin(pi*zm/4.e3)
2831  elseif (zm .le. 6.e3 ) then
2832  utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
2833  vtmp = 8.
2834  else
2835  utmp = us0
2836  vtmp = 8.
2837  endif
2838  ubar = utmp - 8.
2839  vbar = vtmp - 4.
2840  else
2841  ! SRH = 39
2842  utmp = 15.0*(1.+tanh(zm/2000. - 1.5))
2843  vtmp = 8.5*tanh(zm/1000.)
2844  ubar = utmp - 8.5
2845  vbar = vtmp - 4.25
2846 !!$ ! SRH = 45
2847 !!$ utmp = 16.0*(1.+tanh(zm/2000. - 1.4))
2848 !!$ vtmp = 8.5*tanh(zm/1000.)
2849 !!$ ubar = utmp - 10.
2850 !!$ vbar = vtmp - 4.25
2851 !!$ ! SRH = 27 (really)
2852 !!$ utmp = 0.5*us0*(1.+tanh((zm-3500.)/2000.))
2853 !!$ vtmp = 8.*tanh(zm/1000.)
2854 !!$ ubar = utmp - 10.
2855 !!$ vbar = vtmp - 4.
2856  endif
2857 
2858  if( is_master() ) then
2859  write(6,*) k, utmp, vtmp
2860  endif
2861 
2862  do j=js,je
2863  do i=is,ie+1
2864  p1(:) = grid(i ,j ,1:2)
2865  p2(:) = grid(i,j+1 ,1:2)
2866  call mid_pt_sphere(p1, p2, p3)
2867  call get_unit_vect2(p1, p2, e2)
2868  call get_latlon_vector(p3, ex, ey)
2869 ! Scaling factor is a Gaussian decay from center
2870  v(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2871  (ubar*inner_prod(e2,ex) + vbar*inner_prod(e2,ey))
2872  enddo
2873  enddo
2874  do j=js,je+1
2875  do i=is,ie
2876  p1(:) = grid(i, j,1:2)
2877  p2(:) = grid(i+1,j,1:2)
2878  call mid_pt_sphere(p1, p2, p3)
2879  call get_unit_vect2(p1, p2, e1)
2880  call get_latlon_vector(p3, ex, ey)
2881 ! Scaling factor is a Gaussian decay from center
2882  u(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2883  (ubar*inner_prod(e1,ex) + vbar*inner_prod(e1,ey))
2884  enddo
2885  enddo
2886  enddo
2887 
2888  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
2889  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
2890  .true., hydrostatic, nwat, domain)
2891 
2892 ! *** Add Initial perturbation ***
2893  pturb = 2.
2894  r0 = 10.e3 ! radius
2895  zc = 1.4e3 ! center of bubble from surface
2896  do k=1, npz
2897  zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
2898  ptmp = ( (zm-zc)/zc ) **2
2899  if ( ptmp < 1. ) then
2900  do j=js,je
2901  do i=is,ie
2902  dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
2903  if ( dist < 1. ) then
2904  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
2905  endif
2906  enddo
2907  enddo
2908  endif
2909  enddo
2910 
2911  elseif (test_case == 32) then
2912 
2913  call mpp_error(fatal, ' test_case 32 not yet implemented')
2914 
2915  else if ( test_case==33 .or. test_case==34 .or. test_case==35 ) then
2916 !------------------------------------
2917 ! HIWPP M0ountain waves tests
2918 !------------------------------------
2919  f0(:,:) = 0.
2920  fc(:,:) = 0.
2921 
2922  phis(:,:) = 1.e30
2923  ps(:,:) = 1.e30
2924 
2925  zvir = 0.
2926  p00 = 1000.e2
2927  t00 = 300.
2928  us0 = 20.
2929 ! Vertical shear parameter for M3 case:
2930  if ( test_case == 35 ) then
2931  cs_m3 = 2.5e-4
2932  else
2933  cs_m3 = 0.
2934  endif
2935 
2936 ! Mountain height:
2937  h0 = 250.
2938 ! Mountain center
2939  p0(1) = 60./180. * pi
2940  p0(2) = 0.
2941 ! 9-point average:
2942 ! 9 4 8
2943 !
2944 ! 5 1 3
2945 !
2946 ! 6 2 7
2947 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
2948  if ( test_case==35 ) then
2949  dum = -cs_m3/grav
2950  do j=js,je
2951  do i=is,ie
2952 ! temperature is function of latitude (due to vertical shear)
2953 #ifdef USE_CELL_AVG
2954  p2(2) = agrid(i,j,2)
2955  pt1 = exp( dum*(us0*sin(p2(2)))**2 )
2956  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2957  pt2 = exp( dum*(us0*sin(p2(2)))**2 )
2958  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2959  pt3 = exp( dum*(us0*sin(p2(2)))**2 )
2960  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
2961  pt4 = exp( dum*(us0*sin(p2(2)))**2 )
2962  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
2963  pt5 = exp( dum*(us0*sin(p2(2)))**2 )
2964  p2(2) = grid(i,j,2)
2965  pt6 = exp( dum*(us0*sin(p2(2)))**2 )
2966  p2(2) = grid(i+1,j,2)
2967  pt7 = exp( dum*(us0*sin(p2(2)))**2 )
2968  p2(2) = grid(i+1,j+1,2)
2969  pt8 = exp( dum*(us0*sin(p2(2)))**2 )
2970  p2(2) = grid(i,j+1,2)
2971  pt9 = exp( dum*(us0*sin(p2(2)))**2 )
2972  ptmp = t00*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
2973 #else
2974  ptmp = t00*exp( dum*(us0*sin(agrid(i,j,2)))**2 )
2975 #endif
2976  do k=1,npz
2977  pt(i,j,k) = ptmp
2978  enddo
2979  enddo
2980  enddo
2981  else
2982  pt(:,:,:) = t00
2983  endif
2984 
2985  if( test_case==33 ) then
2986 ! NCAR Ridge-mountain Mods:
2987  do j=js,je
2988  do i=is,ie
2989 #ifdef USE_CELL_AVG
2990  p2(1:2) = agrid(i,j,1:2)
2991  r = radius*(p2(1)-p0(1))
2992  pt1 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2993  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2994  r = radius*(p2(1)-p0(1))
2995  pt2 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2996  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2997  r = radius*(p2(1)-p0(1))
2998  pt3 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2999  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
3000  r = radius*(p2(1)-p0(1))
3001  pt4 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3002  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3003  r = radius*(p2(1)-p0(1))
3004  pt5 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3005  p2(1:2) = grid(i,j,1:2)
3006  r = radius*(p2(1)-p0(1))
3007  pt6 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3008  p2(1:2) = grid(i+1,j,1:2)
3009  r = radius*(p2(1)-p0(1))
3010  pt7 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3011  p2(1:2) = grid(i+1,j+1,1:2)
3012  r = radius*(p2(1)-p0(1))
3013  pt8 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3014  p2(1:2) = grid(i,j+1,1:2)
3015  r = radius*(p2(1)-p0(1))
3016  pt9 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3017  phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3018 #else
3019  p2(1:2) = agrid(i,j,1:2)
3020  r = radius*(p2(1)-p0(1))
3021  phis(i,j) = grav*h0*cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3022 #endif
3023  enddo
3024  enddo
3025  else
3026 ! Circular mountain:
3027  do j=js,je
3028  do i=is,ie
3029 ! 9-point average:
3030 ! 9 4 8
3031 !
3032 ! 5 1 3
3033 !
3034 ! 6 2 7
3035 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
3036 #ifdef USE_CELL_AVG
3037  r = great_circle_dist( p0, agrid(i,j,1:2), radius )
3038  pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3039  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
3040  r = great_circle_dist( p0, p2, radius )
3041  pt2 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3042  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
3043  r = great_circle_dist( p0, p2, radius )
3044  pt3 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3045  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
3046  r = great_circle_dist( p0, p2, radius )
3047  pt4 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3048  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3049  r = great_circle_dist( p0, p2, radius )
3050  pt5 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3051  r = great_circle_dist( p0, grid(i,j,1:2), radius )
3052  pt6 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3053  r = great_circle_dist( p0, grid(i+1,j,1:2), radius )
3054  pt7 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3055  r = great_circle_dist( p0, grid(i+1,j+1,1:2), radius )
3056  pt8 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3057  r = great_circle_dist( p0, grid(i,j+1,1:2), radius )
3058  pt9 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3059  phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3060 #else
3061  r = great_circle_dist( p0, agrid(i,j,1:2), radius )
3062  pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3063  phis(i,j) = grav*h0*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3064 #endif
3065  enddo
3066  enddo
3067  endif
3068 
3069  do j=js,je
3070  do i=is,ie
3071 ! DCMIP Eq(33)
3072  ps(i,j) = p00*exp( -0.5*(us0*sin(agrid(i,j,2)))**2/(rdgas*t00)-phis(i,j)/(rdgas*pt(i,j,1)) )
3073  pe(i,1,j) = ptop
3074  peln(i,1,j) = log(ptop)
3075  pk(i,j,1) = ptop**kappa
3076  enddo
3077  enddo
3078 
3079  do k=2,npz+1
3080  do j=js,je
3081  do i=is,ie
3082  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
3083  peln(i,k,j) = log(pe(i,k,j))
3084  pk(i,j,k) = exp( kappa*peln(i,k,j) )
3085  enddo
3086  enddo
3087  enddo
3088 
3089  do k=1,npz
3090  do j=js,je
3091  do i=is,ie
3092  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3093  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
3094  enddo
3095  enddo
3096  enddo
3097 
3098 ! Comnpute mid-level height, using w for temp storage
3099  do j=js,je
3100  do i=is,ie
3101  ze1(npz+1) = phis(i,j)/grav
3102  do k=npz,1,-1
3103  ze1(k) = ze1(k+1) - delz(i,j,k)
3104  enddo
3105  do k=1,npz
3106  w(i,j,k) = 0.5*(ze1(k)+ze1(k+1))
3107  enddo
3108  enddo
3109  enddo
3110  call mpp_update_domains( w, domain )
3111 
3112  do k=1,npz
3113  do j=js,je
3114  do i=is,ie+1
3115  p1(:) = grid(i ,j, 1:2)
3116  p2(:) = grid(i,j+1, 1:2)
3117  call mid_pt_sphere(p1, p2, p3)
3118  call get_unit_vect2(p1, p2, e2)
3119  call get_latlon_vector(p3, ex, ey)
3120 ! Joe Klemp's mod:
3121  utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i-1,j,k)+w(i,j,k)) )
3122  v(i,j,k) = utmp*inner_prod(e2,ex)
3123  enddo
3124  enddo
3125  do j=js,je+1
3126  do i=is,ie
3127  p1(:) = grid(i, j, 1:2)
3128  p2(:) = grid(i+1,j, 1:2)
3129  call mid_pt_sphere(p1, p2, p3)
3130  call get_unit_vect2(p1, p2, e1)
3131  call get_latlon_vector(p3, ex, ey)
3132  utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i,j-1,k)+w(i,j,k)) )
3133  u(i,j,k) = utmp*inner_prod(e1,ex)
3134  enddo
3135  enddo
3136  enddo
3137 
3138  w(:,:,:) = 0. ! reset w
3139  q(:,:,:,:) = 0.
3140 
3141  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3142  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
3143  .true., hydrostatic, nwat, domain)
3144 
3145  else if ( test_case==36 .or. test_case==37 ) then
3146 !------------------------------------
3147 ! HIWPP Super-Cell
3148 !------------------------------------
3149 ! HIWPP SUPER_K;
3150  f0(:,:) = 0.
3151  fc(:,:) = 0.
3152  q(:,:,:,:) = 0.
3153  w(:,:,:) = 0.
3154 
3155  zvir = rvgas/rdgas - 1.
3156  p00 = 1000.e2
3157  pk0 = p00**kappa
3158  ps(:,:) = p00
3159  phis(:,:) = 0.
3160 !
3161 ! Set up vertical layer spacing:
3162  ztop = 20.e3
3163  ze1(1) = ztop
3164  ze1(npz+1) = 0.
3165 #ifndef USE_VAR_DZ
3166 ! Truly uniform setup:
3167  do k=npz,2,-1
3168  ze1(k) = ze1(k+1) + ztop/real(npz)
3169  enddo
3170 #else
3171 ! Lowest layer half of the size
3172 ! ze1(npz) = ztop / real(2*npz-1) ! lowest layer thickness
3173 ! zm = (ztop-ze1(npz)) / real(npz-1)
3174 ! do k=npz,2,-1
3175 ! ze1(k) = ze1(k+1) + zm
3176 ! enddo
3177  call var_dz(npz, ztop, ze1)
3178 #endif
3179  do k=1,npz
3180  zs1(k) = 0.5*(ze1(k)+ze1(k+1))
3181  enddo
3182 !-----
3183 ! Get sounding at "equator": initial storm center
3184  call superk_sounding(npz, pe1, p00, ze1, ts1, qs1)
3185 ! ts1 is FV's definition of potential temperature at EQ
3186 
3187  do k=1,npz
3188  ts1(k) = cp_air*ts1(k)*(1.+zvir*qs1(k)) ! cp*thelta_v
3189  enddo
3190 ! Initialize the fields on z-coordinate; adjust top layer mass
3191 ! Iterate then interpolate to get balanced pt & pk on the sphere
3192 ! Adjusting ptop
3193  call superk_u(npz, zs1, uz1, dudz)
3194  call balanced_k(npz, is, ie, js, je, ng, pe1(npz+1), ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
3195  delz, zvir, ptop, ak, bk, agrid)
3196  do j=js,je
3197  do i=is,ie
3198  ps(i,j) = pe(i,npz+1,j)
3199  enddo
3200  enddo
3201 
3202  do k=1,npz+1
3203  do j=js,je
3204  do i=is,ie
3205  peln(i,k,j) = log(pe(i,k,j))
3206  pk(i,j,k) = exp( kappa*peln(i,k,j) )
3207  enddo
3208  enddo
3209  enddo
3210 
3211  do k=1,npz
3212  do j=js,je
3213  do i=is,ie
3214  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3215  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3216  q(i,j,k,1) = qs1(k)
3217  enddo
3218  enddo
3219  enddo
3220 
3221  k = 1 ! keep the same temperature but adjust the height at the top layer
3222  do j=js,je
3223  do i=is,ie
3224  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
3225  enddo
3226  enddo
3227 ! Adjust temperature; enforce constant dz except the top layer
3228  do k=2,npz
3229  do j=js,je
3230  do i=is,ie
3231  delz(i,j,k) = ze1(k+1) - ze1(k)
3232  pt(i,j,k) = delz(i,j,k)*grav/(rdgas*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)))
3233  enddo
3234  enddo
3235  enddo
3236 
3237 ! Wind-profile:
3238  do k=1,npz
3239  do j=js,je
3240  do i=is,ie+1
3241  p1(:) = grid(i ,j ,1:2)
3242  p2(:) = grid(i,j+1 ,1:2)
3243  call mid_pt_sphere(p1, p2, p3)
3244  call get_unit_vect2(p1, p2, e2)
3245  call get_latlon_vector(p3, ex, ey)
3246  v(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e2,ex)
3247  enddo
3248  enddo
3249  do j=js,je+1
3250  do i=is,ie
3251  p1(:) = grid(i, j,1:2)
3252  p2(:) = grid(i+1,j,1:2)
3253  call mid_pt_sphere(p1, p2, p3)
3254  call get_unit_vect2(p1, p2, e1)
3255  call get_latlon_vector(p3, ex, ey)
3256  u(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e1,ex)
3257  enddo
3258  enddo
3259  enddo
3260 
3261 ! *** Add Initial perturbation ***
3262  if ( test_case == 37 ) then
3263  pp0(1) = pi
3264  pp0(2) = 0.
3265  if (adiabatic) then
3266  pturb = 10.
3267  else
3268  pturb = 3. ! potential temperature
3269  endif
3270  r0 = 10.e3 ! radius
3271  zc = 1.5e3 ! center of bubble from surface
3272  do k=1, npz
3273  zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
3274  ptmp = ( (zm-zc)/zc ) **2
3275  if ( ptmp < 1. ) then
3276  do j=js,je
3277  do i=is,ie
3278  dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
3279  dist = sqrt(dist)
3280  if ( dist < 1. ) then
3281  pt(i,j,k) = pt(i,j,k) + (pkz(i,j,k)/pk0)*pturb*cos(0.5*pi*dist)**2
3282  endif
3283  enddo
3284  enddo
3285  endif
3286  enddo
3287  endif
3288 
3289  else if (test_case == 44) then ! Lock-exchange K-H instability on a very large-scale
3290 
3291  !Background state
3292  p00 = 1000.e2
3293  ps(:,:) = p00
3294  phis = 0.0
3295  u(:,:,:) = 0.
3296  v(:,:,:) = 0.
3297  q(:,:,:,:) = 0.
3298 
3299  if (adiabatic) then
3300  zvir = 0.
3301  else
3302  zvir = rvgas/rdgas - 1.
3303  endif
3304 
3305 ! Initialize delta-P
3306  do z=1,npz
3307  do j=js,je
3308  do i=is,ie
3309  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3310  enddo
3311  enddo
3312  enddo
3313 
3314  do j=js,je
3315  do i=is,ie
3316  pe(i,1,j) = ptop
3317  peln(i,1,j) = log(pe(i,1,j))
3318  pk(i,j,1) = exp(kappa*peln(i,1,j))
3319  enddo
3320  do k=2,npz+1
3321  do i=is,ie
3322  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3323  peln(i,k,j) = log(pe(i,k,j))
3324  pk(i,j,k) = exp(kappa*peln(i,k,j))
3325  enddo
3326  enddo
3327  enddo
3328 
3329  p1(1) = pi
3330  p1(2) = 0.
3331  r0 = 1000.e3 ! hurricane size
3332 
3333  do k=1,npz
3334  do j=js,je
3335  do i=is,ie
3336  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3337  dist = great_circle_dist( p0, agrid(i,j,1:2), radius )
3338  if ( dist .le. r0 ) then
3339  pt(i,j,k) = 275.
3340  q(i,j,k,1) = 1.
3341  else
3342  pt(i,j,k) = 265.
3343  q(i,j,k,1) = 0.
3344  end if
3345 ! pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3346  enddo
3347  enddo
3348  enddo
3349 
3350  if (.not.hydrostatic) then
3351  do k=1,npz
3352  do j=js,je
3353  do i=is,ie
3354  delz(i,j,k) = rdgas*pt(i,j,k)*(1.+zvir*q(i,j,k,1))/grav*log(pe(i,k,j)/pe(i,k+1,j))
3355  w(i,j,k) = 0.0
3356  enddo
3357  enddo
3358  enddo
3359  endif
3360 
3361  else if (test_case == 45 .or. test_case == 46) then ! NGGPS test?
3362 
3363 ! Background state
3364  f0 = 0.; fc = 0.
3365  pt0 = 300. ! potentil temperature
3366  p00 = 1000.e2
3367  ps(:,:) = p00
3368  phis = 0.0
3369  u(:,:,:) = 0.
3370  v(:,:,:) = 0.
3371  q(:,:,:,:) = 0.
3372 
3373  if (adiabatic) then
3374  zvir = 0.
3375  else
3376  zvir = rvgas/rdgas - 1.
3377  endif
3378 
3379 ! Initialize delta-P
3380  do k=1,npz
3381  do j=js,je
3382  do i=is,ie
3383  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
3384  enddo
3385  enddo
3386  enddo
3387 
3388  do j=js,je
3389  do i=is,ie
3390  pe(i,1,j) = ptop
3391  peln(i,1,j) = log(pe(i,1,j))
3392  pk(i,j,1) = exp(kappa*peln(i,1,j))
3393  enddo
3394  do k=2,npz+1
3395  do i=is,ie
3396  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3397  peln(i,k,j) = log(pe(i,k,j))
3398  pk(i,j,k) = exp(kappa*peln(i,k,j))
3399  enddo
3400  enddo
3401  enddo
3402 
3403 ! Initiate the westerly-wind-burst:
3404  ubar = soliton_umax
3405  r0 = soliton_size
3406 !!$ if (test_case == 46) then
3407 !!$ ubar = 200.
3408 !!$ r0 = 250.e3
3409 !!$ else
3410 !!$ ubar = 50. ! Initial maxmium wind speed (m/s)
3411 !!$ r0 = 500.e3
3412 !!$ endif
3413  p0(1) = pi*0.5
3414  p0(2) = 0.
3415 
3416  do k=1,npz
3417  do j=js,je
3418  do i=is,ie+1
3419  p1(:) = grid(i ,j ,1:2)
3420  p2(:) = grid(i,j+1 ,1:2)
3421  call mid_pt_sphere(p1, p2, p3)
3422  r = great_circle_dist( p0, p3, radius )
3423  utmp = ubar*exp(-(r/r0)**2)
3424  call get_unit_vect2(p1, p2, e2)
3425  call get_latlon_vector(p3, ex, ey)
3426  v(i,j,k) = utmp*inner_prod(e2,ex)
3427  enddo
3428  enddo
3429  do j=js,je+1
3430  do i=is,ie
3431  p1(:) = grid(i, j,1:2)
3432  p2(:) = grid(i+1,j,1:2)
3433  call mid_pt_sphere(p1, p2, p3)
3434  r = great_circle_dist( p0, p3, radius )
3435  utmp = ubar*exp(-(r/r0)**2)
3436  call get_unit_vect2(p1, p2, e1)
3437  call get_latlon_vector(p3, ex, ey)
3438  u(i,j,k) = utmp*inner_prod(e1,ex)
3439  enddo
3440  enddo
3441 
3442  do j=js,je
3443  do i=is,ie
3444  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3445 #ifdef USE_PT
3446  pt(i,j,k) = pt0/p00**kappa
3447 ! Convert back to temperature:
3448  pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3449 #else
3450  pt(i,j,k) = pt0
3451 #endif
3452  q(i,j,k,1) = 0.
3453  enddo
3454  enddo
3455 
3456  enddo
3457 
3458 #ifdef NEST_TEST
3459  do k=1,npz
3460  do j=js,je
3461  do i=is,ie
3462  q(i,j,k,:) = agrid(i,j,1)*0.180/pi
3463  enddo
3464  enddo
3465  enddo
3466 #else
3467  call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
3468  ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
3469 #endif
3470 
3471  if ( .not. hydrostatic ) then
3472  do k=1,npz
3473  do j=js,je
3474  do i=is,ie
3475  delz(i,j,k) = rdgas*pt(i,j,k)/grav*log(pe(i,k,j)/pe(i,k+1,j))
3476  w(i,j,k) = 0.0
3477  enddo
3478  enddo
3479  enddo
3480  endif
3481  else if (test_case == 55 .or. test_case == 56 .or. test_case == 57) then
3482 
3483  !Tropical cyclone test case: DCMIP 5X
3484 
3485  !test_case 56 initializes the environment
3486  ! but no vortex
3487 
3488  !test_case 57 uses a globally-uniform f-plane
3489 
3490  ! Initialize surface Pressure
3491  !Vortex perturbation
3492  p0(1) = 180. * pi / 180.
3493  p0(2) = 10. * pi / 180.
3494 
3495  if (test_case == 56) then
3496  dp = 0.
3497  rp = 1.e25
3498  else
3499  dp = 1115.
3500  rp = 282000.
3501  endif
3502  p00 = 101500.
3503 
3504  ps = p00
3505 
3506  do j=js,je
3507  do i=is,ie
3508  p2(:) = agrid(i,j,1:2)
3509  r = great_circle_dist( p0, p2, radius )
3510  ps(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3511  phis(i,j) = 0.
3512  enddo
3513  enddo
3514 
3515  call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3516 
3517  ! Initialize delta-P
3518  do z=1,npz
3519  do j=js,je
3520  do i=is,ie
3521  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3522  enddo
3523  enddo
3524  enddo
3525 
3526  !Pressure
3527  do j=js,je
3528  do i=is,ie
3529  pe(i,1,j) = ptop
3530  enddo
3531  do k=2,npz+1
3532  do i=is,ie
3533  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3534  enddo
3535  enddo
3536  enddo
3537 
3538  !Pressure on v-grid and u-grid points
3539  do j=js,je
3540  do i=is,ie+1
3541  p2(:) = 0.5*(grid(i,j,1:2)+grid(i,j+1,1:2))
3542  r = great_circle_dist( p0, p2, radius )
3543  ps_v(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3544  enddo
3545  enddo
3546  do j=js,je+1
3547  do i=is,ie
3548  p2(:) = 0.5*(grid(i,j,1:2)+grid(i+1,j,1:2))
3549  r = great_circle_dist( p0, p2, radius )
3550  ps_u(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3551  enddo
3552  enddo
3553 
3554  !Pressure
3555  do j=js,je
3556  do i=is,ie+1
3557  pe_v(i,1,j) = ptop
3558  enddo
3559  do k=2,npz+1
3560  do i=is,ie+1
3561  pe_v(i,k,j) = ak(k) + ps_v(i,j)*bk(k)
3562  enddo
3563  enddo
3564  enddo
3565  do j=js,je+1
3566  do i=is,ie
3567  pe_u(i,1,j) = ptop
3568  enddo
3569  do k=2,npz+1
3570  do i=is,ie
3571  pe_u(i,k,j) = ak(k) + ps_u(i,j)*bk(k)
3572  enddo
3573  enddo
3574  enddo
3575 
3576  !Everything else
3577  !if (adiabatic) then
3578  ! zvir = 0.
3579  !else
3580  zvir = rvgas/rdgas - 1.
3581  !endif
3582 
3583  p0 = (/ pi, pi/18. /)
3584 
3585  exppr = 1.5
3586  exppz = 2.
3587  gamma = 0.007
3588  ts0 = 302.15
3589  q00 = 0.021
3590  t00 = ts0*(1.+zvir*q00)
3591  exponent = rdgas*gamma/grav
3592  ztrop = 15000.
3593  zp = 7000.
3594  dp = 1115.
3595  cor = 2.*omega*sin(p0(2)) !Coriolis at vortex center
3596 
3597  !Initialize winds separately on the D-grid
3598  do j=js,je
3599  do i=is,ie+1
3600  p1(:) = grid(i ,j ,1:2)
3601  p2(:) = grid(i,j+1 ,1:2)
3602  call mid_pt_sphere(p1, p2, p3)
3603  call get_unit_vect2(p1, p2, e2)
3604  call get_latlon_vector(p3, ex, ey)
3605 
3606  d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3607  d2 = cos(p0(2))*sin(p3(1)-p0(1))
3608  d = max(1.e-15,sqrt(d1**2+d2**2))
3609 
3610  r = great_circle_dist( p0, p3, radius )
3611 
3612  do k=1,npz
3613  ptmp = 0.5*(pe_v(i,k,j)+pe_v(i,k+1,j))
3614  height = (t00/gamma)*(1.-(ptmp/ps_v(i,j))**exponent)
3615  if (height > ztrop) then
3616  v(i,j,k) = 0.
3617  else
3618  utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3619  - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3620  /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3621  +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3622  vtmp = utmp*d2
3623  utmp = utmp*d1
3624 
3625  v(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
3626 
3627  endif
3628  enddo
3629  enddo
3630  enddo
3631  do j=js,je+1
3632  do i=is,ie
3633  p1(:) = grid(i, j,1:2)
3634  p2(:) = grid(i+1,j,1:2)
3635  call mid_pt_sphere(p1, p2, p3)
3636  call get_unit_vect2(p1, p2, e1)
3637  call get_latlon_vector(p3, ex, ey)
3638 
3639  d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3640  d2 = cos(p0(2))*sin(p3(1)-p0(1))
3641  d = max(1.e-15,sqrt(d1**2+d2**2))
3642 
3643  r = great_circle_dist( p0, p3, radius )
3644 
3645  do k=1,npz
3646  ptmp = 0.5*(pe_u(i,k,j)+pe_u(i,k+1,j))
3647  height = (t00/gamma)*(1.-(ptmp/ps_u(i,j))**exponent)
3648  if (height > ztrop) then
3649  v(i,j,k) = 0.
3650  else
3651  utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3652  - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3653  /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3654  +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3655  vtmp = utmp*d2
3656  utmp = utmp*d1
3657 
3658  u(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
3659  endif
3660  enddo
3661 
3662  enddo
3663  enddo
3664 
3665  qtrop = 1.e-11
3666  ttrop = t00 - gamma*ztrop
3667  zq1 = 3000.
3668  zq2 = 8000.
3669 
3670  q(:,:,:,:) = 0.
3671 
3672  do k=1,npz
3673  do j=js,je
3674  do i=is,ie
3675  ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
3676  height = (t00/gamma)*(1.-(ptmp/ps(i,j))**exponent)
3677  if (height > ztrop) then
3678  q(i,j,k,1) = qtrop
3679  pt(i,j,k) = ttrop
3680  else
3681  q(i,j,k,1) = q00*exp(-height/zq1)*exp(-(height/zq2)**exppz)
3682  p2(:) = agrid(i,j,1:2)
3683  r = great_circle_dist( p0, p2, radius )
3684  pt(i,j,k) = (t00-gamma*height)/(1.d0+zvir*q(i,j,k,1))/(1.d0+exppz*rdgas*(t00-gamma*height)*height &
3685  /(grav*zp**exppz*(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz))))
3686  end if
3687  enddo
3688  enddo
3689  enddo
3690 
3691  !Note that this is already the moist pressure
3692  do j=js,je
3693  do i=is,ie
3694  ps(i,j) = pe(i,npz+1,j)
3695  enddo
3696  enddo
3697 
3698  if (.not.hydrostatic) then
3699  do k=1,npz
3700  do j=js,je
3701  do i=is,ie
3702  delz(i,j,k) = rdgas*pt(i,j,k)*(1.+zvir*q(i,j,k,1))/grav*log(pe(i,k,j)/pe(i,k+1,j))
3703  w(i,j,k) = 0.0
3704  enddo
3705  enddo
3706  enddo
3707  endif
3708 
3709  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
3710 
3711  call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3712 
3713  if (test_case == 57) then
3714  do j=jsd,jed+1
3715  do i=isd,ied+1
3716  fc(i,j) = cor
3717  enddo
3718  enddo
3719  do j=jsd,jed
3720  do i=isd,ied
3721  f0(i,j) = cor
3722  enddo
3723  enddo
3724  endif
3725 
3726 
3727  else if ( test_case == -55 ) then
3728 
3729  call dcmip16_tc (delp, pt, u, v, q, w, delz, &
3730  is, ie, js, je, isd, ied, jsd, jed, npz, ncnst, &
3731  ak, bk, ptop, pk, peln, pe, pkz, gz, phis, &
3732  ps, grid, agrid, hydrostatic, nwat, adiabatic)
3733 
3734  else
3735 
3736  call mpp_error(fatal, " test_case not defined" )
3737 
3738  endif !test_case
3739 
3740  call mpp_update_domains( phis, domain )
3741 
3742  ftop = g_sum(domain, phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
3743  if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav
3744 
3745 ! The flow is initially hydrostatic
3746 #ifndef SUPER_K
3747  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3748  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., mountain, &
3749  moist_phys, hydrostatic, nwat, domain, .not.hydrostatic)
3750 #endif
3751 
3752 #ifdef COLUMN_TRACER
3753  if( ncnst>1 ) q(:,:,:,2:ncnst) = 0.0
3754  ! Initialize a dummy Column Tracer
3755  pcen(1) = pi/9.
3756  pcen(2) = 2.0*pi/9.
3757  r0 = radius/10.0
3758  do z=1,npz
3759  do j=js,je
3760  do i=is,ie
3761  p1(:) = grid(i ,j ,1:2)
3762  p2(:) = grid(i,j+1 ,1:2)
3763  call mid_pt_sphere(p1, p2, pa)
3764  call get_unit_vect2(p1, p2, e2)
3765  call get_latlon_vector(pa, ex, ey)
3766  ! Perturbation Location Case==13
3767  r = great_circle_dist( pcen, pa, radius )
3768  if (-(r/r0)**2.0 > -40.0) q(i,j,z,1) = exp(-(r/r0)**2.0)
3769  enddo
3770  enddo
3771  enddo
3772 #endif
3773 
3774 #endif
3775  call mp_update_dwinds(u, v, npx, npy, npz, domain)
3776 
3777 
3778  nullify(agrid)
3779  nullify(grid)
3780 
3781  nullify(area)
3782  nullify(rarea)
3783 
3784  nullify(fc)
3785  nullify(f0)
3786 
3787  nullify(dx)
3788  nullify(dy)
3789  nullify(dxa)
3790  nullify(dya)
3791  nullify(rdxa)
3792  nullify(rdya)
3793  nullify(dxc)
3794  nullify(dyc)
3795 
3796  nullify(ee1)
3797  nullify(ee2)
3798  nullify(ew)
3799  nullify(es)
3800  nullify(en1)
3801  nullify(en2)
3802 
3803  nullify(latlon)
3804  nullify(cubed_sphere)
3805 
3806  nullify(domain)
3807  nullify(tile)
3808 
3809  nullify(have_south_pole)
3810  nullify(have_north_pole)
3811 
3812  nullify(ntiles_g)
3813  nullify(acapn)
3814  nullify(acaps)
3815  nullify(globalarea)
3816 
3817  end subroutine init_case
3818 
3819  subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
3820  integer isd, ied, jsd, jed, npz
3821  integer isc, iec, jsc, jec
3822  real, intent(in) :: u(isd:ied, jsd:jed+1, npz), v(isd:ied+1, jsd:jed, npz)
3823  real, intent(out) :: vort(isc:iec, jsc:jec, npz)
3824  real, intent(IN) :: dx(isd:ied,jsd:jed+1)
3825  real, intent(IN) :: dy(isd:ied+1,jsd:jed)
3826  real, intent(IN) :: rarea(isd:ied,jsd:jed)
3827 ! Local
3828  real :: utmp(isc:iec, jsc:jec+1), vtmp(isc:iec+1, jsc:jec)
3829  integer :: i,j,k
3830 
3831  do k=1,npz
3832  do j=jsc,jec+1
3833  do i=isc,iec
3834  utmp(i,j) = u(i,j,k)*dx(i,j)
3835  enddo
3836  enddo
3837  do j=jsc,jec
3838  do i=isc,iec+1
3839  vtmp(i,j) = v(i,j,k)*dy(i,j)
3840  enddo
3841  enddo
3842 
3843  do j=jsc,jec
3844  do i=isc,iec
3845  vort(i,j,k) = rarea(i,j)*(utmp(i,j)-utmp(i,j+1)-vtmp(i,j)+vtmp(i+1,j))
3846  enddo
3847  enddo
3848  enddo
3849 
3850  end subroutine get_vorticity
3851 
3852  subroutine checker_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3853  nq, km, q, lon, lat, nx, ny, rn)
3854 !--------------------------------------------------------------------
3855 ! This routine computes the checker-board tracer pattern with optional
3856 ! random pertubation (if rn/= 0)
3857 ! To get 20 (deg) by 20 (deg) checker boxes: nx=9, ny=9
3858 ! If random noises are desired, rn=0.1 is a good value
3859 ! lon: longitude (Radian)
3860 ! lat: latitude (Radian)
3861 ! Coded by S.-J. Lin for HIWPP benchmark, Oct2, 2014
3862 !--------------------------------------------------------------------
3863  integer, intent(in):: nq ! number of tracers
3864  integer, intent(in):: km ! vertical dimension
3865  integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3866  integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3867  integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3868  real, intent(in):: nx ! east-west wave number
3869  real, intent(in):: ny ! North-south wave number
3870  real, intent(in), optional:: rn ! (optional) magnitude of random perturbation
3871  real(kind=R_GRID), intent(in), dimension(i0:i1,j0:j1):: lon, lat
3872  real, intent(out):: q(ifirst:ilast,jfirst:jlast,km,nq)
3873 ! Local var:
3874  real:: qt(i0:i1,j0:j1)
3875  real:: qtmp, ftmp
3876  integer:: i,j,k,iq
3877 
3878 !$OMP parallel do default(none) shared(i0,i1,j0,j1,nx,lon,ny,lat,qt) &
3879 !$OMP private(qtmp)
3880  do j=j0,j1
3881  do i=i0,i1
3882  qtmp = sin(nx*lon(i,j))*sin(ny*lat(i,j))
3883  if ( qtmp < 0. ) then
3884  qt(i,j) = 0.
3885  else
3886  qt(i,j) = 1.
3887  endif
3888  enddo
3889  enddo
3890 
3891  if ( present(rn) ) then ! Add random noises to the set pattern
3892  do iq=1,nq
3893  call random_seed()
3894 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,rn,iq) &
3895 !$OMP private(ftmp)
3896  do k=1,km
3897  do j=j0,j1
3898  do i=i0,i1
3899  call random_number(ftmp)
3900  q(i,j,k,iq) = qt(i,j) + rn*ftmp
3901  enddo
3902  enddo
3903  enddo
3904  enddo
3905  else
3906  do iq=1,nq
3907 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,iq) &
3908 !$OMP private(ftmp)
3909  do k=1,km
3910  do j=j0,j1
3911  do i=i0,i1
3912  q(i,j,k,iq) = qt(i,j)
3913  enddo
3914  enddo
3915  enddo
3916  enddo
3917  endif
3918 
3919  end subroutine checker_tracers
3920 
3921  subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3922  km, q, delp, ncnst, lon, lat)
3923 !--------------------------------------------------------------------
3924 ! This routine implements the terminator test.
3925 ! Coded by Lucas Harris for DCMIP 2016, May 2016
3926 !--------------------------------------------------------------------
3927  integer, intent(in):: km ! vertical dimension
3928  integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3929  integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3930  integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3931  integer, intent(in):: ncnst
3932  real(kind=R_GRID), intent(in), dimension(ifirst:ilast,jfirst:jlast):: lon, lat
3933  real, intent(inout):: q(ifirst:ilast,jfirst:jlast,km,ncnst)
3934  real, intent(in):: delp(ifirst:ilast,jfirst:jlast,km)
3935 ! Local var:
3936  real:: D, k1, r, ll, sinthc, costhc, mm
3937  integer:: i,j,k
3938  integer:: Cl, Cl2
3939 
3940  !NOTE: If you change the reaction rates, then you will have to change it both
3941  ! here and in fv_phys
3942  real, parameter :: qcly = 4.e-6
3943  real, parameter :: lc = 5.*pi/3.
3944  real, parameter :: thc = pi/9.
3945  real, parameter :: k2 = 1.
3946 
3947  sinthc = sin(thc)
3948  costhc = cos(thc)
3949 
3950  cl = get_tracer_index(model_atmos, 'Cl')
3951  cl2 = get_tracer_index(model_atmos, 'Cl2')
3952 
3953  do j=j0,j1
3954  do i=i0,i1
3955  k1 = max(0., sin(lat(i,j))*sinthc + cos(lat(i,j))*costhc*cos(lon(i,j) - lc))
3956  r = k1/k2 * 0.25
3957  d = sqrt(r*r + 2.*r*qcly)
3958  q(i,j,1,cl) = d - r
3959  q(i,j,1,cl2) = 0.5*(qcly - q(i,j,1,cl))
3960  enddo
3961  enddo
3962 
3963  do k=2,km
3964  do j=j0,j1
3965  do i=i0,i1
3966  q(i,j,k,cl) = q(i,j,1,cl)
3967  q(i,j,k,cl2) = q(i,j,1,cl2)
3968  enddo
3969  enddo
3970  enddo
3971 
3972  !Compute qcly0
3973  qcly0 = 0.
3974  if (is_master()) then
3975  i = is
3976  j = js
3977  mm = 0.
3978  do k=1,km
3979  qcly0 = qcly0 + (q(i,j,k,cl) + 2.*q(i,j,k,cl2))*delp(i,j,k)
3980  mm = mm + delp(i,j,k)
3981  enddo
3982  qcly0 = qcly0/mm
3983  endif
3984  call mpp_sum(qcly0)
3985  if (is_master()) print*, ' qcly0 = ', qcly0
3986 
3987 
3988 end subroutine terminator_tracers
3989 
3990  subroutine rankine_vortex(ubar, r0, p1, u, v, grid )
3991 !----------------------------
3992 ! Rankine vortex
3993 !----------------------------
3994  real, intent(in):: ubar ! max wind (m/s)
3995  real, intent(in):: r0 ! Radius of max wind (m)
3996  real, intent(in):: p1(2) ! center position (longitude, latitude) in radian
3997  real, intent(inout):: u(isd:ied, jsd:jed+1)
3998  real, intent(inout):: v(isd:ied+1,jsd:jed)
3999  real(kind=R_GRID), intent(IN) :: grid(isd:ied+1,jsd:jed+1,2)
4000 ! local:
4001  real(kind=R_GRID):: p2(2), p3(2), p4(2)
4002  real(kind=R_GRID):: e1(3), e2(3), ex(3), ey(3)
4003  real:: vr, r, d2, cos_p, x1, y1
4004  real:: utmp, vtmp
4005  integer i, j
4006 
4007 ! Compute u-wind
4008  do j=js,je+1
4009  do i=is,ie
4010  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
4011 ! shift:
4012  p2(1) = p2(1) - p1(1)
4013  cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
4014  r = radius*acos(cos_p) ! great circle distance
4015 ! if( r<0.) call mpp_error(FATAL, 'radius negative!')
4016  if( r<r0 ) then
4017  vr = ubar*r/r0
4018  else
4019  vr = ubar*r0/r
4020  endif
4021  x1 = cos(p2(2))*sin(p2(1))
4022  y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
4023  d2 = max(1.e-25, sqrt(x1**2 + y1**2))
4024  utmp = -vr*y1/d2
4025  vtmp = vr*x1/d2
4026  p3(1) = grid(i,j, 1) - p1(1)
4027  p3(2) = grid(i,j, 2)
4028  p4(1) = grid(i+1,j,1) - p1(1)
4029  p4(2) = grid(i+1,j,2)
4030  call get_unit_vect2(p3, p4, e1)
4031  call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
4032  u(i,j) = u(i,j) + utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4033  enddo
4034  enddo
4035 
4036 ! Compute v-wind
4037  do j=js,je
4038  do i=is,ie+1
4039  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
4040 ! shift:
4041  p2(1) = p2(1) - p1(1)
4042  cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
4043  r = radius*acos(cos_p) ! great circle distance
4044  if( r<r0 ) then
4045  vr = ubar*r/r0
4046  else
4047  vr = ubar*r0/r
4048  endif
4049  x1 = cos(p2(2))*sin(p2(1))
4050  y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
4051  d2 = max(1.e-25, sqrt(x1**2 + y1**2))
4052  utmp = -vr*y1/d2
4053  vtmp = vr*x1/d2
4054  p3(1) = grid(i,j, 1) - p1(1)
4055  p3(2) = grid(i,j, 2)
4056  p4(1) = grid(i,j+1,1) - p1(1)
4057  p4(2) = grid(i,j+1,2)
4058  call get_unit_vect2(p3, p4, e2)
4059  call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
4060  v(i,j) = v(i,j) + utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4061  enddo
4062  enddo
4063  end subroutine rankine_vortex
4064 
4065 
4066 
4067  real function gh_jet(npy, lat_in)
4068  integer, intent(in):: npy
4069  real, intent(in):: lat_in
4070  real lat, lon, dp, uu
4071  real h0, ft
4072  integer j,jm
4073 
4074  jm = 4 * npy
4075 ! h0 = 10.E3
4076  h0 = 10.157946867e3
4077  dp = pi / real(jm-1)
4078 
4079  if ( .not. gh_initialized ) then
4080 ! SP:
4081  allocate(gh_table(jm))
4082  allocate(lats_table(jm))
4083  gh_table(1) = grav*h0
4084  lats_table(1) = -pi/2.
4085 ! Using only the mid-point for integration
4086  do j=2,jm
4087  lat = -pi/2. + (real(j-1)-0.5)*dp
4088  uu = u_jet(lat)
4089  ft = 2.*omega*sin(lat)
4090  gh_table(j) = gh_table(j-1) - uu*(radius*ft + tan(lat)*uu) * dp
4091  lats_table(j) = -pi/2. + real(j-1)*dp
4092  enddo
4093  gh_initialized = .true.
4094  endif
4095 
4096  if ( lat_in <= lats_table(1) ) then
4097  gh_jet = gh_table(1)
4098  return
4099  endif
4100  if ( lat_in >= lats_table(jm) ) then
4101  gh_jet = gh_table(jm)
4102  return
4103  endif
4104 
4105 ! Search:
4106  do j=1,jm-1
4107  if ( lat_in >=lats_table(j) .and. lat_in<=lats_table(j+1) ) then
4108  gh_jet = gh_table(j) + (gh_table(j+1)-gh_table(j))/dp * (lat_in-lats_table(j))
4109  return
4110  endif
4111  enddo
4112  end function gh_jet
4113 
4114  real function u_jet(lat)
4115  real lat, lon, dp
4116  real umax, en, ph0, ph1
4117 
4118  umax = 80.
4119  ph0 = pi/7.
4120  ph1 = pi/2. - ph0
4121  en = exp( -4./(ph1-ph0)**2 )
4122 
4123  if ( lat>ph0 .and. lat<ph1 ) then
4124  u_jet = (umax/en)*exp( 1./( (lat-ph0)*(lat-ph1) ) )
4125  else
4126  u_jet = 0.
4127  endif
4128  end function u_jet
4129 
4130  subroutine get_case9_b(B, agrid)
4131  real, intent(OUT) :: B(isd:ied,jsd:jed)
4132  real, intent(IN) :: agrid(isd:ied,jsd:jed,2)
4133  real :: myC,yy,myB
4134  integer :: i,j
4135 ! Generate B forcing function
4136 !
4137  gh0 = 720.*grav
4138  do j=jsd,jed
4139  do i=isd,ied
4140  if (sin(agrid(i,j,2)) > 0.) then
4141  myc = sin(agrid(i,j,1))
4142  yy = (cos(agrid(i,j,2))/sin(agrid(i,j,2)))**2
4143  myb = gh0*yy*exp(1.-yy)
4144  b(i,j) = myb*myc
4145  else
4146  b(i,j) = 0.
4147  endif
4148  enddo
4149  enddo
4150 
4151  end subroutine get_case9_b
4152 !
4153 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4154 !-------------------------------------------------------------------------------
4155 
4156 !-------------------------------------------------------------------------------
4157 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4158 !
4159  subroutine case9_forcing1(phis,time_since_start)
4160 
4161  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4162  real , intent(IN) :: time_since_start
4163  real :: tday, amean
4164  integer :: i,j
4165 !
4166 ! Generate B forcing function
4167 !
4168  tday = time_since_start/86400.0
4169  if (tday >= 20.) then
4170  aoft(2) = 0.5*(1.-cos(0.25*pi*(tday-20)))
4171  if (tday == 24) aoft(2) = 1.0
4172  elseif (tday <= 4.) then
4173  aoft(2) = 0.5*(1.-cos(0.25*pi*tday))
4174  elseif (tday <= 16.) then
4175  aoft(2) = 1.
4176  else
4177  aoft(2) = 0.5*(1.+cos(0.25*pi*(tday-16.)))
4178  endif
4179  amean = 0.5*(aoft(1)+aoft(2))
4180  do j=jsd,jed
4181  do i=isd,ied
4182  phis(i,j) = amean*case9_b(i,j)
4183  enddo
4184  enddo
4185 
4186  end subroutine case9_forcing1
4187 !
4188 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4189 !-------------------------------------------------------------------------------
4190 
4191 !-------------------------------------------------------------------------------
4192 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4193 !
4194  subroutine case9_forcing2(phis)
4195  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4196  integer :: i,j
4197 !
4198 ! Generate B forcing function
4199 !
4200  do j=jsd,jed
4201  do i=isd,ied
4202  phis(i,j) = aoft(2)*case9_b(i,j)
4203  enddo
4204  enddo
4205  aoft(1) = aoft(2)
4206 
4207  end subroutine case9_forcing2
4208 !
4209 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4210 !-------------------------------------------------------------------------------
4211 
4212  subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain)
4213 
4214  real, intent(INOUT) :: delp(isd:ied,jsd:jed,npz)
4215  real, intent(INOUT) :: uc(isd:ied+1,jsd:jed,npz)
4216  real, intent(INOUT) :: vc(isd:ied,jsd:jed+1,npz)
4217  real, intent(INOUT) :: u(isd:ied,jsd:jed+1,npz)
4218  real, intent(INOUT) :: v(isd:ied+1,jsd:jed,npz)
4219  real, intent(INOUT) :: ua(isd:ied,jsd:jed,npz)
4220  real, intent(INOUT) :: va(isd:ied,jsd:jed,npz)
4221  real, intent(INOUT) :: pe(is-1:ie+1, npz+1,js-1:je+1) ! edge pressure (pascal)
4222  real, intent(IN) :: time, dt
4223  real, intent(INOUT) :: ptop
4224  integer, intent(IN) :: npx, npy, npz
4225  type(fv_grid_type), intent(IN), target :: gridstruct
4226  type(domain2d), intent(INOUT) :: domain
4227 
4228  real :: period
4229  real :: omega0
4230 
4231  integer :: i,j,k
4232 
4233  real :: s, l, dt2, v0, phase
4234  real :: ull, vll, lonp
4235  real :: p0(2), elon(3), elat(3)
4236 
4237  real :: psi(isd:ied,jsd:jed)
4238  real :: psi_b(isd:ied+1,jsd:jed+1)
4239  real :: dist, psi1, psi2
4240 
4241  real :: k_cell = 5
4242 
4243  real :: utmp, vtmp
4244  real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3), pt(2), p1(2), p2(2), p3(2), rperiod, timefac, t00
4245 
4246  integer :: wind_field = 1 !Should be the same as tracer_test
4247 
4248  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
4249  real, pointer, dimension(:,:) :: dx, dxa, dy, dya, dxc, dyc
4250 
4251  agrid => gridstruct%agrid_64
4252  grid => gridstruct%grid_64
4253 
4254  dx => gridstruct%dx
4255  dxa => gridstruct%dxa
4256  dxc => gridstruct%dxc
4257  dy => gridstruct%dy
4258  dya => gridstruct%dya
4259  dyc => gridstruct%dyc
4260 
4261  period = real( 12*24*3600 ) !12 days
4262 
4263  l = 2.*pi/period
4264  dt2 = dt*0.5
4265 
4266  phase = pi*time/period
4267 
4268  !call prt_maxmin('pe', pe, is, ie, js, je, 0, npz, 1.E-3)
4269 
4270  !Winds: NONDIVERGENT---just use streamfunction!
4271 
4272  psi(:,:) = 1.e25
4273  psi_b(:,:) = 1.e25
4274 
4275 
4276  select case (wind_field)
4277  case (0)
4278 
4279  omega0 = 23000.*pi/period
4280 
4281  t00 = 300.
4282  ptop = 100000.*exp(-12000.*grav/t00/rdgas)
4283 
4284  do j=js,je
4285  do k=1,npz+1
4286  do i=is,ie
4287  s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4288  pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4289  cos(period*(time+dt2))*sin(s*0.5*pi)
4290  enddo
4291  enddo
4292  enddo
4293 
4294  do k=1,npz
4295  do j=js,je
4296  do i=is,ie
4297  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4298  enddo
4299  enddo
4300  enddo
4301 
4302  v0 = 10.*radius/period !k in DCMIP document
4303  ubar = 40.
4304 
4305  do j=jsd,jed
4306  do i=isd,ied
4307  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
4308  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
4309  enddo
4310  enddo
4311  call mpp_update_domains( psi, domain )
4312  do j=jsd,jed+1
4313  do i=isd,ied+1
4314  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
4315  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
4316  enddo
4317  enddo
4318 
4319  k = 1
4320 
4321  do j=js,je+1
4322  do i=is,ie
4323  dist = dx(i,j)
4324  vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
4325  if (dist==0) vc(i,j,k) = 0.
4326  enddo
4327  enddo
4328  do j=js,je
4329  do i=is,ie+1
4330  dist = dy(i,j)
4331  uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
4332  if (dist==0) uc(i,j,k) = 0.
4333  enddo
4334  enddo
4335 
4336  do j=js,je
4337  do i=is,ie+1
4338  dist = dxc(i,j)
4339  v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
4340  if (dist==0) v(i,j,k) = 0.
4341  enddo
4342  enddo
4343  do j=js,je+1
4344  do i=is,ie
4345  dist = dyc(i,j)
4346  u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
4347  if (dist==0) u(i,j,k) = 0.
4348  enddo
4349  enddo
4350 
4351  do j=js,je
4352  do i=is,ie
4353  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
4354  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
4355  dist = dya(i,j)
4356  ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
4357  if (dist==0) ua(i,j,k) = 0.
4358  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
4359  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
4360  dist = dxa(i,j)
4361  va(i,j,k) = (psi2 - psi1) / (dist)
4362  if (dist==0) va(i,j,k) = 0.
4363  enddo
4364  enddo
4365 
4366  case (1)
4367 
4368  omega0 = 23000.*pi/period
4369 
4370  do j=js,je
4371  do k=1,npz+1
4372  do i=is,ie
4373  s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4374  pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4375  cos(period*(time+dt2))*sin(s*0.5*pi)
4376  enddo
4377  enddo
4378  enddo
4379 
4380  do k=1,npz
4381  do j=js,je
4382  do i=is,ie
4383  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4384  enddo
4385  enddo
4386  enddo
4387 
4388  ubar = 10.*radius/period !k in DCMIP document
4389 
4390 
4391  do j=js,je
4392  do i=is,ie+1
4393  p1(:) = grid(i ,j ,1:2)
4394  p2(:) = grid(i,j+1 ,1:2)
4395  call mid_pt_sphere(p1, p2, p3)
4396  call get_unit_vect2(p1, p2, e2) !! e2 is WRONG in halo??
4397  call get_latlon_vector(p3, ex, ey)
4398  l = p3(1) - 2.*pi*time/period
4399  utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*radius/period*cos(p3(2))
4400  vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4401  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4402  enddo
4403  enddo
4404  do j=js,je+1
4405  do i=is,ie
4406  p1(:) = grid(i, j,1:2)
4407  p2(:) = grid(i+1,j,1:2)
4408  call mid_pt_sphere(p1, p2, p3)
4409  call get_unit_vect2(p1, p2, e1)
4410  call get_latlon_vector(p3, ex, ey)
4411  l = p3(1) - 2.*pi*time/period
4412  utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*radius/period*cos(p3(2))
4413  vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4414  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4415  enddo
4416  enddo
4417 
4418  call mp_update_dwinds(u(:,:,1), v(:,:,1), npx, npy, domain)
4419 
4420 ! copy vertically; no wind shear
4421  do k=2,npz
4422  do j=jsd,jed+1
4423  do i=isd,ied
4424  u(i,j,k) = u(i,j,1)
4425  enddo
4426  enddo
4427  do j=jsd,jed
4428  do i=isd,ied+1
4429  v(i,j,k) = v(i,j,1)
4430  enddo
4431  enddo
4432  enddo
4433 
4434  call mp_update_dwinds(u, v, npx, npy, npz, domain)
4435 
4436  call dtoa( u(:,:,1), v(:,:,1),ua(:,:,1),va(:,:,1),dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
4437  call mpp_update_domains( ua, va, domain, gridtype=agrid_param) !! ABSOLUTELY NECESSARY!!
4438  call atoc(ua(:,:,1),va(:,:,1),uc(:,:,1),vc(:,:,1),dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
4439 
4440  do k=2,npz
4441  do j=js,je
4442  do i=is,ie
4443  ua(i,j,k) = ua(i,j,1)
4444  enddo
4445  enddo
4446  do j=js,je
4447  do i=is,ie
4448  va(i,j,k) = va(i,j,1)
4449  enddo
4450  enddo
4451  enddo
4452 
4453  do k=2,npz
4454  do j=js,je+1
4455  do i=is,ie
4456  vc(i,j,k) = vc(i,j,1)
4457  enddo
4458  enddo
4459  do j=js,je
4460  do i=is,ie+1
4461  uc(i,j,k) = uc(i,j,1)
4462  enddo
4463  enddo
4464  enddo
4465 
4466  !cases 2 and 3 are not nondivergent so we cannot use a streamfunction.
4467  case (2)
4468 
4469  omega0 = 0.25
4470 
4471  do j=js,je
4472  do k=1,npz+1
4473  do i=is,ie
4474  pe(i,k,j) = pe(i,k,j) + dt*omega0*grav*pe(i,k,j)/rdgas/300./k_cell* &
4475  (-2.*sin(k_cell*agrid(i,j,2))*sin(agrid(i,j,2)) + k_cell*cos(agrid(i,j,2))*cos(k_cell*agrid(i,j,2)))* &
4476  sin(pi*zz0(k)/12000.)*cos(phase)
4477  enddo
4478  enddo
4479  enddo
4480 
4481  do k=1,npz
4482  do j=js,je
4483  do i=is,ie
4484  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4485  enddo
4486  enddo
4487  enddo
4488 
4489  ubar = 40.
4490 
4491  !Set lat-lon A-grid winds
4492  k = 1
4493  do j=js,je
4494  do i=is,ie
4495  utmp = ubar*cos(agrid(i,j,2))
4496  vtmp = - radius * omega0 * pi / k_cell / 12000. * &
4497  cos(agrid(i,j,2)) * sin(k_cell * agrid(i,j,2)) * &
4498  sin(pi*zz0(k)/12000.)*cos(phase)
4499  enddo
4500  enddo
4501 
4502  end select
4503 
4504  do k=2,npz
4505  u(:,:,k) = u(:,:,1)
4506  v(:,:,k) = v(:,:,1)
4507  uc(:,:,k) = uc(:,:,1)
4508  vc(:,:,k) = vc(:,:,1)
4509  ua(:,:,k) = ua(:,:,1)
4510  va(:,:,k) = va(:,:,1)
4511  enddo
4512 
4513  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
4514  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
4515  call mp_update_dwinds(u, v, npx, npy, npz, domain)
4516 
4517  nullify(agrid)
4518  nullify(grid)
4519 
4520  nullify(dx)
4521  nullify(dxa)
4522  nullify(dy)
4523  nullify(dya)
4524 
4525  end subroutine case51_forcing
4526 
4527 !-------------------------------------------------------------------------------
4528 !
4529 ! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined
4530 ! in Williamson, 1994 (p.16)
4531  subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, &
4532  uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, &
4533  gridstruct, stats_lun, consv_lun, monitorFreq, tile, &
4534  domain, nested)
4535  integer, intent(IN) :: nt, maxnt
4536  real , intent(IN) :: dt, dtout, ndays
4537  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
4538  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
4539  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
4540  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
4541  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
4542  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4543  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
4544  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
4545  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
4546  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
4547  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
4548  integer, intent(IN) :: npx, npy, npz, ncnst, tile
4549  integer, intent(IN) :: ndims
4550  integer, intent(IN) :: nregions
4551  integer, intent(IN) :: stats_lun
4552  integer, intent(IN) :: consv_lun
4553  integer, intent(IN) :: monitorfreq
4554  type(fv_grid_type), target :: gridstruct
4555  type(domain2d), intent(INOUT) :: domain
4556  logical, intent(IN) :: nested
4557 
4558  real :: l1_norm
4559  real :: l2_norm
4560  real :: linf_norm
4561  real :: pmin, pmin1, uamin1, vamin1
4562  real :: pmax, pmax1, uamax1, vamax1
4563  real(kind=4) :: arr_r4(5)
4564  real :: tmass0, tvort0, tener0, tke0
4565  real :: tmass, tvort, tener, tke
4566  real :: temp(is:ie,js:je)
4567  integer :: i0, j0, k0, n0
4568  integer :: i, j, k, n, iq
4569 
4570  real :: psmo, vtx, p, w_p, p0
4571  real :: x1,y1,z1,x2,y2,z2,ang
4572 
4573  real :: p1(2), p2(2), p3(2), r, r0, dist, heading
4574 
4575  real :: uc0(isd:ied+1,jsd:jed ,npz)
4576  real :: vc0(isd:ied ,jsd:jed+1,npz)
4577 
4578  real :: myday
4579  integer :: myrec
4580 
4581  real, save, allocatable, dimension(:,:,:) :: u0, v0
4582  real :: up(isd:ied ,jsd:jed+1,npz)
4583  real :: vp(isd:ied+1,jsd:jed ,npz)
4584 
4585  real, dimension(:,:,:), pointer :: grid, agrid
4586  real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc
4587 
4588  grid => gridstruct%grid
4589  agrid=> gridstruct%agrid
4590 
4591  area => gridstruct%area
4592  f0 => gridstruct%f0
4593 
4594  dx => gridstruct%dx
4595  dy => gridstruct%dy
4596  dxa => gridstruct%dxa
4597  dya => gridstruct%dya
4598  dxc => gridstruct%dxc
4599  dyc => gridstruct%dyc
4600 
4601  !!! DEBUG CODE
4602  if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS'
4603  !!! END DEBUG CODE
4604 
4605  myday = ndays*((float(nt)/float(maxnt)))
4606 
4607 #if defined(SW_DYNAMICS)
4608  if (test_case==0) then
4609  phi0 = 0.0
4610  do j=js,je
4611  do i=is,ie
4612  x1 = agrid(i,j,1)
4613  y1 = agrid(i,j,2)
4614  z1 = radius
4615  p = p0_c0 * cos(y1)
4616  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
4617  w_p = 0.0
4618  if (p /= 0.0) w_p = vtx/p
4619  ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4620  phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4621  enddo
4622  enddo
4623  elseif (test_case==1) then
4624 ! Get Current Height Field "Truth"
4625  p1(1) = pi/2. + pi_shift
4626  p1(2) = 0.
4627  p2(1) = 3.*pi/2. + pi_shift
4628  p2(2) = 0.
4629  r0 = radius/3. !RADIUS 3.
4630  dist = 2.0*pi*radius* ((float(nt)/float(maxnt)))
4631  heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha
4632  call get_pt_on_great_circle( p1, p2, dist, heading, p3)
4633  phi0 = 0.0
4634  do j=js,je
4635  do i=is,ie
4636  p2(1) = agrid(i,j,1)
4637  p2(2) = agrid(i,j,2)
4638  r = great_circle_dist( p3, p2, radius )
4639  if (r < r0) then
4640  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
4641  else
4642  phi0(i,j,1) = phis(i,j)
4643  endif
4644  enddo
4645  enddo
4646  endif
4647 
4648 ! Get Height Field Stats
4649  call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4650  pmin1=pmin1/grav
4651  pmax1=pmax1/grav
4652  if (test_case <= 2) then
4653  call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, &
4654  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
4655  pmin=pmin/grav
4656  pmax=pmax/grav
4657  arr_r4(1) = pmin1
4658  arr_r4(2) = pmax1
4659  arr_r4(3) = l1_norm
4660  arr_r4(4) = l2_norm
4661  arr_r4(5) = linf_norm
4662  !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4
4663  else
4664  arr_r4(1) = pmin1
4665  arr_r4(2) = pmax1
4666  arr_r4(3:5) = 0.
4667  pmin = 0.
4668  pmax = 0.
4669  l1_norm = 0.
4670  l2_norm = 0.
4671  linf_norm = 0.
4672  endif
4673 
4674  200 format(i6.6,a,i6.6,a,e21.14)
4675  201 format(' ',a,e21.14,' ',e21.14)
4676  202 format(' ',a,i4.4,'x',i4.4,'x',i4.4)
4677 
4678  if ( (is_master()) .and. mod(nt,monitorfreq)==0 ) then
4679  write(*,200) nt, ' step of ', maxnt, ' DAY ', myday
4680  write(*,201) 'Height MAX : ', pmax1
4681  write(*,201) 'Height MIN : ', pmin1
4682  write(*,202) 'HGT MAX location : ', i0, j0, n0
4683  if (test_case <= 2) then
4684  write(*,201) 'Height L1_norm : ', l1_norm
4685  write(*,201) 'Height L2_norm : ', l2_norm
4686  write(*,201) 'Height Linf_norm : ', linf_norm
4687  endif
4688  endif
4689 
4690 ! Get UV Stats
4691  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
4692  call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4693  if (test_case <= 2) then
4694  call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, &
4695  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
4696  endif
4697  arr_r4(1) = pmin1
4698  arr_r4(2) = pmax1
4699  arr_r4(3) = l1_norm
4700  arr_r4(4) = l2_norm
4701  arr_r4(5) = linf_norm
4702  !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4
4703  if ( (is_master()) .and. mod(nt,monitorfreq)==0) then
4704  write(*,201) 'UV MAX : ', pmax1
4705  write(*,201) 'UV MIN : ', pmin1
4706  write(*,202) 'UV MAX location : ', i0, j0, n0
4707  if (test_case <= 2) then
4708  write(*,201) 'UV L1_norm : ', l1_norm
4709  write(*,201) 'UV L2_norm : ', l2_norm
4710  write(*,201) 'UV Linf_norm : ', linf_norm
4711  endif
4712  endif
4713 #else
4714 
4715  200 format(i6.6,a,i6.6,a,e10.4)
4716  201 format(' ',a,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4717  202 format(' ',a,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4)
4718  203 format(' ',a,i3.3,a,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4719 
4720  if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myday
4721 
4722 ! Surface Pressure
4723  psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4724  if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo
4725  call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4726  if (is_master()) then
4727  write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0
4728  endif
4729 
4730 ! Get PT Stats
4731  pmax1 = -1.e25
4732  pmin1 = 1.e25
4733  i0=-999
4734  j0=-999
4735  k0=-999
4736  n0=-999
4737  do k=1,npz
4738  call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4739  pmin1 = min(pmin, pmin1)
4740  pmax1 = max(pmax, pmax1)
4741  if (pmax1 == pmax) k0 = k
4742  enddo
4743  if (is_master()) then
4744  write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4745  endif
4746 
4747 #if defined(DEBUG_TEST_CASES)
4748  if(is_master()) write(*,*) ' '
4749  do k=1,npz
4750  pmax1 = -1.e25
4751  pmin1 = 1.e25
4752  i0=-999
4753  j0=-999
4754  k0=-999
4755  n0=-999
4756  call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4757  pmin1 = min(pmin, pmin1)
4758  pmax1 = max(pmax, pmax1)
4759  if (is_master()) then
4760  write(*,202) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k, n0, 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
4761  endif
4762  enddo
4763  if(is_master()) write(*,*) ' '
4764 #endif
4765 
4766 ! Get DELP Stats
4767  pmax1 = -1.e25
4768  pmin1 = 1.e25
4769  i0=-999
4770  j0=-999
4771  k0=-999
4772  n0=-999
4773  do k=1,npz
4774  call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4775  pmin1 = min(pmin, pmin1)
4776  pmax1 = max(pmax, pmax1)
4777  if (pmax1 == pmax) k0 = k
4778  enddo
4779  if (is_master()) then
4780  write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4781  endif
4782 
4783 ! Get UV Stats
4784  uamax1 = -1.e25
4785  uamin1 = 1.e25
4786  i0=-999
4787  j0=-999
4788  k0=-999
4789  n0=-999
4790  do k=1,npz
4791  call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
4792  call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4793  uamin1 = min(pmin, uamin1)
4794  uamax1 = max(pmax, uamax1)
4795  if (uamax1 == pmax) k0 = k
4796  enddo
4797  if (is_master()) then
4798  write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0
4799  endif
4800 
4801  vamax1 = -1.e25
4802  vamin1 = 1.e25
4803  i0=-999
4804  j0=-999
4805  k0=-999
4806  n0=-999
4807  do k=1,npz
4808  call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4809  vamin1 = min(pmin, vamin1)
4810  vamax1 = max(pmax, vamax1)
4811  if (vamax1 == pmax) k0 = k
4812  enddo
4813  if (is_master()) then
4814  write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0
4815  endif
4816 
4817 ! Get Q Stats
4818  pmax1 = -1.e25
4819  pmin1 = 1.e25
4820  i0=-999
4821  j0=-999
4822  k0=-999
4823  n0=-999
4824  do k=1,npz
4825  call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4826  pmin1 = min(pmin, pmin1)
4827  pmax1 = max(pmax, pmax1)
4828  if (pmax1 == pmax) k0 = k
4829  enddo
4830  if (is_master()) then
4831  write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4832  endif
4833 
4834 ! Get tracer Stats
4835  do iq=2,ncnst
4836  pmax1 = -1.e25
4837  pmin1 = 1.e25
4838  i0=-999
4839  j0=-999
4840  k0=-999
4841  n0=-999
4842  do k=1,npz
4843  call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4844  pmin1 = min(pmin, pmin1)
4845  pmax1 = max(pmax, pmax1)
4846  if (pmax1 == pmax) k0 = k
4847  enddo
4848  if (is_master()) then
4849  write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4850  endif
4851  enddo
4852 
4853 #endif
4854 
4855  if (test_case == 12) then
4856 ! Get UV Stats
4857  call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, &
4858  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
4859  if (is_master()) then
4860  write(*,201) 'UV(850) L1_norm : ', l1_norm
4861  write(*,201) 'UV(850) L2_norm : ', l2_norm
4862  write(*,201) 'UV(850) Linf_norm : ', linf_norm
4863  endif
4864  endif
4865 
4866  tmass = 0.0
4867  tke = 0.0
4868  tener = 0.0
4869  tvort = 0.0
4870 #if defined(SW_DYNAMICS)
4871  do k=1,1
4872 #else
4873  do k=1,npz
4874 #endif
4875 ! Get conservation Stats
4876 
4877 ! Conservation of Mass
4878  temp(:,:) = delp(is:ie,js:je,k)
4879  tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4880  tmass = tmass + tmass0
4881 
4882  !if (.not. allocated(u0, v0)) then
4883  if (nt == 0) then
4884  allocate(u0(isd:ied,jsd:jed+1,npz))
4885  allocate(v0(isd:ied+1,jsd:jed,npz))
4886  u0 = u
4887  v0 = v
4888  endif
4889 
4890  !! UA is the PERTURBATION now
4891  up = u - u0
4892  vp = v - v0
4893 
4894  call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, ng)
4895  call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,ng,nested, domain, nocomm=.true.)
4896 ! Conservation of Kinetic Energy
4897  do j=js,je
4898  do i=is,ie
4899  temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + &
4900  vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) )
4901  enddo
4902  enddo
4903  tke0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4904  tke = tke + tke0
4905 
4906 ! Conservation of Energy
4907  do j=js,je
4908  do i=is,ie
4909  temp(i,j) = 0.5 * (delp(i,j,k)/grav) * temp(i,j) ! Include Previously calcullated KE
4910  temp(i,j) = temp(i,j) + &
4911  grav*((delp(i,j,k)/grav + phis(i,j))*(delp(i,j,k)/grav + phis(i,j))) - &
4912  phis(i,j)*phis(i,j)
4913  enddo
4914  enddo
4915  tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4916  tener = tener + tener0
4917 
4918 ! Conservation of Potential Enstrophy
4919  if (test_case>1) then
4920  do j=js,je
4921  do i=is,ie
4922  temp(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - &
4923  (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
4924  temp(i,j) = ( grav*(temp(i,j)*temp(i,j))/delp(i,j,k) )
4925  enddo
4926  enddo
4927  tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4928  tvort = tvort + tvort0
4929  else
4930  tvort=1.
4931  endif
4932  enddo
4933 
4934  if (nt == 0) then
4935  tmass_orig = tmass
4936  tener_orig = tener
4937  tvort_orig = tvort
4938  endif
4939  arr_r4(1) = (tmass-tmass_orig)/tmass_orig
4940  arr_r4(2) = (tener-tener_orig)/tener_orig
4941  arr_r4(3) = (tvort-tvort_orig)/tvort_orig
4942  arr_r4(4) = tke
4943  if (test_case==12) arr_r4(4) = l2_norm
4944 #if defined(SW_DYNAMICS)
4945  myrec = nt+1
4946 #else
4947  myrec = myday*86400.0/dtout + 1
4948 #endif
4949  if (is_master()) write(consv_lun,rec=myrec) arr_r4(1:4)
4950 #if defined(SW_DYNAMICS)
4951  if ( (is_master()) .and. mod(nt,monitorfreq)==0) then
4952 #else
4953  if ( (is_master()) ) then
4954 #endif
4955  write(*,201) 'MASS TOTAL : ', tmass
4956  write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig
4957  if (test_case >= 2) then
4958  write(*,201) 'Kinetic Energy KE : ', tke
4959  write(*,201) 'ENERGY TOTAL : ', tener
4960  write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig
4961  write(*,201) 'ENSTR TOTAL : ', tvort
4962  write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig
4963  endif
4964  write(*,*) ' '
4965  endif
4966 
4967  nullify(grid)
4968  nullify(agrid)
4969  nullify(area)
4970  nullify(f0)
4971  nullify(dx)
4972  nullify(dy)
4973 
4974  end subroutine get_stats
4975 
4976 
4977 
4978  subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
4979 ! get_pt_on_great_circle :: Get the mid-point on a great circle given:
4980 ! -2 points (Lon/Lat) to define a great circle
4981 ! -Great Cirle distance between 2 defining points
4982 ! -Heading
4983 ! compute:
4984 ! Arrival Point (Lon/Lat)
4985 
4986  real , intent(IN) :: p1(2), p2(2)
4987  real , intent(IN) :: dist
4988  real , intent(IN) :: heading
4989  real , intent(OUT) :: p3(2)
4990 
4991  real pha, dp
4992 
4993  pha = dist/radius
4994 
4995  p3(2) = asin( (cos(heading)*cos(p1(2))*sin(pha)) + (sin(p1(2))*cos(pha)) )
4996  dp = atan2( sin(heading)*sin(pha)*cos(p1(2)) , cos(pha) - sin(p1(2))*sin(p3(2)) )
4997  p3(1) = mod( (p1(1)-pi)-dp+pi , 2.*pi ) !- pi Leave at 0 to 360
4998 
4999  end subroutine get_pt_on_great_circle
5000 
5001 
5002 !
5003 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5004 !-------------------------------------------------------------------------------
5005 
5006 !-------------------------------------------------------------------------------
5007 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5008 !
5009 ! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5010 ! in Williamson, 1994 (p.16)
5011 ! for any var
5012 
5013  subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, &
5014  vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
5015  integer, intent(IN) :: npx, npy
5016  integer, intent(IN) :: ndims
5017  integer, intent(IN) :: nregions, tile
5018  real , intent(IN) :: var(isd:ied,jsd:jed)
5019  real , intent(IN) :: varT(isd:ied,jsd:jed)
5020  real , intent(OUT) :: vmin
5021  real , intent(OUT) :: vmax
5022  real , intent(OUT) :: L1_norm
5023  real , intent(OUT) :: L2_norm
5024  real , intent(OUT) :: Linf_norm
5025 
5026  type(fv_grid_type), target :: gridstruct
5027 
5028  real :: vmean
5029  real :: vvar
5030  real :: vmin1
5031  real :: vmax1
5032  real :: pdiffmn
5033  real :: pdiffmx
5034 
5035  real :: varSUM, varSUM2, varMAX
5036  real :: gsum
5037  real :: vminT, vmaxT, vmeanT, vvarT
5038  integer :: i0, j0, n0
5039 
5040  real, dimension(:,:,:), pointer :: grid, agrid
5041  real, dimension(:,:), pointer :: area
5042 
5043  grid => gridstruct%grid
5044  agrid=> gridstruct%agrid
5045 
5046  area => gridstruct%area
5047 
5048  varsum = 0.
5049  varsum2 = 0.
5050  varmax = 0.
5051  l1_norm = 0.
5052  l2_norm = 0.
5053  linf_norm = 0.
5054  vmean = 0.
5055  vvar = 0.
5056  vmax = 0.
5057  vmin = 0.
5058  pdiffmn= 0.
5059  pdiffmx= 0.
5060  vmeant = 0.
5061  vvart = 0.
5062  vmaxt = 0.
5063  vmint = 0.
5064 
5065  vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5066  vmeant = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5067  vmean = vmean / (4.0*pi)
5068  vmeant = vmeant / (4.0*pi)
5069 
5070  call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0)
5071  call pmxn(vart, npx, npy, nregions, tile, gridstruct, vmint, vmaxt, i0, j0, n0)
5072  call pmxn(var-vart, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0)
5073 
5074  vmax = (vmax - vmaxt) / (vmaxt-vmint)
5075  vmin = (vmin - vmint) / (vmaxt-vmint)
5076 
5077  varsum = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5078  varsum2 = globalsum(vart(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5079  l1_norm = globalsum(abs(var(is:ie,js:je)-vart(is:ie,js:je)), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5080  l2_norm = globalsum((var(is:ie,js:je)-vart(is:ie,js:je))**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5081  l1_norm = l1_norm/varsum
5082  l2_norm = sqrt(l2_norm)/sqrt(varsum2)
5083 
5084  call pmxn(abs(vart), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5085  varmax = vmax
5086  call pmxn(abs(var-vart), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5087  linf_norm = vmax/varmax
5088 
5089  end subroutine get_scalar_stats
5090 !
5091 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5092 !-------------------------------------------------------------------------------
5093 
5094 !-------------------------------------------------------------------------------
5095 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5096 !
5097 ! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5098 ! in Williamson, 1994 (p.16)
5099 ! for any var
5100 
5101  subroutine get_vector_stats(varU, varUT, varV, varVT, &
5102  npx, npy, ndims, nregions, &
5103  vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
5104  integer, intent(IN) :: npx, npy
5105  integer, intent(IN) :: ndims
5106  integer, intent(IN) :: nregions, tile
5107  real , intent(IN) :: varU(isd:ied,jsd:jed)
5108  real , intent(IN) :: varUT(isd:ied,jsd:jed)
5109  real , intent(IN) :: varV(isd:ied,jsd:jed)
5110  real , intent(IN) :: varVT(isd:ied,jsd:jed)
5111  real , intent(OUT) :: vmin
5112  real , intent(OUT) :: vmax
5113  real , intent(OUT) :: L1_norm
5114  real , intent(OUT) :: L2_norm
5115  real , intent(OUT) :: Linf_norm
5116 
5117  real :: var(isd:ied,jsd:jed)
5118  real :: varT(isd:ied,jsd:jed)
5119  real :: vmean
5120  real :: vvar
5121  real :: vmin1
5122  real :: vmax1
5123  real :: pdiffmn
5124  real :: pdiffmx
5125 
5126  real :: varSUM, varSUM2, varMAX
5127  real :: gsum
5128  real :: vminT, vmaxT, vmeanT, vvarT
5129  integer :: i,j,n
5130  integer :: i0, j0, n0
5131 
5132  type(fv_grid_type), target :: gridstruct
5133 
5134  real, dimension(:,:,:), pointer :: grid, agrid
5135  real, dimension(:,:), pointer :: area
5136 
5137  grid => gridstruct%grid
5138  agrid=> gridstruct%agrid
5139 
5140  area => gridstruct%area
5141 
5142  varsum = 0.
5143  varsum2 = 0.
5144  varmax = 0.
5145  l1_norm = 0.
5146  l2_norm = 0.
5147  linf_norm = 0.
5148  vmean = 0.
5149  vvar = 0.
5150  vmax = 0.
5151  vmin = 0.
5152  pdiffmn= 0.
5153  pdiffmx= 0.
5154  vmeant = 0.
5155  vvart = 0.
5156  vmaxt = 0.
5157  vmint = 0.
5158 
5159  do j=js,je
5160  do i=is,ie
5161  var(i,j) = sqrt( (varu(i,j)-varut(i,j))**2. + &
5162  (varv(i,j)-varvt(i,j))**2. )
5163  vart(i,j) = sqrt( varut(i,j)*varut(i,j) + &
5164  varvt(i,j)*varvt(i,j) )
5165  enddo
5166  enddo
5167  varsum = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5168  l1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5169  l1_norm = l1_norm/varsum
5170 
5171  call pmxn(vart, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5172  varmax = vmax
5173  call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5174  linf_norm = vmax/varmax
5175 
5176  do j=js,je
5177  do i=is,ie
5178  var(i,j) = ( (varu(i,j)-varut(i,j))**2. + &
5179  (varv(i,j)-varvt(i,j))**2. )
5180  vart(i,j) = ( varut(i,j)*varut(i,j) + &
5181  varvt(i,j)*varvt(i,j) )
5182  enddo
5183  enddo
5184  varsum = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5185  l2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5186  l2_norm = sqrt(l2_norm)/sqrt(varsum)
5187 
5188  end subroutine get_vector_stats
5189 !
5190 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5191 !-------------------------------------------------------------------------------
5192 
5193 !-------------------------------------------------------------------------------
5194 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5195 !
5196 ! check_courant_numbers ::
5197 !
5198  subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint)
5199 
5200  real, intent(IN) :: ndt
5201  integer, intent(IN) :: n_split
5202  integer, intent(IN) :: npx, npy, npz, tile
5203  logical, OPTIONAL, intent(IN) :: noprint
5204  real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz)
5205  real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz)
5206 
5207  real :: ideal_c=0.06
5208  real :: tolerance= 1.e-3
5209  real :: dt_inc, dt_orig
5210  real :: meancy, mincy, maxcy, meancx, mincx, maxcx
5211 
5212  real :: counter
5213  logical :: ideal
5214 
5215  integer :: i,j,k
5216  real :: dt
5217 
5218  type(fv_grid_type), intent(IN), target :: gridstruct
5219  real, dimension(:,:), pointer :: dxc, dyc
5220 
5221  dxc => gridstruct%dxc
5222  dyc => gridstruct%dyc
5223 
5224  dt = ndt/real(n_split)
5225 
5226  300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
5227 
5228  dt_orig = dt
5229  dt_inc = 1
5230  ideal = .false.
5231 
5232  do while(.not. ideal)
5233 
5234  counter = 0
5235  mincy = missing
5236  maxcy = -1.*missing
5237  mincx = missing
5238  maxcx = -1.*missing
5239  meancx = 0
5240  meancy = 0
5241  do k=1,npz
5242  do j=js,je
5243  do i=is,ie+1
5244  mincx = min(mincx, abs( (dt/dxc(i,j))*uc(i,j,k) ))
5245  maxcx = max(maxcx, abs( (dt/dxc(i,j))*uc(i,j,k) ))
5246  meancx = meancx + abs( (dt/dxc(i,j))*uc(i,j,k) )
5247 
5248  if (abs( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then
5249  counter = counter+1
5250  write(*,300) i,j,k,tile, abs( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter
5251  call exit(1)
5252  endif
5253 
5254  enddo
5255  enddo
5256  do j=js,je+1
5257  do i=is,ie
5258  mincy = min(mincy, abs( (dt/dyc(i,j))*vc(i,j,k) ))
5259  maxcy = max(maxcy, abs( (dt/dyc(i,j))*vc(i,j,k) ))
5260  meancy = meancy + abs( (dt/dyc(i,j))*vc(i,j,k) )
5261 
5262  if (abs( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then
5263  counter = counter+1
5264  write(*,300) i,j,k,tile, abs( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter
5265  call exit(1)
5266  endif
5267 
5268  enddo
5269  enddo
5270  enddo
5271 
5272  call mp_reduce_max(maxcx)
5273  call mp_reduce_max(maxcy)
5274  mincx = -mincx
5275  mincy = -mincy
5276  call mp_reduce_max(mincx)
5277  call mp_reduce_max(mincy)
5278  mincx = -mincx
5279  mincy = -mincy
5280  call mp_reduce_sum(meancx)
5281  call mp_reduce_sum(meancy)
5282  meancx = meancx/(6.0*dble(npx)*dble(npy-1))
5283  meancy = meancy/(6.0*dble(npx-1)*dble(npy))
5284 
5285  !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then
5286  ideal = .true.
5287  !elseif (maxCy-ideal_c > 0) then
5288  ! dt = dt - dt_inc
5289  !else
5290  ! dt = dt + dt_inc
5291  !endif
5292 
5293  enddo
5294 
5295  if ( (.not. present(noprint)) .and. (is_master()) ) then
5296  print*, ''
5297  print*, '--------------------------------------------'
5298  print*, 'Y-dir Courant number MIN : ', mincy
5299  print*, 'Y-dir Courant number MAX : ', maxcy
5300  print*, ''
5301  print*, 'X-dir Courant number MIN : ', mincx
5302  print*, 'X-dir Courant number MAX : ', maxcx
5303  print*, ''
5304  print*, 'X-dir Courant number MEAN : ', meancx
5305  print*, 'Y-dir Courant number MEAN : ', meancy
5306  print*, ''
5307  print*, 'NDT: ', ndt
5308  print*, 'n_split: ', n_split
5309  print*, 'DT: ', dt
5310  print*, ''
5311  print*, '--------------------------------------------'
5312  print*, ''
5313  endif
5314 
5315  end subroutine check_courant_numbers
5316 !
5317 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5318 !-------------------------------------------------------------------------------
5319 
5320 !-------------------------------------------------------------------------------
5321 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5322 !
5323 ! pmxn :: find max and min of field p
5324 !
5325  subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
5326  integer, intent(IN) :: npx
5327  integer, intent(IN) :: npy
5328  integer, intent(IN) :: nregions, tile
5329  real , intent(IN) :: p(isd:ied,jsd:jed)
5330  type(fv_grid_type), intent(IN), target :: gridstruct
5331  real , intent(OUT) :: pmin
5332  real , intent(OUT) :: pmax
5333  integer, intent(OUT) :: i0
5334  integer, intent(OUT) :: j0
5335  integer, intent(OUT) :: n0
5336 
5337  real :: temp
5338  integer :: i,j,n
5339 
5340 
5341  real, pointer, dimension(:,:,:) :: agrid, grid
5342  real, pointer, dimension(:,:) :: area, rarea, fC, f0
5343  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
5344  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
5345  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5346 
5347  logical, pointer :: cubed_sphere, latlon
5348 
5349  logical, pointer :: have_south_pole, have_north_pole
5350 
5351  integer, pointer :: ntiles_g
5352  real, pointer :: acapN, acapS, globalarea
5353 
5354  grid => gridstruct%grid
5355  agrid=> gridstruct%agrid
5356 
5357  area => gridstruct%area
5358  rarea => gridstruct%rarea
5359 
5360  fc => gridstruct%fC
5361  f0 => gridstruct%f0
5362 
5363  ee1 => gridstruct%ee1
5364  ee2 => gridstruct%ee2
5365  ew => gridstruct%ew
5366  es => gridstruct%es
5367  en1 => gridstruct%en1
5368  en2 => gridstruct%en2
5369 
5370  dx => gridstruct%dx
5371  dy => gridstruct%dy
5372  dxa => gridstruct%dxa
5373  dya => gridstruct%dya
5374  rdxa => gridstruct%rdxa
5375  rdya => gridstruct%rdya
5376  dxc => gridstruct%dxc
5377  dyc => gridstruct%dyc
5378 
5379  cubed_sphere => gridstruct%cubed_sphere
5380  latlon => gridstruct%latlon
5381 
5382  have_south_pole => gridstruct%have_south_pole
5383  have_north_pole => gridstruct%have_north_pole
5384 
5385  ntiles_g => gridstruct%ntiles_g
5386  acapn => gridstruct%acapN
5387  acaps => gridstruct%acapS
5388  globalarea => gridstruct%globalarea
5389 
5390  pmax = -1.e25
5391  pmin = 1.e25
5392  i0 = -999
5393  j0 = -999
5394  n0 = tile
5395 
5396  do j=js,je
5397  do i=is,ie
5398  temp = p(i,j)
5399  if (temp > pmax) then
5400  pmax = temp
5401  i0 = i
5402  j0 = j
5403  elseif (temp < pmin) then
5404  pmin = temp
5405  endif
5406  enddo
5407  enddo
5408 
5409  temp = pmax
5410  call mp_reduce_max(temp)
5411  if (temp /= pmax) then
5412  i0 = -999
5413  j0 = -999
5414  n0 = -999
5415  endif
5416  pmax = temp
5417  call mp_reduce_max(i0)
5418  call mp_reduce_max(j0)
5419  call mp_reduce_max(n0)
5420 
5421  pmin = -pmin
5422  call mp_reduce_max(pmin)
5423  pmin = -pmin
5424 
5425  end subroutine pmxn
5426 !
5427 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5428 !-------------------------------------------------------------------------------
5429 
5430 !! These routines are no longer used
5431 #ifdef NCDF_OUTPUT
5432 
5433 !-------------------------------------------------------------------------------
5434 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5435 !
5436 ! output_ncdf :: write out NETCDF fields
5437 !
5438  subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5439  omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, &
5440  npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, &
5441  phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, &
5442  lats_id, lons_id, gridstruct, flagstruct)
5443  real, intent(IN) :: dt
5444  integer, intent(IN) :: nt, maxnt
5445  integer, intent(INOUT) :: nout
5446 
5447  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5448  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5449  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5450  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5451  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5452 
5453  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5454  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5455 
5456  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5457  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5458  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5459  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5460  real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz)
5461 
5462  integer, intent(IN) :: npx, npy, npz
5463  integer, intent(IN) :: ng, ncnst
5464  integer, intent(IN) :: ndims
5465  integer, intent(IN) :: nregions
5466  integer, intent(IN) :: ncid
5467  integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id
5468  integer, intent(IN) :: ntiles_id, nt_id
5469  integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id
5470  integer, intent(IN) :: om_id ! omega (dp/dt)
5471  integer, intent(IN) :: tracers_ids(ncnst-1)
5472  integer, intent(IN) :: lats_id, lons_id
5473 
5474  type(fv_grid_type), target :: gridstruct
5475  type(fv_flags_type), intent(IN) :: flagstruct
5476 
5477  real, allocatable :: tmp(:,:,:)
5478  real, allocatable :: tmpA(:,:,:)
5479 #if defined(SW_DYNAMICS)
5480  real, allocatable :: ut(:,:,:)
5481  real, allocatable :: vt(:,:,:)
5482 #else
5483  real, allocatable :: ut(:,:,:,:)
5484  real, allocatable :: vt(:,:,:,:)
5485  real, allocatable :: tmpA_3d(:,:,:,:)
5486 #endif
5487  real, allocatable :: vort(:,:)
5488 
5489  real :: p1(2) ! Temporary Point
5490  real :: p2(2) ! Temporary Point
5491  real :: p3(2) ! Temporary Point
5492  real :: p4(2) ! Temporary Point
5493  real :: pa(2) ! Temporary Point
5494  real :: utmp, vtmp, r, r0, dist, heading
5495  integer :: i,j,k,n,iq,nreg
5496 
5497  real :: Vtx, p, w_p
5498  real :: x1,y1,z1,x2,y2,z2,ang
5499 
5500  real, pointer, dimension(:,:,:) :: agrid, grid
5501  real, pointer, dimension(:,:) :: area, rarea
5502  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5503 
5504  grid => gridstruct%grid
5505  agrid => gridstruct%agrid
5506 
5507  area => gridstruct%area
5508  rarea => gridstruct%rarea
5509 
5510  dx => gridstruct%dx
5511  dy => gridstruct%dy
5512  dxa => gridstruct%dxa
5513  dya => gridstruct%dya
5514  rdxa => gridstruct%rdxa
5515  rdya => gridstruct%rdya
5516  dxc => gridstruct%dxc
5517  dyc => gridstruct%dyc
5518 
5519  allocate( tmp(npx ,npy ,nregions) )
5520  allocate( tmpa(npx-1,npy-1,nregions) )
5521 #if defined(SW_DYNAMICS)
5522  allocate( ut(npx-1,npy-1,nregions) )
5523  allocate( vt(npx-1,npy-1,nregions) )
5524 #else
5525  allocate( ut(npx-1,npy-1,npz,nregions) )
5526  allocate( vt(npx-1,npy-1,npz,nregions) )
5527  allocate( tmpa_3d(npx-1,npy-1,npz,nregions) )
5528 #endif
5529  allocate( vort(isd:ied,jsd:jed) )
5530 
5531  nout = nout + 1
5532 
5533  if (nt==0) then
5534  tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2)
5535  call wrtvar_ncdf(ncid, lats_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3)
5536  tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1)
5537  call wrtvar_ncdf(ncid, lons_id, nout, is,ie+1, js,je+1, npx+1, npy+1, 1, nregions, tmp(1:npx,1:npy,1:nregions), 3)
5538  endif
5539 
5540 #if defined(SW_DYNAMICS)
5541  if (test_case > 1) then
5542  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)/grav
5543 
5544  if ((nt==0) .and. (test_case==2)) then
5545  ubar = (2.0*pi*radius)/(12.0*86400.0)
5546  gh0 = 2.94e4
5547  phis = 0.0
5548  do j=js,je+1
5549  do i=is,ie+1
5550  tmp(i,j,tile) = (gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
5551  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5552  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / grav
5553  enddo
5554  enddo
5555  endif
5556 
5557  else
5558 
5559  if (test_case==1) then
5560 ! Get Current Height Field "Truth"
5561  p1(1) = pi/2. + pi_shift
5562  p1(2) = 0.
5563  p2(1) = 3.*pi/2. + pi_shift
5564  p2(2) = 0.
5565  r0 = radius/3. !RADIUS /3.
5566  dist = 2.0*pi*radius* ((float(nt)/float(maxnt)))
5567  heading = 5.0*pi/2.0 - alpha
5568  call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5569  do j=jsd,jed
5570  do i=isd,ied
5571  p2(1) = agrid(i,j,1)
5572  p2(2) = agrid(i,j,2)
5573  r = great_circle_dist( p3, p2, radius )
5574  if (r < r0) then
5575  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
5576  else
5577  phi0(i,j,1) = phis(i,j)
5578  endif
5579  enddo
5580  enddo
5581  elseif (test_case == 0) then
5582  phi0 = 0.0
5583  do j=jsd,jed
5584  do i=isd,ied
5585  x1 = agrid(i,j,1)
5586  y1 = agrid(i,j,2)
5587  z1 = radius
5588  p = p0_c0 * cos(y1)
5589  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5590  w_p = 0.0
5591  if (p /= 0.0) w_p = vtx/p
5592  phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5593  enddo
5594  enddo
5595  endif
5596 
5597  tmpa(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5598  call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5599  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5600  endif
5601  call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5602 
5603  if (test_case == 9) then
5604 ! Calc Vorticity
5605  do j=jsd,jed
5606  do i=isd,ied
5607  vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
5608  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5609  vort(i,j) = grav*vort(i,j)/delp(i,j,1)
5610  enddo
5611  enddo
5612  tmpa(is:ie,js:je,tile) = vort(is:ie,js:je)
5613  call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5614  endif
5615 
5616  call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord, bd)
5617  do j=js,je
5618  do i=is,ie
5619  ut(i,j,tile) = ua(i,j,1)
5620  vt(i,j,tile) = va(i,j,1)
5621  enddo
5622  enddo
5623 
5624  call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:nregions), 3)
5625  call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:nregions), 3)
5626 
5627  if ((test_case >= 2) .and. (nt==0) ) then
5628  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5629  call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5630  endif
5631 #else
5632 
5633 ! Write Moisture Data
5634  tmpa_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1)
5635  call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5636 
5637 ! Write Tracer Data
5638  do iq=2,ncnst
5639  tmpa_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq)
5640  call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5641  enddo
5642 
5643 ! Write Surface height data
5644  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5645  call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpa, 3)
5646 
5647 ! Write Pressure Data
5648  tmpa(is:ie,js:je,tile) = ps(is:ie,js:je)
5649  call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpa, 3)
5650  do k=1,npz
5651  tmpa_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/grav
5652  enddo
5653  call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5654 
5655 ! Write PT Data
5656  do k=1,npz
5657  tmpa_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k)
5658  enddo
5659  call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5660 
5661 ! Write U,V Data
5662  call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord)
5663  do k=1,npz
5664  do j=js,je
5665  do i=is,ie
5666  ut(i,j,k,tile) = ua(i,j,k)
5667  vt(i,j,k,tile) = va(i,j,k)
5668  enddo
5669  enddo
5670  enddo
5671  call wrtvar_ncdf(ncid, u_id, nout, is,ie, js,je, npx, npy, npz, nregions, ut(1:npx-1,1:npy-1,1:npz,1:nregions), 4)
5672  call wrtvar_ncdf(ncid, v_id, nout, is,ie, js,je, npx, npy, npz, nregions, vt(1:npx-1,1:npy-1,1:npz,1:nregions), 4)
5673 
5674 
5675 ! Calc Vorticity
5676  do k=1,npz
5677  do j=js,je
5678  do i=is,ie
5679  tmpa_3d(i,j,k,tile) = rarea(i,j) * ( (v(i+1,j,k)*dy(i+1,j) - v(i,j,k)*dy(i,j)) - &
5680  (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
5681  enddo
5682  enddo
5683  enddo
5684  call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5685 !
5686 ! Output omega (dp/dt):
5687  do k=1,npz
5688  do j=js,je
5689  do i=is,ie
5690  tmpa_3d(i,j,k,tile) = omga(i,j,k)
5691  enddo
5692  enddo
5693  enddo
5694  call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5695 
5696 #endif
5697 
5698  deallocate( tmp )
5699  deallocate( tmpa )
5700 #if defined(SW_DYNAMICS)
5701  deallocate( ut )
5702  deallocate( vt )
5703 #else
5704  deallocate( ut )
5705  deallocate( vt )
5706  deallocate( tmpa_3d )
5707 #endif
5708  deallocate( vort )
5709 
5710  nullify(grid)
5711  nullify(agrid)
5712 
5713  nullify(area)
5714 
5715  nullify(dx)
5716  nullify(dy)
5717  nullify(dxa)
5718  nullify(dya)
5719  nullify(rdxa)
5720  nullify(rdya)
5721  nullify(dxc)
5722  nullify(dyc)
5723 
5724  end subroutine output_ncdf
5725 
5726 !
5727 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5728 !-------------------------------------------------------------------------------
5729 
5730 !-------------------------------------------------------------------------------
5731 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5732 !
5733 ! output :: write out fields
5734 !
5735  subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5736  npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, &
5737  pt_lun, pv_lun, uv_lun, gridstruct)
5738 
5739  real, intent(IN) :: dt
5740  integer, intent(IN) :: nt, maxnt
5741  integer, intent(INOUT) :: nout
5742 
5743  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5744  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5745  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5746  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5747  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5748 
5749  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5750  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5751 
5752  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5753  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5754  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5755  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5756 
5757  integer, intent(IN) :: npx, npy, npz
5758  integer, intent(IN) :: ng, ncnst
5759  integer, intent(IN) :: ndims
5760  integer, intent(IN) :: nregions
5761  integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun
5762 
5763  type(fv_grid_type), target :: gridstruct
5764 
5765  real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
5766  real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions)
5767  real :: p1(2) ! Temporary Point
5768  real :: p2(2) ! Temporary Point
5769  real :: p3(2) ! Temporary Point
5770  real :: p4(2) ! Temporary Point
5771  real :: pa(2) ! Temporary Point
5772  real :: ut(1:npx,1:npy,1:nregions)
5773  real :: vt(1:npx,1:npy,1:nregions)
5774  real :: utmp, vtmp, r, r0, dist, heading
5775  integer :: i,j,k,n,nreg
5776  real :: vort(isd:ied,jsd:jed)
5777 
5778  real :: Vtx, p, w_p
5779  real :: x1,y1,z1,x2,y2,z2,ang
5780 
5781  real, pointer, dimension(:,:,:) :: agrid, grid
5782  real, pointer, dimension(:,:) :: area, rarea
5783  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5784 
5785  grid => gridstruct%grid
5786  agrid => gridstruct%agrid
5787 
5788  area => gridstruct%area
5789 
5790  dx => gridstruct%dx
5791  dy => gridstruct%dy
5792  dxa => gridstruct%dxa
5793  dya => gridstruct%dya
5794  rdxa => gridstruct%rdxa
5795  rdya => gridstruct%rdya
5796  dxc => gridstruct%dxc
5797  dyc => gridstruct%dyc
5798 
5799  cubed_sphere => gridstruct%cubed_sphere
5800 
5801  nout = nout + 1
5802 
5803 #if defined(SW_DYNAMICS)
5804  if (test_case > 1) then
5805  call atob_s(delp(:,:,1)/grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5806  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)/grav
5807 
5808  if ((nt==0) .and. (test_case==2)) then
5809  ubar = (2.0*pi*radius)/(12.0*86400.0)
5810  gh0 = 2.94e4
5811  phis = 0.0
5812  do j=js,je+1
5813  do i=is,ie+1
5814  tmp(i,j,tile) = (gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
5815  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5816  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / grav
5817  enddo
5818  enddo
5819  endif
5820 
5821  else
5822 
5823  if (test_case==1) then
5824 ! Get Current Height Field "Truth"
5825  p1(1) = pi/2. + pi_shift
5826  p1(2) = 0.
5827  p2(1) = 3.*pi/2. + pi_shift
5828  p2(2) = 0.
5829  r0 = radius/3. !RADIUS /3.
5830  dist = 2.0*pi*radius* ((float(nt)/float(maxnt)))
5831  heading = 5.0*pi/2.0 - alpha
5832  call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5833  do j=jsd,jed
5834  do i=isd,ied
5835  p2(1) = agrid(i,j,1)
5836  p2(2) = agrid(i,j,2)
5837  r = great_circle_dist( p3, p2, radius )
5838  if (r < r0) then
5839  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
5840  else
5841  phi0(i,j,1) = phis(i,j)
5842  endif
5843  enddo
5844  enddo
5845  elseif (test_case == 0) then
5846  phi0 = 0.0
5847  do j=jsd,jed
5848  do i=isd,ied
5849  x1 = agrid(i,j,1)
5850  y1 = agrid(i,j,2)
5851  z1 = radius
5852  p = p0_c0 * cos(y1)
5853  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5854  w_p = 0.0
5855  if (p /= 0.0) w_p = vtx/p
5856  phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5857  enddo
5858  enddo
5859  endif
5860 
5861  call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5862  tmpa(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5863  call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5864  call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5865  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5866  endif
5867  ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5868  call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5869 
5870  if (test_case == 9) then
5871 ! Calc Vorticity
5872  do j=jsd,jed
5873  do i=isd,ied
5874  vort(i,j) = f0(i,j) + (1./area(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
5875  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5876  vort(i,j) = grav*vort(i,j)/delp(i,j,1)
5877  enddo
5878  enddo
5879  call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5880  call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5881  endif
5882 
5883  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
5884 ! Rotate winds to standard Lat-Lon orientation
5885  if (cubed_sphere) then
5886  do j=js,je
5887  do i=is,ie
5888  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5889  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5890  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5891  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5892  utmp = ua(i,j,1)
5893  vtmp = va(i,j,1)
5894  if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5895  ut(i,j,tile) = utmp
5896  vt(i,j,tile) = vtmp
5897  enddo
5898  enddo
5899  endif
5900 
5901  call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions))
5902  call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions))
5903 
5904  if ((test_case >= 2) .and. (nt==0) ) then
5905  call atob_s(phis/grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5906  ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5907  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5908  call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5909  endif
5910 #else
5911 
5912 ! Write Surface height data
5913  if (nt==0) then
5914  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5915  call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5916  endif
5917 
5918 ! Write Pressure Data
5919 
5920  !if (tile==2) then
5921  ! do i=is,ie
5922  ! print*, i, ps(i,35)
5923  ! enddo
5924  !endif
5925  tmpa(is:ie,js:je,tile) = ps(is:ie,js:je)
5926  call wrt2d(phi_lun, (nout-1)*(npz+1) + 1, is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5927  do k=1,npz
5928  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,k)/grav
5929  call wrt2d(phi_lun, (nout-1)*(npz+1) + 1 + k, is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5930  enddo
5931 
5932 ! Write PT Data
5933  do k=1,npz
5934  tmpa(is:ie,js:je,tile) = pt(is:ie,js:je,k)
5935  call wrt2d(pt_lun, (nout-1)*npz + (k-1) + 1, is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5936  enddo
5937 
5938 ! Write U,V Data
5939  do k=1,npz
5940  call dtoa(u(isd,jsd,k), v(isd,jsd,k), ua(isd,jsd,k), va(isd,jsd,k), dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
5941 ! Rotate winds to standard Lat-Lon orientation
5942  if (cubed_sphere) then
5943  do j=js,je
5944  do i=is,ie
5945  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5946  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5947  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5948  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5949  utmp = ua(i,j,k)
5950  vtmp = va(i,j,k)
5951  if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5952  ut(i,j,tile) = utmp
5953  vt(i,j,tile) = vtmp
5954  enddo
5955  enddo
5956  endif
5957  call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions))
5958  call wrt2d(uv_lun, 2*((nout-1)*npz + (k-1)) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions))
5959  enddo
5960 #endif
5961 
5962  nullify(grid)
5963  nullify(agrid)
5964 
5965  nullify(area)
5966 
5967  nullify(dx)
5968  nullify(dy)
5969  nullify(dxa)
5970  nullify(dya)
5971  nullify(rdxa)
5972  nullify(rdya)
5973  nullify(dxc)
5974  nullify(dyc)
5975 
5976  nullify(cubed_sphere)
5977 
5978  end subroutine output
5979 !
5980 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5981 !-------------------------------------------------------------------------------
5982 
5983 !-------------------------------------------------------------------------------
5984 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5985 ! wrt2d_ncdf :: write out a 2d field
5986 !
5987  subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims)
5988 #include <netcdf.inc>
5989  integer, intent(IN) :: ncid, varid
5990  integer, intent(IN) :: nrec
5991  integer, intent(IN) :: i1,i2,j1,j2
5992  integer, intent(IN) :: npx
5993  integer, intent(IN) :: npy
5994  integer, intent(IN) :: npz
5995  integer, intent(IN) :: ntiles
5996  real , intent(IN) :: p(npx-1,npy-1,npz,ntiles)
5997  integer, intent(IN) :: ndims
5998 
5999  integer :: error
6000  real(kind=4), allocatable :: p_R4(:,:,:,:)
6001  integer :: i,j,k,n
6002  integer :: istart(ndims+1), icount(ndims+1)
6003 
6004  allocate( p_r4(npx-1,npy-1,npz,ntiles) )
6005 
6006  p_r4(:,:,:,:) = missing
6007  p_r4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile)
6008  call mp_gather(p_r4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles)
6009 
6010  istart(:) = 1
6011  istart(ndims+1) = nrec
6012  icount(1) = npx-1
6013  icount(2) = npy-1
6014  icount(3) = npz
6015  if (ndims == 3) icount(3) = ntiles
6016  if (ndims == 4) icount(4) = ntiles
6017  icount(ndims+1) = 1
6018 
6019  if (is_master()) then
6020  error = nf_put_vara_real(ncid, varid, istart, icount, p_r4)
6021  endif ! masterproc
6022 
6023  deallocate( p_r4 )
6024 
6025  end subroutine wrtvar_ncdf
6026 !
6027 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6028 !-------------------------------------------------------------------------------
6029 
6030 !-------------------------------------------------------------------------------
6031 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6032 ! wrt2d :: write out a 2d field
6033 !
6034  subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p)
6035  integer, intent(IN) :: iout
6036  integer, intent(IN) :: nrec
6037  integer, intent(IN) :: i1,i2,j1,j2
6038  integer, intent(IN) :: npx
6039  integer, intent(IN) :: npy
6040  integer, intent(IN) :: nregions
6041  real , intent(IN) :: p(npx-1,npy-1,nregions)
6042 
6043  real(kind=4) :: p_R4(npx-1,npy-1,nregions)
6044  integer :: i,j,n
6045 
6046  do n=tile,tile
6047  do j=j1,j2
6048  do i=i1,i2
6049  p_r4(i,j,n) = p(i,j,n)
6050  enddo
6051  enddo
6052  enddo
6053 
6054  call mp_gather(p_r4, i1,i2, j1,j2, npx-1, npy-1, nregions)
6055 
6056  if (is_master()) then
6057  write(iout,rec=nrec) p_r4(1:npx-1,1:npy-1,1:nregions)
6058  endif ! masterproc
6059 
6060  end subroutine wrt2d
6061 !
6062 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6063 !-------------------------------------------------------------------------------
6064 #endif
6065 !-------------------------------------------------------------------------------
6066 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6067 ! init_double_periodic
6068 !
6069  subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
6070  gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, &
6071  mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd)
6072 
6073 
6074  type(fv_grid_bounds_type), intent(IN) :: bd
6075  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6076  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6077  real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
6078  real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6079  real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6080  real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
6081 
6082  real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
6083 
6084  real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
6085  real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
6086  real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
6087  real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
6088  real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
6089  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6090  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6091  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6092  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6093  real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:)
6094  real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
6095 
6096  real , intent(inout) :: ak(npz+1)
6097  real , intent(inout) :: bk(npz+1)
6098 
6099  integer, intent(IN) :: npx, npy, npz
6100  integer, intent(IN) :: ng, ncnst, nwat
6101  integer, intent(IN) :: ndims
6102  integer, intent(IN) :: nregions
6103 
6104  real, intent(IN) :: dry_mass
6105  logical, intent(IN) :: mountain
6106  logical, intent(IN) :: moist_phys
6107  logical, intent(IN) :: hydrostatic, hybrid_z
6108  integer, intent(INOUT) :: ks
6109  integer, intent(INOUT), target :: tile_in
6110  real, intent(INOUT) :: ptop
6111 
6112  type(domain2d), intent(IN), target :: domain_in
6113 
6114  type(fv_grid_type), target :: gridstruct
6115  type(fv_flags_type), target :: flagstruct
6116 
6117  real, dimension(bd%is:bd%ie):: pm, qs
6118  real, dimension(1:npz):: pk1, ts1, qs1
6119  real :: us0 = 30.
6120  real :: dist, r0, f0_const, prf, rgrav
6121  real :: ptmp, ze, zc, zm, utmp, vtmp
6122  real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop
6123  real :: ze1(npz+1)
6124  real:: dz1(npz)
6125  real:: zvir
6126  integer :: i, j, k, m, icenter, jcenter
6127 
6128  real, pointer, dimension(:,:,:) :: agrid, grid
6129  real(kind=R_GRID), pointer, dimension(:,:) :: area
6130  real, pointer, dimension(:,:) :: rarea, fc, f0
6131  real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
6132  real, pointer, dimension(:,:,:,:) :: ew, es
6133  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
6134 
6135  logical, pointer :: cubed_sphere, latlon
6136 
6137  type(domain2d), pointer :: domain
6138  integer, pointer :: tile
6139 
6140  logical, pointer :: have_south_pole, have_north_pole
6141 
6142  integer, pointer :: ntiles_g
6143  real, pointer :: acapn, acaps, globalarea
6144 
6145  real(kind=R_GRID), pointer :: dx_const, dy_const
6146 
6147  integer :: is, ie, js, je
6148  integer :: isd, ied, jsd, jed
6149 
6150  is = bd%is
6151  ie = bd%ie
6152  js = bd%js
6153  je = bd%je
6154  isd = bd%isd
6155  ied = bd%ied
6156  jsd = bd%jsd
6157  jed = bd%jed
6158 
6159  agrid => gridstruct%agrid
6160  grid => gridstruct%grid
6161 
6162  area => gridstruct%area_64
6163 
6164  dx => gridstruct%dx
6165  dy => gridstruct%dy
6166  dxa => gridstruct%dxa
6167  dya => gridstruct%dya
6168  rdxa => gridstruct%rdxa
6169  rdya => gridstruct%rdya
6170  dxc => gridstruct%dxc
6171  dyc => gridstruct%dyc
6172 
6173  fc => gridstruct%fC
6174  f0 => gridstruct%f0
6175 
6176  !These are frequently used and so have pointers set up for them
6177  dx_const => flagstruct%dx_const
6178  dy_const => flagstruct%dy_const
6179 
6180  domain => domain_in
6181  tile => tile_in
6182 
6183  have_south_pole => gridstruct%have_south_pole
6184  have_north_pole => gridstruct%have_north_pole
6185 
6186  ntiles_g => gridstruct%ntiles_g
6187  acapn => gridstruct%acapN
6188  acaps => gridstruct%acapS
6189  globalarea => gridstruct%globalarea
6190 
6191  f0_const = 2.*omega*sin(flagstruct%deglat/180.*pi)
6192  f0(:,:) = f0_const
6193  fc(:,:) = f0_const
6194 
6195  q = 0.
6196 
6197  select case (test_case)
6198  case ( 1 )
6199 
6200  phis(:,:)=0.
6201 
6202  u(:,:,:)=10.
6203  v(:,:,:)=10.
6204  ua(:,:,:)=10.
6205  va(:,:,:)=10.
6206  uc(:,:,:)=10.
6207  vc(:,:,:)=10.
6208  pt(:,:,:)=1.
6209  delp(:,:,:)=0.
6210 
6211  do j=js,je
6212  if (j>0 .and. j<5) then
6213  do i=is,ie
6214  if (i>0 .and. i<5) then
6215  delp(i,j,:)=1.
6216  endif
6217  enddo
6218  endif
6219  enddo
6220  call mpp_update_domains( delp, domain )
6221 
6222  case ( 2 )
6223 
6224  phis(:,:) = 0.
6225 
6226 ! r0 = 5000.
6227  r0 = 5.*sqrt(dx_const**2 + dy_const**2)
6228  icenter = npx/2
6229  jcenter = npy/2
6230  do j=jsd,jed
6231  do i=isd,ied
6232  dist=(i-icenter)*dx_const*(i-icenter)*dx_const &
6233  +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6234  dist=min(r0,sqrt(dist))
6235  phis(i,j)=1500.*(1. - (dist/r0))
6236  enddo
6237  enddo
6238 
6239  u(:,:,:)=0.
6240  v(:,:,:)=0.
6241  ua(:,:,:)=0.
6242  va(:,:,:)=0.
6243  uc(:,:,:)=0.
6244  vc(:,:,:)=0.
6245  pt(:,:,:)=1.
6246  delp(:,:,:)=1500.
6247 
6248  case ( 14 )
6249 !---------------------------
6250 ! Doubly periodic Aqua-plane
6251 !---------------------------
6252  u(:,:,:) = 0.
6253  v(:,:,:) = 0.
6254  phis(:,:) = 0.
6255 
6256  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
6257  delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
6258 
6259  ! *** Add Initial perturbation ***
6260  if (bubble_do) then
6261  r0 = 100.*sqrt(dx_const**2 + dy_const**2)
6262  icenter = npx/2
6263  jcenter = npy/2
6264 
6265  do j=js,je
6266  do i=is,ie
6267  dist = (i-icenter)*dx_const*(i-icenter)*dx_const &
6268  +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6269  dist = min(r0, sqrt(dist))
6270  do k=1,npz
6271  prf = ak(k) + ps(i,j)*bk(k)
6272  if ( prf > 100.e2 ) then
6273  pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j)
6274  endif
6275  enddo
6276  enddo
6277  enddo
6278  endif
6279  if ( hydrostatic ) then
6280  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6281  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6282  moist_phys, .true., nwat , domain)
6283  else
6284  w(:,:,:) = 0.
6285  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6286  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6287  moist_phys, hydrostatic, nwat, domain, .true. )
6288  endif
6289 
6290  q = 0.
6291  do k=1,npz
6292  do j=js,je
6293  do i=is,ie
6294  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6295  enddo
6296 #ifdef MULTI_GASES
6297  call qsmith((ie-is+1)*(je-js+1), npz, &
6298  ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6299 #else
6300  call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6301 #endif
6302  do i=is,ie
6303  q(i,j,k,1) = max(2.e-6, 0.8*pm(i)/ps(i,j)*qs(i) )
6304  enddo
6305  enddo
6306  enddo
6307 
6308  case ( 15 )
6309 !---------------------------
6310 ! Doubly periodic bubble
6311 !---------------------------
6312  t00 = 250.
6313 
6314  u(:,:,:) = 0.
6315  v(:,:,:) = 0.
6316  pt(:,:,:) = t00
6317  q(:,:,:,:) = 1.e-6
6318 
6319  if ( .not. hydrostatic ) w(:,:,:) = 0.
6320 
6321  do j=jsd,jed
6322  do i=isd,ied
6323  phis(i,j) = 0.
6324  ps(i,j) = 1000.e2
6325  enddo
6326  enddo
6327 
6328  do k=1,npz
6329  do j=jsd,jed
6330  do i=isd,ied
6331  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6332  enddo
6333  enddo
6334  enddo
6335 
6336 
6337  do k=1,npz
6338  do j=jsd,jed
6339  do i=isd,ied
6340  ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6341 ! pt(i,j,k) = t00
6342  enddo
6343  enddo
6344  enddo
6345 
6346  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6347  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6348  moist_phys, .false., nwat, domain)
6349 
6350 ! *** Add Initial perturbation ***
6351  r0 = 5.*max(dx_const, dy_const)
6352  zc = 0.5e3 ! center of bubble from surface
6353  icenter = npx/2
6354  jcenter = npy/2
6355 
6356  do j=js,je
6357  do i=is,ie
6358  ze = 0.
6359  do k=npz,1,-1
6360  zm = ze - 0.5*delz(i,j,k) ! layer center
6361  ze = ze - delz(i,j,k)
6362  dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + &
6363  (zm-zc)**2
6364  dist = sqrt(dist)
6365  if ( dist <= r0 ) then
6366  pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
6367  endif
6368  enddo
6369  enddo
6370  enddo
6371 
6372  case ( 16 )
6373 !------------------------------------
6374 ! Non-hydrostatic 3D density current:
6375 !------------------------------------
6376  phis = 0.
6377  u = 0.
6378  v = 0.
6379  w = 0.
6380  t00 = 300.
6381  p00 = 1.e5
6382  pk0 = p00**kappa
6383 ! Set up vertical coordinare with constant del-z spacing:
6384 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
6385  ztop = 6.4e3
6386  ze1( 1) = ztop
6387  ze1(npz+1) = 0.
6388  do k=npz,2,-1
6389  ze1(k) = ze1(k+1) + ztop/real(npz)
6390  enddo
6391 
6392  do j=js,je
6393  do i=is,ie
6394  ps(i,j) = p00
6395  pe(i,npz+1,j) = p00
6396  pk(i,j,npz+1) = pk0
6397  enddo
6398  enddo
6399 
6400  do k=npz,1,-1
6401  do j=js,je
6402  do i=is,ie
6403  delz(i,j,k) = ze1(k+1) - ze1(k)
6404  pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
6405  pe(i,k,j) = pk(i,j,k)**(1./kappa)
6406  enddo
6407  enddo
6408  enddo
6409 
6410  ptop = pe(is,1,js)
6411  if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
6412 
6413  do k=1,npz+1
6414  do j=js,je
6415  do i=is,ie
6416  peln(i,k,j) = log(pe(i,k,j))
6417  ze0(i,j,k) = ze1(k)
6418  enddo
6419  enddo
6420  enddo
6421 
6422  do k=1,npz
6423  do j=js,je
6424  do i=is,ie
6425  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6426  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6427  pt(i,j,k) = t00/pk0 ! potential temp
6428  enddo
6429  enddo
6430  enddo
6431 
6432  pturb = 15.
6433  xmax = 51.2e3
6434  xc = xmax / 2.
6435 
6436  do k=1,npz
6437  zm = (0.5*(ze1(k)+ze1(k+1))-3.e3) / 2.e3
6438  do j=js,je
6439  do i=is,ie
6440 ! Impose perturbation in potential temperature: pturb
6441  xx = (dx_const * (0.5+real(i-1)) - xc) / 4.e3
6442  yy = (dy_const * (0.5+real(j-1)) - xc) / 4.e3
6443  dist = sqrt( xx**2 + yy**2 + zm**2 )
6444  if ( dist<=1. ) then
6445  pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
6446  endif
6447 ! Transform back to temperature:
6448  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
6449  enddo
6450  enddo
6451  enddo
6452 
6453  case ( 17 )
6454 !---------------------------
6455 ! Doubly periodic SuperCell, straight wind (v==0)
6456 !--------------------------
6457  zvir = rvgas/rdgas - 1.
6458  p00 = 1000.e2
6459  ps(:,:) = p00
6460  phis(:,:) = 0.
6461  do j=js,je
6462  do i=is,ie
6463  pk(i,j,1) = ptop**kappa
6464  pe(i,1,j) = ptop
6465  peln(i,1,j) = log(ptop)
6466  enddo
6467  enddo
6468 
6469  do k=1,npz
6470  do j=js,je
6471  do i=is,ie
6472  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6473  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6474  peln(i,k+1,j) = log(pe(i,k+1,j))
6475  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6476  enddo
6477  enddo
6478  enddo
6479 
6480  i = is
6481  j = js
6482  do k=1,npz
6483  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6484  enddo
6485 
6486 
6487  v(:,:,:) = 0.
6488  w(:,:,:) = 0.
6489  q(:,:,:,:) = 0.
6490 
6491  do k=1,npz
6492  do j=js,je
6493  do i=is,ie
6494  pt(i,j,k) = ts1(k)
6495  q(i,j,k,1) = qs1(k)
6496  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6497  enddo
6498  enddo
6499  enddo
6500 
6501  ze1(npz+1) = 0.
6502  do k=npz,1,-1
6503  ze1(k) = ze1(k+1) - delz(is,js,k)
6504  enddo
6505 
6506  do k=1,npz
6507  zm = 0.5*(ze1(k)+ze1(k+1))
6508  utmp = us0*tanh(zm/3.e3)
6509  do j=js,je+1
6510  do i=is,ie
6511  u(i,j,k) = utmp
6512  enddo
6513  enddo
6514  enddo
6515 
6516  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6517  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6518  .true., hydrostatic, nwat, domain)
6519 
6520 ! *** Add Initial perturbation ***
6521  pturb = 2.
6522  r0 = 10.e3
6523  zc = 1.4e3 ! center of bubble from surface
6524  icenter = (npx-1)/3 + 1
6525  jcenter = (npy-1)/2 + 1
6526  do k=1, npz
6527  zm = 0.5*(ze1(k)+ze1(k+1))
6528  ptmp = ( (zm-zc)/zc ) **2
6529  if ( ptmp < 1. ) then
6530  do j=js,je
6531  do i=is,ie
6532  dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6533  if ( dist < 1. ) then
6534  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6535  endif
6536  enddo
6537  enddo
6538  endif
6539  enddo
6540 
6541  case ( 18 )
6542 !---------------------------
6543 ! Doubly periodic SuperCell, quarter circle hodograph
6544 ! M. Toy, Apr 2013, MWR
6545  pturb = 2.5
6546  zvir = rvgas/rdgas - 1.
6547  p00 = 1000.e2
6548  ps(:,:) = p00
6549  phis(:,:) = 0.
6550  do j=js,je
6551  do i=is,ie
6552  pk(i,j,1) = ptop**kappa
6553  pe(i,1,j) = ptop
6554  peln(i,1,j) = log(ptop)
6555  enddo
6556  enddo
6557 
6558  do k=1,npz
6559  do j=js,je
6560  do i=is,ie
6561  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6562  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6563  peln(i,k+1,j) = log(pe(i,k+1,j))
6564  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6565  enddo
6566  enddo
6567  enddo
6568 
6569  i = is
6570  j = js
6571  do k=1,npz
6572  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6573  enddo
6574 
6575 
6576  w(:,:,:) = 0.
6577  q(:,:,:,:) = 0.
6578 
6579  do k=1,npz
6580  do j=js,je
6581  do i=is,ie
6582  pt(i,j,k) = ts1(k)
6583  q(i,j,k,1) = qs1(k)
6584  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6585  enddo
6586  enddo
6587  enddo
6588 
6589  ze1(npz+1) = 0.
6590  do k=npz,1,-1
6591  ze1(k) = ze1(k+1) - delz(is,js,k)
6592  enddo
6593 
6594 ! Quarter-circle hodograph (Harris approximation)
6595  us0 = 30.
6596  do k=1,npz
6597  zm = 0.5*(ze1(k)+ze1(k+1))
6598  if ( zm .le. 2.e3 ) then
6599  utmp = 8.*(1.-cos(pi*zm/4.e3))
6600  vtmp = 8.*sin(pi*zm/4.e3)
6601  elseif (zm .le. 6.e3 ) then
6602  utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
6603  vtmp = 8.
6604  else
6605  utmp = us0
6606  vtmp = 8.
6607  endif
6608 ! u-wind
6609  do j=js,je+1
6610  do i=is,ie
6611  u(i,j,k) = utmp - 8.
6612  enddo
6613  enddo
6614 ! v-wind
6615  do j=js,je
6616  do i=is,ie+1
6617  v(i,j,k) = vtmp - 4.
6618  enddo
6619  enddo
6620  enddo
6621 
6622 
6623  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6624  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6625  .true., hydrostatic, nwat, domain)
6626 
6627 ! *** Add Initial perturbation ***
6628  if (bubble_do) then
6629  r0 = 10.e3
6630  zc = 1.4e3 ! center of bubble from surface
6631  icenter = (npx-1)/2 + 1
6632  jcenter = (npy-1)/2 + 1
6633  do k=1, npz
6634  zm = 0.5*(ze1(k)+ze1(k+1))
6635  ptmp = ( (zm-zc)/zc ) **2
6636  if ( ptmp < 1. ) then
6637  do j=js,je
6638  do i=is,ie
6639  dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6640  if ( dist < 1. ) then
6641  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6642  endif
6643  enddo
6644  enddo
6645  endif
6646  enddo
6647  endif
6648 
6649  case ( 101 )
6650 
6651 ! IC for LES
6652  t00 = 250. ! constant temp
6653  p00 = 1.e5
6654  pk0 = p00**kappa
6655 
6656  phis = 0.
6657  u = 0.
6658  v = 0.
6659  w = 0.
6660  pt(:,:,:) = t00
6661  q(:,:,:,1) = 0.
6662 
6663  if (.not.hybrid_z) call mpp_error(fatal, 'hybrid_z must be .TRUE.')
6664 
6665  rgrav = 1./ grav
6666 
6667  if ( npz/=101) then
6668  call mpp_error(fatal, 'npz must be == 101 ')
6669  else
6670  call compute_dz_l101( npz, ztop, dz1 )
6671  endif
6672 
6673  call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
6674  phis, ze0, delz)
6675 
6676  do j=js,je
6677  do i=is,ie
6678  ps(i,j) = p00
6679  pe(i,npz+1,j) = p00
6680  pk(i,j,npz+1) = pk0
6681  peln(i,npz+1,j) = log(p00)
6682  enddo
6683  enddo
6684 
6685  do k=npz,1,-1
6686  do j=js,je
6687  do i=is,ie
6688  peln(i,k,j) = peln(i,k+1,j) + grav*delz(i,j,k)/(rdgas*t00)
6689  pe(i,k,j) = exp(peln(i,k,j))
6690  pk(i,j,k) = pe(i,k,j)**kappa
6691  enddo
6692  enddo
6693  enddo
6694 
6695 
6696 ! Set up fake "sigma" coordinate
6697  call make_eta_level(npz, pe, area, ks, ak, bk, ptop, domain, bd)
6698 
6699  if ( is_master() ) write(*,*) 'LES testcase: computed model top (mb)=', ptop/100.
6700 
6701  do k=1,npz
6702  do j=js,je
6703  do i=is,ie
6704  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6705  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6706  enddo
6707  enddo
6708  enddo
6709 
6710  do k=1,npz
6711  do j=js,je
6712  do i=is,ie
6713  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6714  enddo
6715 #ifdef MULTI_GASES
6716  call qsmith((ie-is+1)*(je-js+1), npz, &
6717  ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6718 #else
6719  call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6720 #endif
6721  do i=is,ie
6722  if ( pm(i) > 100.e2 ) then
6723  q(i,j,k,1) = 0.9*qs(i)
6724  else
6725  q(i,j,k,1) = 2.e-6
6726  endif
6727  enddo
6728  enddo
6729  enddo
6730 
6731 ! *** Add perturbation ***
6732  r0 = 1.0e3 ! radius (m)
6733  zc = 1.0e3 ! center of bubble
6734  icenter = npx/2
6735  jcenter = npy/2
6736 
6737  do k=1,npz
6738  do j=js,je
6739  do i=is,ie
6740  zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1))
6741  dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2
6742  dist = sqrt(dist)
6743  if ( dist <= r0 ) then
6744  pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0)
6745  endif
6746  enddo
6747  enddo
6748  enddo
6749 
6750  end select
6751 
6752  nullify(grid)
6753  nullify(agrid)
6754 
6755  nullify(area)
6756 
6757  nullify(fc)
6758  nullify(f0)
6759 
6760  nullify(ee1)
6761  nullify(ee2)
6762  nullify(ew)
6763  nullify(es)
6764  nullify(en1)
6765  nullify(en2)
6766 
6767  nullify(dx)
6768  nullify(dy)
6769  nullify(dxa)
6770  nullify(dya)
6771  nullify(rdxa)
6772  nullify(rdya)
6773  nullify(dxc)
6774  nullify(dyc)
6775 
6776  nullify(dx_const)
6777  nullify(dy_const)
6778 
6779  nullify(domain)
6780  nullify(tile)
6781 
6782  nullify(have_south_pole)
6783  nullify(have_north_pole)
6784 
6785  nullify(ntiles_g)
6786  nullify(acapn)
6787  nullify(acaps)
6788  nullify(globalarea)
6789 
6790  end subroutine init_double_periodic
6791 
6792  subroutine superk_sounding(km, pe, p00, ze, pt, qz)
6793  integer, intent(in):: km
6794  real, intent(in):: p00
6795  real, intent(inout), dimension(km+1):: pe
6796  real, intent(in), dimension(km+1):: ze
6797 ! pt: potential temperature / pk0
6798 ! qz: specific humidity (mixing ratio)
6799  real, intent(out), dimension(km):: pt, qz
6800 ! Local:
6801  integer, parameter:: nx = 5
6802  real, parameter:: qst = 1.0e-6
6803  real, parameter:: qv0 = 1.4e-2
6804  real, parameter:: ztr = 12.e3
6805  real, parameter:: ttr = 213.
6806  real, parameter:: ptr = 343.
6807  real, parameter:: pt0 = 300.
6808  real, dimension(km):: zs, rh, temp, dp, dp0
6809  real, dimension(km+1):: peln, pk
6810  real:: qs, zvir, fac_z, pk0, temp1, pm
6811  integer:: k, n, kk
6812 
6813  zvir = rvgas/rdgas - 1.
6814  pk0 = p00**kappa
6815  if ( (is_master()) ) then
6816  write(*,*) 'Computing sounding for HIWPP super-cell test using p00=', p00
6817  endif
6818 
6819  qz(:) = qst
6820  rh(:) = 0.25
6821 
6822  do k=1, km
6823  zs(k) = 0.5*(ze(k)+ze(k+1))
6824 ! Potential temperature
6825  if ( zs(k) .gt. ztr ) then
6826 ! Stratosphere:
6827  pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
6828  else
6829 ! Troposphere:
6830  fac_z = (zs(k)/ztr)**1.25
6831  pt(k) = pt0 + (ptr-pt0)* fac_z
6832  rh(k) = 1. - 0.75 * fac_z
6833 ! First guess on q:
6834  qz(k) = qv0 - (qv0-qst)*fac_z
6835  endif
6836  if ( is_master() ) write(*,*) zs(k), pt(k), qz(k)
6837 ! Convert to FV's definition of potential temperature
6838  pt(k) = pt(k) / pk0
6839  enddo
6840 
6841 #ifdef USE_MOIST_P00
6842 !--------------------------------------
6843 ! Iterate nx times with virtual effect:
6844 !--------------------------------------
6845 ! pt & height remain unchanged
6846  pk(km+1) = pk0
6847  pe(km+1) = p00 ! Dry
6848  peln(km+1) = log(p00)
6849 
6850  do n=1, nx
6851 ! Derive pressure fields from hydrostatic balance:
6852  do k=km,1,-1
6853  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6854  peln(k) = log(pk(k)) / kappa
6855  pe(k) = exp(peln(k))
6856  enddo
6857  do k=1, km
6858  pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
6859  temp(k) = pt(k)*pm**kappa
6860 ! NCAR form:
6861  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6862  qz(k) = min( qv0, rh(k)*qs )
6863  if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
6864  enddo
6865  enddo
6866 #else
6867 ! pt & height remain unchanged
6868  pk(km+1) = pk0
6869  pe(km+1) = p00 ! Dry
6870  peln(km+1) = log(p00)
6871 
6872 ! Derive "dry" pressure fields from hydrostatic balance:
6873  do k=km,1,-1
6874  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k))
6875  peln(k) = log(pk(k)) / kappa
6876  pe(k) = exp(peln(k))
6877  enddo
6878  do k=1, km
6879  dp0(k) = pe(k+1) - pe(k)
6880  pm = dp0(k)/(peln(k+1)-peln(k))
6881  temp(k) = pt(k)*pm**kappa
6882 ! NCAR form:
6883  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6884  qz(k) = min( qv0, rh(k)*qs )
6885  enddo
6886 
6887  do n=1, nx
6888 
6889  do k=1, km
6890  dp(k) = dp0(k)*(1. + qz(k)) ! moist air
6891  pe(k+1) = pe(k) + dp(k)
6892  enddo
6893 ! dry pressure, pt & height remain unchanged
6894  pk(km+1) = pe(km+1)**kappa
6895  peln(km+1) = log(pe(km+1))
6896 
6897 ! Derive pressure fields from hydrostatic balance:
6898  do k=km,1,-1
6899  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6900  peln(k) = log(pk(k)) / kappa
6901  pe(k) = exp(peln(k))
6902  enddo
6903  do k=1, km
6904  pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
6905  temp(k) = pt(k)*pm**kappa
6906 ! NCAR form:
6907  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6908  qz(k) = min( qv0, rh(k)*qs )
6909  if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
6910  enddo
6911  enddo
6912 #endif
6913 
6914  if ( is_master() ) then
6915  write(*,*) 'Super_K: computed ptop (mb)=', 0.01*pe(1), ' PS=', 0.01*pe(km+1)
6916  call prt_m1('1D Sounding T0', temp, 1, km, 1, 1, 0, 1, 1.)
6917  endif
6918 
6919  end subroutine superk_sounding
6920 
6921  subroutine balanced_k(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
6922  delz, zvir, ptop, ak, bk, agrid)
6923  integer, intent(in):: is, ie, js, je, ng, km
6924  real, intent(in), dimension(km ):: ts1, qs1, uz1, dudz
6925  real, intent(in), dimension(km+1):: ze1
6926  real, intent(in):: zvir, ps0
6927  real, intent(inout):: ptop
6928  real(kind=R_GRID), intent(in):: agrid(is-ng:ie+ng,js-ng:je+ng,2)
6929  real, intent(inout), dimension(km+1):: ak, bk
6930  real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delz
6931  real, intent(out), dimension(is:ie,js:je,km+1):: pk
6932 ! pt is FV's cp*thelta_v
6933  real, intent(inout), dimension(is-1:ie+1,km+1,js-1:je+1):: pe
6934 ! Local
6935  integer, parameter:: nt=5
6936  integer, parameter:: nlat=1001
6937  real, dimension(nlat,km):: pt2, pky, dzc
6938  real, dimension(nlat,km+1):: pk2, pe2, peln2, pte
6939  real, dimension(km+1):: pe1
6940  real:: lat(nlat), latc(nlat-1)
6941  real:: fac_y, dlat, dz0, pk0, tmp1, tmp2, tmp3, pint
6942  integer::i,j,k,n, jj, k1
6943  real:: p00=1.e5
6944 
6945  pk0 = p00**kappa
6946  dz0 = ze1(km) - ze1(km+1)
6947 !!! dzc(:,:) =dz0
6948 
6949  dlat = 0.5*pi/real(nlat-1)
6950  do j=1,nlat
6951  lat(j) = dlat*real(j-1)
6952  do k=1,km
6953  dzc(j,k) = ze1(k) - ze1(k+1)
6954  enddo
6955  enddo
6956  do j=1,nlat-1
6957  latc(j) = 0.5*(lat(j)+lat(j+1))
6958  enddo
6959 
6960 ! Initialize pt2
6961  do k=1,km
6962  do j=1,nlat
6963  pt2(j,k) = ts1(k)
6964  enddo
6965  enddo
6966  if ( is_master() ) then
6967  tmp1 = pk0/cp_air
6968  call prt_m1('Super_K PT0', pt2, 1, nlat, 1, km, 0, 1, tmp1)
6969  endif
6970 
6971 ! pt2 defined from Eq to NP
6972 ! Check NP
6973  do n=1, nt
6974 ! Compute edge values
6975  call ppme(pt2, pte, dzc, nlat, km)
6976  do k=1,km
6977  do j=2,nlat
6978  tmp1 = 0.5*(pte(j-1,k ) + pte(j,k ))
6979  tmp3 = 0.5*(pte(j-1,k+1) + pte(j,k+1))
6980  pt2(j,k) = pt2(j-1,k) + dlat/(2.*grav)*sin(2.*latc(j-1))*uz1(k)* &
6981  ( uz1(k)*(tmp1-tmp3)/dzc(j,k) - (pt2(j-1,k)+pt2(j,k))*dudz(k) )
6982  enddo
6983  enddo
6984  if ( is_master() ) then
6985  call prt_m1('Super_K PT', pt2, 1, nlat, 1, km, 0, 1, pk0/cp_air)
6986  endif
6987  enddo
6988 !
6989 ! Compute surface pressure using gradient-wind balance:
6990 !!! pk2(1,km+1) = pk0
6991  pk2(1,km+1) = ps0**kappa ! fixed at equator
6992  do j=2,nlat
6993  pk2(j,km+1) = pk2(j-1,km+1) - dlat*uz1(km)*uz1(km)*sin(2.*latc(j-1)) &
6994  / (pt2(j-1,km) + pt2(j,km))
6995  enddo
6996 ! Compute pressure using hydrostatic balance:
6997  do j=1,nlat
6998  do k=km,1,-1
6999  pk2(j,k) = pk2(j,k+1) - grav*dzc(j,k)/pt2(j,k)
7000  enddo
7001  enddo
7002 
7003  do k=1,km+1
7004  do j=1,nlat
7005  peln2(j,k) = log(pk2(j,k)) / kappa
7006  pe2(j,k) = exp(peln2(j,k))
7007  enddo
7008  enddo
7009 ! Convert pt2 to temperature
7010  do k=1,km
7011  do j=1,nlat
7012  pky(j,k) = (pk2(j,k+1)-pk2(j,k))/(kappa*(peln2(j,k+1)-peln2(j,k)))
7013  pt2(j,k) = pt2(j,k)*pky(j,k)/(cp_air*(1.+zvir*qs1(k)))
7014  enddo
7015  enddo
7016 
7017  do k=1,km+1
7018  pe1(k) = pe2(1,k)
7019  enddo
7020 
7021  if ( is_master() ) then
7022  write(*,*) 'SuperK ptop at EQ=', 0.01*pe1(1), 'new ptop=', 0.01*ptop
7023  call prt_m1('Super_K pe', pe2, 1, nlat, 1, km+1, 0, 1, 0.01)
7024  call prt_m1('Super_K Temp', pt2, 1, nlat, 1, km, 0, 1, 1.)
7025  endif
7026 
7027 ! Interpolate (pt2, pk2) from lat-dir to cubed-sphere
7028  do j=js, je
7029  do i=is, ie
7030  do jj=1,nlat-1
7031  if (abs(agrid(i,j,2))>=lat(jj) .and. abs(agrid(i,j,2))<=lat(jj+1) ) then
7032 ! found it !
7033  fac_y = (abs(agrid(i,j,2))-lat(jj)) / dlat
7034  do k=1,km
7035  pt(i, j,k) = pt2(jj, k) + fac_y*(pt2(jj+1, k)-pt2(jj,k))
7036  enddo
7037  do k=1,km+1
7038  pe(i,k,j) = pe2(jj,k) + fac_y*(pe2(jj+1,k)-pe2(jj,k))
7039  enddo
7040 ! k = km+1
7041 ! pk(i,j,k) = pk2(jj,k) + fac_y*(pk2(jj+1,k)-pk2(jj,k))
7042  goto 123
7043  endif
7044  enddo
7045 123 continue
7046  enddo
7047  enddo
7048 
7049 ! Adjust pk
7050 ! ak & bk
7051 ! Adjusting model top to be a constant pressure surface, assuming isothermal atmosphere
7052 ! pe = ak + bk*ps
7053 ! One pressure layer
7054  pe1(1) = ptop
7055  ak(1) = ptop
7056  pint = pe1(2)
7057  bk(1) = 0.
7058  ak(2) = pint
7059  bk(2) = 0.
7060  do k=3,km+1
7061  bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma
7062  ak(k) = pe1(k) - bk(k) * pe1(km+1)
7063  if ( is_master() ) write(*,*) k, ak(k), bk(k)
7064  enddo
7065  ak(km+1) = 0.
7066  bk(km+1) = 1.
7067  do j=js, je
7068  do i=is, ie
7069  pe(i,1,j) = ptop
7070  enddo
7071  enddo
7072 
7073 
7074  end subroutine balanced_k
7075 
7076  subroutine superk_u(km, zz, um, dudz)
7077  integer, intent(in):: km
7078  real, intent(in):: zz(km)
7079  real, intent(out):: um(km), dudz(km)
7080 ! Local
7081  real, parameter:: zs = 5.e3
7082  real, parameter:: us = 30.
7083  real:: uc = 15.
7084  integer k
7085 
7086  do k=1, km
7087 #ifndef TEST_TANHP
7088 ! MPAS specification:
7089  if ( zz(k) .gt. zs+1.e3 ) then
7090  um(k) = us
7091  dudz(k) = 0.
7092  elseif ( abs(zz(k)-zs) .le. 1.e3 ) then
7093  um(k) = us*(-4./5. + 3.*zz(k)/zs - 5./4.*(zz(k)/zs)**2)
7094  dudz(k) = us/zs*(3. - 5./2.*zz(k)/zs)
7095  else
7096  um(k) = us*zz(k)/zs
7097  dudz(k) = us/zs
7098  endif
7099 ! constant wind so as to make the storm relatively stationary
7100  um(k) = um(k) - uc
7101 #else
7102  uc = 12. ! this gives near stationary (in longitude) storms
7103  um(k) = us*tanh( zz(k)/zs ) - uc
7104  dudz(k) = (us/zs)/cosh(zz(k)/zs)**2
7105 #endif
7106  enddo
7107 
7108  end subroutine superk_u
7109 
7110 
7111  subroutine dcmip16_bc(delp,pt,u,v,q,w,delz,&
7112  is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7113  pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7114  hydrostatic, nwat, adiabatic, do_pert, domain)
7115 
7116  integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7117  real, intent(IN) :: ptop
7118  real, intent(IN), dimension(npz+1) :: ak, bk
7119  real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7120  real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz
7121  real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7122  real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7123  real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7124  real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7125  real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7126  real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7127  real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7128  real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7129  real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7130  real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7131  logical, intent(IN) :: hydrostatic,adiabatic,do_pert
7132  type(domain2d), intent(INOUT) :: domain
7133 
7134  real, parameter :: p0 = 1.e5
7135  real, parameter :: u0 = 35.
7136  real, parameter :: b = 2.
7137  real, parameter :: KK = 3.
7138  real, parameter :: Te = 310.
7139  real, parameter :: Tp = 240.
7140  real, parameter :: T0 = 0.5*(te + tp) !!WRONG in document
7141  real, parameter :: up = 1.
7142  real, parameter :: zp = 1.5e4
7143  real(kind=R_GRID), parameter :: lamp = pi/9.
7144  real(kind=R_GRID), parameter :: phip = 2.*lamp
7145  real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7146  real, parameter :: Rp = radius/10.
7147  real, parameter :: lapse = 5.e-3
7148  real, parameter :: dT = 4.8e5
7149  real, parameter :: phiW = 2.*pi/9.
7150  real, parameter :: pW = 34000.
7151  real, parameter :: q0 = .018
7152  real, parameter :: qt = 1.e-12
7153  real, parameter :: ptrop = 1.e4
7154 
7155  real, parameter :: zconv = 1.e-6
7156  real, parameter :: rdgrav = rdgas/grav
7157  real, parameter :: zvir = rvgas/rdgas - 1.
7158  real, parameter :: rrdgrav = grav/rdgas
7159 
7160  integer :: i,j,k,iter, sphum, cl, cl2, n
7161  real :: p,z,z0,ziter,piter,titer,uu,vv,pl,pt_u,pt_v
7162  real(kind=R_GRID), dimension(2) :: pa
7163  real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7164  real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2
7165  real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7166  real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2
7167  real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7168 
7169  !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7170  ! (with or without perturbation), moisture, Terminator tracer, w, delz
7171 
7172  !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7173  ! and meridional winds on both grids, and rotate as needed
7174 
7175  !PS
7176  do j=js,je
7177  do i=is,ie
7178  ps(i,j) = p0
7179  enddo
7180  enddo
7181 
7182  !delp
7183  do k=1,npz
7184  do j=js,je
7185  do i=is,ie
7186  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7187  enddo
7188  enddo
7189  enddo
7190 
7191  !Pressure variables
7192  do j=js,je
7193  do i=is,ie
7194  pe(i,1,j) = ptop
7195  enddo
7196  do i=is,ie
7197  peln(i,1,j) = log(ptop)
7198  pk(i,j,1) = ptop**kappa
7199  enddo
7200  do k=2,npz+1
7201  do i=is,ie
7202  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
7203  enddo
7204  do i=is,ie
7205  pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7206  peln(i,k,j) = log(pe(i,k,j))
7207  enddo
7208  enddo
7209  enddo
7210 
7211  do k=1,npz
7212  do j=js,je
7213  do i=is,ie
7214  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7215  enddo
7216  enddo
7217  enddo
7218 
7219  !Height: Use Newton's method
7220  !Cell centered
7221  do j=js,je
7222  do i=is,ie
7223  phis(i,j) = 0.
7224  gz(i,j,npz+1) = 0.
7225  enddo
7226  enddo
7227  do k=npz,1,-1
7228  do j=js,je
7229  do i=is,ie
7230  p = pe(i,k,j)
7231  z = gz(i,j,k+1)
7232  do iter=1,30
7233  ziter = z
7234  piter = dcmip16_bc_pressure(ziter,agrid(i,j,2))
7235  titer = dcmip16_bc_temperature(ziter,agrid(i,j,2))
7236  z = ziter + (piter - p)*rdgrav*titer/piter
7237 !!$ !!! DEBUG CODE
7238 !!$ if (is_master() .and. i == is .and. j == js) then
7239 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7240 !!$ endif
7241 !!$ !!! END DEBUG CODE
7242  if (abs(z - ziter) < zconv) exit
7243  enddo
7244  gz(i,j,k) = z
7245  enddo
7246  enddo
7247  enddo
7248 
7249  !Temperature: Compute from hydro balance
7250  do k=1,npz
7251  do j=js,je
7252  do i=is,ie
7253  pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7254  enddo
7255  enddo
7256  enddo
7257 
7258  !Compute height and temperature for u and v points also, to be able to compute the local winds
7259  !Use temporary 2d arrays for this purpose
7260  do j=js,je+1
7261  do i=is,ie
7262  gz_u(i,j) = 0.
7263  p_u(i,j) = p0
7264  peln_u(i,j) = log(p0)
7265  ps_u(i,j) = p0
7266  call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7267  lat_u(i,j) = pa(2)
7268  lon_u(i,j) = pa(1)
7269  call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7270  call get_latlon_vector(pa,ex,ey)
7271  u1(i,j) = inner_prod(e1,ex) !u components
7272  u2(i,j) = inner_prod(e1,ey)
7273  enddo
7274  enddo
7275  do k=npz,1,-1
7276  do j=js,je+1
7277  do i=is,ie
7278  !Pressure (Top of interface)
7279  p = ak(k) + ps_u(i,j)*bk(k)
7280  pl = log(p)
7281  !Height (top of interface); use newton's method
7282  z = gz_u(i,j) !first guess, height of lower level
7283  z0 = z
7284  do iter=1,30
7285  ziter = z
7286  piter = dcmip16_bc_pressure(ziter,lat_u(i,j))
7287  titer = dcmip16_bc_temperature(ziter,lat_u(i,j))
7288  z = ziter + (piter - p)*rdgrav*titer/piter
7289  if (abs(z - ziter) < zconv) exit
7290  enddo
7291  !Temperature, compute from hydro balance
7292  pt_u = rrdgrav * ( z - gz_u(i,j) ) / (peln_u(i,j) - pl)
7293  !Now compute winds. Note no meridional winds
7294  !!!NOTE: do we need to use LAYER-mean z?
7295  uu = dcmip16_bc_uwind(0.5*(z+z0),pt_u,lat_u(i,j))
7296  if (do_pert) then
7297  uu = uu + dcmip16_bc_uwind_pert(0.5*(z+z0),lat_u(i,j),lon_u(i,j))
7298  endif
7299  u(i,j,k) = u1(i,j)*uu
7300 
7301  gz_u(i,j) = z
7302  p_u(i,j) = p
7303  peln_u(i,j) = pl
7304  enddo
7305  enddo
7306  enddo
7307 
7308  do j=js,je
7309  do i=is,ie+1
7310  gz_v(i,j) = 0.
7311  p_v(i,j) = p0
7312  peln_v(i,j) = log(p0)
7313  ps_v(i,j) = p0
7314  call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7315  lat_v(i,j) = pa(2)
7316  lon_v(i,j) = pa(1)
7317  call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7318  call get_latlon_vector(pa,ex,ey)
7319  v1(i,j) = inner_prod(e2,ex) !v components
7320  v2(i,j) = inner_prod(e2,ey)
7321  enddo
7322  enddo
7323  do k=npz,1,-1
7324  do j=js,je
7325  do i=is,ie+1
7326  !Pressure (Top of interface)
7327  p = ak(k) + ps_v(i,j)*bk(k)
7328  pl = log(p)
7329  !Height (top of interface); use newton's method
7330  z = gz_v(i,j) !first guess, height of lower level
7331  z0 = z
7332  do iter=1,30
7333  ziter = z
7334  piter = dcmip16_bc_pressure(ziter,lat_v(i,j))
7335  titer = dcmip16_bc_temperature(ziter,lat_v(i,j))
7336  z = ziter + (piter - p)*rdgrav*titer/piter
7337  if (abs(z - ziter) < zconv) exit
7338  enddo
7339  !Temperature, compute from hydro balance
7340  pt_v = rrdgrav * ( z - gz_v(i,j) ) / (peln_v(i,j) - pl)
7341  !Now compute winds
7342  uu = dcmip16_bc_uwind(0.5*(z+z0),pt_v,lat_v(i,j))
7343  if (do_pert) then
7344  uu = uu + dcmip16_bc_uwind_pert(0.5*(z+z0),lat_v(i,j),lon_v(i,j))
7345  endif
7346  v(i,j,k) = v1(i,j)*uu
7347  gz_v(i,j) = z
7348  p_v(i,j) = p
7349  peln_v(i,j) = pl
7350  enddo
7351  enddo
7352  enddo
7353 
7354  !Compute moisture and other tracer fields, as desired
7355  do n=1,nq
7356  do k=1,npz
7357  do j=jsd,jed
7358  do i=isd,ied
7359  q(i,j,k,n) = 0.
7360  enddo
7361  enddo
7362  enddo
7363  enddo
7364  if (.not. adiabatic) then
7365  sphum = get_tracer_index(model_atmos, 'sphum')
7366  do k=1,npz
7367  do j=js,je
7368  do i=is,ie
7369  p = delp(i,j,k)/(peln(i,k+1,j) - peln(i,k,j))
7370  q(i,j,k,sphum) = dcmip16_bc_sphum(p,ps(i,j),agrid(i,j,2),agrid(i,j,1))
7371  !Convert pt to non-virtual temperature
7372  pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum))
7373  enddo
7374  enddo
7375  enddo
7376  endif
7377 
7378  cl = get_tracer_index(model_atmos, 'cl')
7379  cl2 = get_tracer_index(model_atmos, 'cl2')
7380  if (cl > 0 .and. cl2 > 0) then
7381  call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
7382  q, delp,nq,agrid(isd,jsd,1),agrid(isd,jsd,2))
7383  call mpp_update_domains(q,domain)
7384  endif
7385 
7386  !Compute nonhydrostatic variables, if needed
7387  if (.not. hydrostatic) then
7388  do k=1,npz
7389  do j=js,je
7390  do i=is,ie
7391  w(i,j,k) = 0.
7392  delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7393  enddo
7394  enddo
7395  enddo
7396  endif
7397 
7398  contains
7399 
7400 
7401  real function dcmip16_bc_temperature(z, lat)
7402 
7403  real, intent(IN) :: z
7404  real(kind=R_GRID), intent(IN) :: lat
7405  real :: it, t1, t2, tr, zsc
7406 
7407  it = exp(kk * log(cos(lat))) - kk/(kk+2.)*exp((kk+2.)*log(cos(lat)))
7408  zsc = z*grav/(b*rdgas*t0)
7409  tr = ( 1. - 2.*zsc**2.) * exp(-zsc**2. )
7410 
7411  t1 = (1./t0)*exp(lapse*z/t0) + (t0 - tp)/(t0*tp) * tr
7412  t2 = 0.5* ( kk + 2.) * (te - tp)/(te*tp) * tr
7413 
7414  dcmip16_bc_temperature = 1./(t1 - t2*it)
7415 
7416  end function dcmip16_bc_temperature
7417 
7418  real function dcmip16_bc_pressure(z,lat)
7419 
7420  real, intent(IN) :: z
7421  real(kind=R_GRID), intent(IN) :: lat
7422  real :: it, ti1, ti2, tir
7423 
7424  it = exp(kk * log(cos(lat))) - kk/(kk+2.)*exp((kk+2.)*log(cos(lat)))
7425  tir = z*exp(-(z*grav/(b*rdgas*t0))*(z*grav/(b*rdgas*t0)) )
7426 
7427  ti1 = 1./lapse* (exp(lapse*z/t0) - 1.) + tir*(t0-tp)/(t0*tp)
7428  ti2 = 0.5*(kk+2.)*(te-tp)/(te*tp) * tir
7429 
7430  dcmip16_bc_pressure = p0*exp(-grav/rdgas * ( ti1 - ti2*it))
7431 
7432  end function dcmip16_bc_pressure
7433 
7434  real function dcmip16_bc_uwind(z,T,lat)
7435 
7436  real, intent(IN) :: z, t
7437  real(kind=R_GRID), intent(IN) :: lat
7438  real :: tir, ti2, uu, ur
7439 
7440  tir = z*exp(-(z*grav/(b*rdgas*t0))*(z*grav/(b*rdgas*t0)) )
7441  ti2 = 0.5*(kk+2.)*(te-tp)/(te*tp) * tir
7442 
7443  uu = grav*kk/radius * ti2 * ( cos(lat)**(int(kk)-1) - cos(lat)**(int(kk)+1) ) * t
7444  ur = - omega * radius * cos(lat) + sqrt( (omega*radius*cos(lat))**2 + radius*cos(lat)*uu)
7445 
7446  dcmip16_bc_uwind = ur
7447 
7448  end function dcmip16_bc_uwind
7449 
7450  real function dcmip16_bc_uwind_pert(z,lat,lon)
7451 
7452  real, intent(IN) :: z
7453  real(kind=R_GRID), intent(IN) :: lat, lon
7454  real :: zz, zrat
7455  real(kind=R_GRID) :: dst, pphere(2)
7456 
7457  zrat = z/zp
7458  zz = max(1. - 3.*zrat*zrat + 2.*zrat*zrat*zrat, 0.)
7459 
7460  pphere = (/ lon, lat /)
7461  dst = great_circle_dist(pphere, ppcenter, radius)
7462 
7463  dcmip16_bc_uwind_pert = max(0., up*zz*exp(-(dst/rp)**2) )
7464 
7465  end function dcmip16_bc_uwind_pert
7466 
7467  real function dcmip16_bc_sphum(p,ps,lat, lon)
7468 
7469  real, intent(IN) :: p, ps
7470  real(kind=R_GRID), intent(IN) :: lat, lon
7471  real :: eta
7472 
7473  eta = p/ps
7474 
7475  dcmip16_bc_sphum = qt
7476  if (p > ptrop) then
7477  dcmip16_bc_sphum = q0 * exp(-(lat/phiw)**4) * exp(-( (eta-1.)*p0/pw)**2)
7478  endif
7479 
7480  end function dcmip16_bc_sphum
7481 
7482  end subroutine dcmip16_bc
7483 
7484  subroutine dcmip16_tc(delp,pt,u,v,q,w,delz,&
7485  is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7486  pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7487  hydrostatic, nwat, adiabatic)
7488 
7489  integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7490  real, intent(IN) :: ptop
7491  real, intent(IN), dimension(npz+1) :: ak, bk
7492  real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7493  real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz
7494  real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7495  real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7496  real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7497  real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7498  real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7499  real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7500  real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7501  real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7502  real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7503  real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7504  logical, intent(IN) :: hydrostatic,adiabatic
7505 
7506  real, parameter :: zt = 15000
7507  real, parameter :: q0 = 0.021
7508  real, parameter :: qt = 1.e-11
7509  real, parameter :: T0 = 302.15
7510  real, parameter :: Tv0 = 302.15*(1.+0.608*q0)
7511  real, parameter :: Ts = 302.15
7512  real, parameter :: zq1 = 3000.
7513  real, parameter :: zq2 = 8000.
7514  real, parameter :: lapse = 7.e-3
7515  real, parameter :: Tvt = tv0 - lapse*zt
7516  real, parameter :: pb = 101500.
7517  real, parameter :: ptt = pb*(tvt/tv0)**(grav/rdgas/lapse)
7518  real(kind=R_GRID), parameter :: lamp = pi
7519  real(kind=R_GRID), parameter :: phip = pi/18.
7520  real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7521  real, parameter :: dp = 1115.
7522  real, parameter :: rp = 282000.
7523  real, parameter :: zp = 7000.
7524  real, parameter :: fc = 2.*omega*sin(phip)
7525 
7526  real, parameter :: zconv = 1.e-6
7527  real, parameter :: rdgrav = rdgas/grav
7528  real, parameter :: rrdgrav = grav/rdgas
7529 
7530  integer :: i,j,k,iter, sphum, cl, cl2, n
7531  real :: p,z,z0,ziter,piter,titer,uu,vv,pl, r
7532  real(kind=R_GRID), dimension(2) :: pa
7533  real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7534  real, dimension(is:ie,js:je) :: rc
7535  real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2, rc_u
7536  real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7537  real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v
7538  real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7539 
7540  !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7541  ! (with or without perturbation), moisture, w, delz
7542 
7543  !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7544  ! and meridional winds on both grids, and rotate as needed
7545 
7546  !Save r for easy use
7547  do j=js,je
7548  do i=is,ie
7549  rc(i,j) = great_circle_dist(agrid(i,j,:), ppcenter, radius)
7550  enddo
7551  enddo
7552 
7553  !PS
7554  do j=js,je
7555  do i=is,ie
7556  ps(i,j) = pb - dp*exp( -sqrt((rc(i,j)/rp)**3) )
7557  enddo
7558  enddo
7559 
7560  !delp
7561  do k=1,npz
7562  do j=js,je
7563  do i=is,ie
7564  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7565  enddo
7566  enddo
7567  enddo
7568 
7569  !Pressure variables
7570  do j=js,je
7571  do i=is,ie
7572  pe(i,1,j) = ptop
7573  enddo
7574  do i=is,ie
7575  peln(i,1,j) = log(ptop)
7576  pk(i,j,1) = ptop**kappa
7577  enddo
7578  do k=2,npz+1
7579  do i=is,ie
7580  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
7581  enddo
7582  do i=is,ie
7583  pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7584  peln(i,k,j) = log(pe(i,k,j))
7585  enddo
7586  enddo
7587  enddo
7588 
7589  do k=1,npz
7590  do j=js,je
7591  do i=is,ie
7592  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7593  enddo
7594  enddo
7595  enddo
7596 
7597  !Height: Use Newton's method
7598  !Cell centered
7599  do j=js,je
7600  do i=is,ie
7601  phis(i,j) = 0.
7602  gz(i,j,npz+1) = 0.
7603  enddo
7604  enddo
7605  do k=npz,1,-1
7606  do j=js,je
7607  do i=is,ie
7608  p = pe(i,k,j)
7609  z = gz(i,j,k+1)
7610  do iter=1,30
7611  ziter = z
7612  piter = dcmip16_tc_pressure(ziter,rc(i,j))
7613  titer = dcmip16_tc_temperature(ziter,rc(i,j))
7614  z = ziter + (piter - p)*rdgrav*titer/piter
7615 !!$ !!! DEBUG CODE
7616 !!$ if (is_master() .and. i == is .and. j == js) then
7617 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7618 !!$ endif
7619 !!$ !!! END DEBUG CODE
7620  if (abs(z - ziter) < zconv) exit
7621  enddo
7622  gz(i,j,k) = z
7623  enddo
7624  enddo
7625  enddo
7626 
7627  !Temperature: Compute from hydro balance
7628  do k=1,npz
7629  do j=js,je
7630  do i=is,ie
7631  pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7632  enddo
7633  enddo
7634  enddo
7635 
7636  !Compute height and temperature for u and v points also, to be able to compute the local winds
7637  !Use temporary 2d arrays for this purpose
7638  do j=js,je+1
7639  do i=is,ie
7640  call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7641  lat_u(i,j) = pa(2)
7642  lon_u(i,j) = pa(1)
7643  call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7644  call get_latlon_vector(pa,ex,ey)
7645  u1(i,j) = inner_prod(e1,ex) !u components
7646  u2(i,j) = inner_prod(e1,ey)
7647  rc_u(i,j) = great_circle_dist(pa, ppcenter, radius)
7648  gz_u(i,j) = 0.
7649  p_u(i,j) = pb - dp*exp( -sqrt((rc_u(i,j)/rp)**3) )
7650  peln_u(i,j) = log(p_u(i,j))
7651  ps_u(i,j) = p_u(i,j)
7652  enddo
7653  enddo
7654  do k=npz,1,-1
7655  do j=js,je+1
7656  do i=is,ie
7657  !Pressure (Top of interface)
7658  p = ak(k) + ps_u(i,j)*bk(k)
7659  pl = log(p)
7660  !Height (top of interface); use newton's method
7661  z = gz_u(i,j) !first guess, height of lower level
7662  z0 = z
7663  do iter=1,30
7664  ziter = z
7665  piter = dcmip16_tc_pressure(ziter,rc_u(i,j))
7666  titer = dcmip16_tc_temperature(ziter,rc_u(i,j))
7667  z = ziter + (piter - p)*rdgrav*titer/piter
7668  if (abs(z - ziter) < zconv) exit
7669  enddo
7670  !Now compute winds
7671  call dcmip16_tc_uwind_pert(0.5*(z+z0),rc_u(i,j),lon_u(i,j),lat_u(i,j), uu, vv)
7672  u(i,j,k) = u1(i,j)*uu + u2(i,j)*vv
7673 
7674  gz_u(i,j) = z
7675  p_u(i,j) = p
7676  peln_u(i,j) = pl
7677  enddo
7678  enddo
7679  enddo
7680 
7681  do j=js,je
7682  do i=is,ie+1
7683  call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7684  lat_v(i,j) = pa(2)
7685  lon_v(i,j) = pa(1)
7686  call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7687  call get_latlon_vector(pa,ex,ey)
7688  v1(i,j) = inner_prod(e2,ex) !v components
7689  v2(i,j) = inner_prod(e2,ey)
7690  rc_v(i,j) = great_circle_dist(pa, ppcenter, radius)
7691  gz_v(i,j) = 0.
7692  p_v(i,j) = pb - dp*exp( - sqrt((rc_v(i,j)/rp)**3) )
7693  peln_v(i,j) = log(p_v(i,j))
7694  ps_v(i,j) = p_v(i,j)
7695  enddo
7696  enddo
7697  do k=npz,1,-1
7698  do j=js,je
7699  do i=is,ie+1
7700  !Pressure (Top of interface)
7701  p = ak(k) + ps_v(i,j)*bk(k)
7702  pl = log(p)
7703  !Height (top of interface); use newton's method
7704  z = gz_v(i,j) !first guess, height of lower level
7705  z0 = z
7706  do iter=1,30
7707  ziter = z
7708  piter = dcmip16_tc_pressure(ziter,rc_v(i,j))
7709  titer = dcmip16_tc_temperature(ziter,rc_v(i,j))
7710  z = ziter + (piter - p)*rdgrav*titer/piter
7711  if (abs(z - ziter) < zconv) exit
7712  enddo
7713  !Now compute winds
7714  call dcmip16_tc_uwind_pert(0.5*(z+z0),rc_v(i,j),lon_v(i,j),lat_v(i,j), uu, vv)
7715  v(i,j,k) = v1(i,j)*uu + v2(i,j)*vv
7716  gz_v(i,j) = z
7717  p_v(i,j) = p
7718  peln_v(i,j) = pl
7719  enddo
7720  enddo
7721  enddo
7722 
7723  !Compute moisture and other tracer fields, as desired
7724  do n=1,nq
7725  do k=1,npz
7726  do j=jsd,jed
7727  do i=isd,ied
7728  q(i,j,k,n) = 0.
7729  enddo
7730  enddo
7731  enddo
7732  enddo
7733  if (.not. adiabatic) then
7734  sphum = get_tracer_index(model_atmos, 'sphum')
7735  do k=1,npz
7736  do j=js,je
7737  do i=is,ie
7738  z = 0.5*(gz(i,j,k) + gz(i,j,k+1))
7739  q(i,j,k,sphum) = dcmip16_tc_sphum(z)
7740  enddo
7741  enddo
7742  enddo
7743  endif
7744 
7745  !Compute nonhydrostatic variables, if needed
7746  if (.not. hydrostatic) then
7747  do k=1,npz
7748  do j=js,je
7749  do i=is,ie
7750  w(i,j,k) = 0.
7751  delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7752  enddo
7753  enddo
7754  enddo
7755  endif
7756 
7757  contains
7758 
7759  !Initialize with virtual temperature
7760  real function dcmip16_tc_temperature(z, r)
7761 
7762  real, intent(IN) :: z, r
7763  real :: tv, term1, term2
7764 
7765  if (z > zt) then
7766  dcmip16_tc_temperature = tvt
7767  return
7768  endif
7769 
7770  tv = tv0 - lapse*z
7771  term1 = grav*zp*zp* ( 1. - pb/dp * exp( sqrt(r/rp)**3 + (z/zp)**2 ) )
7772  term2 = 2*rdgas*tv*z
7773  dcmip16_tc_temperature = tv + tv*( 1./(1 + term2/term1) - 1.)
7774 
7775  end function dcmip16_tc_temperature
7776 
7777  !Initialize with moist air mass
7778  real function dcmip16_tc_pressure(z, r)
7779 
7780  real, intent(IN) :: z, r
7781 
7782  if (z <= zt) then
7783  dcmip16_tc_pressure = pb*exp(grav/(rdgas*lapse) * log( (tv0-lapse*z)/tv0) ) -dp* exp(-sqrt((r/rp)**3) - (z/zp)**2) * &
7784  exp( grav/(rdgas*lapse) * log( (tv0-lapse*z)/tv0) )
7785  else
7786  dcmip16_tc_pressure = ptt*exp(grav*(zt-z)/(rdgas*tvt))
7787  endif
7788 
7789  end function dcmip16_tc_pressure
7790 
7791  subroutine dcmip16_tc_uwind_pert(z,r,lon,lat,uu,vv)
7792 
7793  real, intent(IN) :: z, r
7794  real(kind=R_GRID), intent(IN) :: lon, lat
7795  real, intent(OUT) :: uu, vv
7796  real :: rfac, Tvrd, vt, fr5, d1, d2, d
7797  real(kind=R_GRID) :: dst, pphere(2)
7798 
7799  if (z > zt) then
7800  uu = 0.
7801  vv = 0.
7802  return
7803  endif
7804 
7805  rfac = sqrt(r/rp)**3
7806 
7807  fr5 = 0.5*fc*r
7808  tvrd = (tv0 - lapse*z)*rdgas
7809 
7810  vt = -fr5 + sqrt( fr5**2 - (1.5 * rfac * tvrd) / &
7811  ( 1. + 2*tvrd*z/(grav*zp**2) - pb/dp*exp( rfac + (z/zp)**2) ) )
7812 
7813  d1 = sin(phip)*cos(lat) - cos(phip)*sin(lat)*cos(lon - lamp)
7814  d2 = cos(phip)*sin(lon - lamp)
7815  d = max(1.e-25,sqrt(d1*d1 + d2*d2))
7816 
7817  uu = vt * d1/d
7818  vv = vt * d2/d
7819 
7820  end subroutine dcmip16_tc_uwind_pert
7821 
7822  real function dcmip16_tc_sphum(z)
7823 
7824  real, intent(IN) :: z
7825 
7826  dcmip16_tc_sphum = qt
7827  if (z < zt) then
7828  dcmip16_tc_sphum = q0 * exp(-z/zq1) * exp(-(z/zq2 )**2)
7829  endif
7830 
7831  end function dcmip16_tc_sphum
7832 
7833  end subroutine dcmip16_tc
7834 
7835  subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
7836  gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, &
7837  mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in)
7838 
7839  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
7840  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
7841  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
7842  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
7843  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
7844 
7845  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
7846 
7847  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
7848  real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1)
7849  real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1)
7850  real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je)
7851  real , intent(INOUT) :: pkz(is:ie ,js:je ,npz )
7852  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
7853  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
7854  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
7855  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
7856  real , intent(inout) :: delz(isd:,jsd:,1:)
7857  real , intent(inout) :: ze0(is:,js:,1:)
7858 
7859  real , intent(IN) :: ak(npz+1)
7860  real , intent(IN) :: bk(npz+1)
7861 
7862  integer, intent(IN) :: npx, npy, npz
7863  integer, intent(IN) :: ng, ncnst
7864  integer, intent(IN) :: ndims
7865  integer, intent(IN) :: nregions
7866  integer,target,intent(IN):: tile_in
7867 
7868  real, intent(IN) :: dry_mass
7869  logical, intent(IN) :: mountain
7870  logical, intent(IN) :: moist_phys
7871  logical, intent(IN) :: hybrid_z
7872 
7873  type(fv_grid_type), intent(IN), target :: gridstruct
7874  type(domain2d), intent(IN), target :: domain_in
7875 
7876  real, pointer, dimension(:,:,:) :: agrid, grid
7877  real, pointer, dimension(:,:) :: area, rarea, fc, f0
7878  real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
7879  real, pointer, dimension(:,:,:,:) :: ew, es
7880  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
7881 
7882  logical, pointer :: cubed_sphere, latlon
7883 
7884  type(domain2d), pointer :: domain
7885  integer, pointer :: tile
7886 
7887  logical, pointer :: have_south_pole, have_north_pole
7888 
7889  integer, pointer :: ntiles_g
7890  real, pointer :: acapn, acaps, globalarea
7891 
7892  real(kind=R_GRID) :: p1(2), p2(2)
7893  real :: r, r0
7894  integer :: i,j
7895 
7896  agrid => gridstruct%agrid
7897  grid => gridstruct%grid
7898 
7899  area => gridstruct%area
7900 
7901  dx => gridstruct%dx
7902  dy => gridstruct%dy
7903  dxa => gridstruct%dxa
7904  dya => gridstruct%dya
7905  rdxa => gridstruct%rdxa
7906  rdya => gridstruct%rdya
7907  dxc => gridstruct%dxc
7908  dyc => gridstruct%dyc
7909 
7910  fc => gridstruct%fC
7911  f0 => gridstruct%f0
7912 
7913  ntiles_g => gridstruct%ntiles_g
7914  acapn => gridstruct%acapN
7915  acaps => gridstruct%acapS
7916  globalarea => gridstruct%globalarea
7917 
7918  domain => domain_in
7919  tile => tile_in
7920 
7921  have_south_pole => gridstruct%have_south_pole
7922  have_north_pole => gridstruct%have_north_pole
7923 
7924  do j=jsd,jed+1
7925  do i=isd,ied+1
7926  fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) &
7927  +sin(grid(i,j,2))*cos(alpha) )
7928  enddo
7929  enddo
7930  do j=jsd,jed
7931  do i=isd,ied
7932  f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) &
7933  +sin(agrid(i,j,2))*cos(alpha) )
7934  enddo
7935  enddo
7936 
7937  select case (test_case)
7938  case ( 1 )
7939 
7940  ubar = (2.0*pi*radius)/(12.0*86400.0)
7941  phis = 0.0
7942  r0 = radius/3. !RADIUS radius/3.
7943 !!$ p1(1) = 0.
7944  p1(1) = pi/2. + pi_shift
7945  p1(2) = 0.
7946  do j=jsd,jed
7947  do i=isd,ied
7948  p2(1) = agrid(i,j,1)
7949  p2(2) = agrid(i,j,2)
7950  r = great_circle_dist( p1, p2, radius )
7951  if (r < r0) then
7952  delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(pi*r/r0))
7953  else
7954  delp(i,j,1) = phis(i,j)
7955  endif
7956  enddo
7957  enddo
7958  call init_latlon_winds(ubar, u, v, ua, va, uc, vc, 1, gridstruct)
7959 
7960 
7961 !!$ phis(:,:)=0.
7962 !!$
7963 !!$ u (:,:,:)=10.
7964 !!$ v (:,:,:)=10.
7965 !!$ ua(:,:,:)=10.
7966 !!$ va(:,:,:)=10.
7967 !!$ uc(:,:,:)=10.
7968 !!$ vc(:,:,:)=10.
7969 !!$ pt(:,:,:)=1.
7970 !!$ delp(:,:,:)=0.
7971 !!$
7972 !!$ do j=js,je
7973 !!$ if (j>10 .and. j<15) then
7974 !!$ do i=is,ie
7975 !!$ if (i>10 .and. i<15) then
7976 !!$ delp(i,j,:)=1.
7977 !!$ endif
7978 !!$ enddo
7979 !!$ endif
7980 !!$ enddo
7981 !!$ call mpp_update_domains( delp, domain )
7982 
7983  end select
7984 
7985  nullify(grid)
7986  nullify(agrid)
7987 
7988  nullify(area)
7989 
7990  nullify(fc)
7991  nullify(f0)
7992 
7993  nullify(dx)
7994  nullify(dy)
7995  nullify(dxa)
7996  nullify(dya)
7997  nullify(rdxa)
7998  nullify(rdya)
7999  nullify(dxc)
8000  nullify(dyc)
8001 
8002  nullify(domain)
8003  nullify(tile)
8004 
8005  nullify(have_south_pole)
8006  nullify(have_north_pole)
8007 
8008  nullify(ntiles_g)
8009  nullify(acapn)
8010  nullify(acaps)
8011  nullify(globalarea)
8012 
8013  end subroutine init_latlon
8014 
8015  subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct)
8016 
8017  ! defOnGrid = -1:null_op, 0:All-Grids, 1:C-Grid, 2:D-Grid, 3:A-Grid, 4:A-Grid then Rotate, 5:D-Grid with unit vectors then Rotate
8018 
8019  real, intent(INOUT) :: UBar
8020  real, intent(INOUT) :: u(isd:ied ,jsd:jed+1)
8021  real, intent(INOUT) :: v(isd:ied+1,jsd:jed )
8022  real, intent(INOUT) :: uc(isd:ied+1,jsd:jed )
8023  real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
8024  real, intent(INOUT) :: ua(isd:ied ,jsd:jed )
8025  real, intent(INOUT) :: va(isd:ied ,jsd:jed )
8026  integer, intent(IN) :: defOnGrid
8027  type(fv_grid_type), intent(IN), target :: gridstruct
8028 
8029  real :: p1(2),p2(2),p3(2),p4(2), pt(2)
8030  real :: e1(3), e2(3), ex(3), ey(3)
8031 
8032  real :: dist, r, r0
8033  integer :: i,j,k,n
8034  real :: utmp, vtmp
8035 
8036  real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
8037 
8038  real, dimension(:,:,:), pointer :: grid, agrid
8039  real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc
8040 
8041  grid => gridstruct%grid
8042  agrid=> gridstruct%agrid
8043 
8044  area => gridstruct%area
8045  dx => gridstruct%dx
8046  dy => gridstruct%dy
8047  dxc => gridstruct%dxc
8048  dyc => gridstruct%dyc
8049 
8050  psi(:,:) = 1.e25
8051  psi_b(:,:) = 1.e25
8052  do j=jsd,jed
8053  do i=isd,ied
8054  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
8055  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
8056  enddo
8057  enddo
8058  do j=jsd,jed+1
8059  do i=isd,ied+1
8060  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
8061  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
8062  enddo
8063  enddo
8064 
8065  if ( defongrid == 1 ) then
8066  do j=jsd,jed+1
8067  do i=isd,ied
8068  dist = dx(i,j)
8069  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
8070  if (dist==0) vc(i,j) = 0.
8071  enddo
8072  enddo
8073  do j=jsd,jed
8074  do i=isd,ied+1
8075  dist = dy(i,j)
8076  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
8077  if (dist==0) uc(i,j) = 0.
8078  enddo
8079  enddo
8080 
8081 
8082  do j=js,je
8083  do i=is,ie+1
8084  dist = dxc(i,j)
8085  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
8086  if (dist==0) v(i,j) = 0.
8087  enddo
8088  enddo
8089  do j=js,je+1
8090  do i=is,ie
8091  dist = dyc(i,j)
8092  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
8093  if (dist==0) u(i,j) = 0.
8094  enddo
8095  enddo
8096  endif
8097 
8098  end subroutine init_latlon_winds
8099 
8100  subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, nested, &
8101  u,v, ua,va, uc,vc, gridstruct, domain)
8102 
8103 ! Input
8104  integer, intent(IN) :: im,jm,km
8105  integer, intent(IN) :: ifirst,ilast
8106  integer, intent(IN) :: jfirst,jlast
8107  integer, intent(IN) :: ng
8108  logical, intent(IN) :: nested
8109  type(fv_grid_type), intent(IN), target :: gridstruct
8110  type(domain2d), intent(INOUT) :: domain
8111 
8112  !real , intent(in) :: sinlon(im,jm)
8113  !real , intent(in) :: coslon(im,jm)
8114  !real , intent(in) :: sinl5(im,jm)
8115  !real , intent(in) :: cosl5(im,jm)
8116 
8117 ! Output
8118  ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8119  ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8120  ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8121  ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8122  ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8123  ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8124 
8125  real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8126  real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8127  real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8128  real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8129  real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8130  real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8131 
8132 !--------------------------------------------------------------
8133 ! Local
8134 
8135  real :: sinlon(im,jm)
8136  real :: coslon(im,jm)
8137  real :: sinl5(im,jm)
8138  real :: cosl5(im,jm)
8139 
8140  real :: tmp1(jsd:jed+1)
8141  real :: tmp2(jsd:jed)
8142  real :: tmp3(jsd:jed)
8143 
8144  real mag,mag1,mag2, ang,ang1,ang2
8145  real us, vs, un, vn
8146  integer i, j, k, im2
8147  integer js1g1
8148  integer js2g1
8149  integer js2g2
8150  integer js2gc
8151  integer js2gc1
8152  integer js2gcp1
8153  integer js2gd
8154  integer jn2gc
8155  integer jn1g1
8156  integer jn1g2
8157  integer jn2gd
8158  integer jn2gsp1
8159 
8160  real, pointer, dimension(:,:,:) :: agrid, grid
8161  real, pointer, dimension(:,:) :: area, rarea, fC, f0
8162  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
8163  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
8164  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8165 
8166  logical, pointer :: cubed_sphere, latlon
8167 
8168  logical, pointer :: have_south_pole, have_north_pole
8169 
8170  integer, pointer :: ntiles_g
8171  real, pointer :: acapN, acapS, globalarea
8172 
8173  grid => gridstruct%grid
8174  agrid=> gridstruct%agrid
8175 
8176  area => gridstruct%area
8177  rarea => gridstruct%rarea
8178 
8179  fc => gridstruct%fC
8180  f0 => gridstruct%f0
8181 
8182  ee1 => gridstruct%ee1
8183  ee2 => gridstruct%ee2
8184  ew => gridstruct%ew
8185  es => gridstruct%es
8186  en1 => gridstruct%en1
8187  en2 => gridstruct%en2
8188 
8189  dx => gridstruct%dx
8190  dy => gridstruct%dy
8191  dxa => gridstruct%dxa
8192  dya => gridstruct%dya
8193  rdxa => gridstruct%rdxa
8194  rdya => gridstruct%rdya
8195  dxc => gridstruct%dxc
8196  dyc => gridstruct%dyc
8197 
8198  cubed_sphere => gridstruct%cubed_sphere
8199  latlon => gridstruct%latlon
8200 
8201  have_south_pole => gridstruct%have_south_pole
8202  have_north_pole => gridstruct%have_north_pole
8203 
8204  ntiles_g => gridstruct%ntiles_g
8205  acapn => gridstruct%acapN
8206  acaps => gridstruct%acapS
8207  globalarea => gridstruct%globalarea
8208 
8209  if (cubed_sphere) then
8210 
8211  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng)
8212  if (.not. nested) call fill_corners(ua, va, im, jm, vector=.true., agrid=.true.)
8213  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, nested, domain, nocomm=.true.)
8214  if (.not. nested) call fill_corners(uc, vc, im, jm, vector=.true., cgrid=.true.)
8215 
8216  else ! Lat-Lon
8217 
8218  im2 = im/2
8219 
8220 ! Set loop limits
8221 
8222  js1g1 = jfirst-1
8223  js2g1 = jfirst-1
8224  js2g2 = jfirst-2
8225  js2gc = jfirst-ng
8226  js2gcp1 = jfirst-ng-1
8227  js2gd = jfirst-ng
8228  jn1g1 = jlast+1
8229  jn1g2 = jlast+2
8230  jn2gc = jlast+ng
8231  jn2gd = jlast+ng-1
8232  jn2gsp1 = jlast+ng-1
8233 
8234  if (have_south_pole) then
8235  js1g1 = 1
8236  js2g1 = 2
8237  js2g2 = 2
8238  js2gc = 2
8239  js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2)
8240  js2gd = 2
8241  endif
8242  if (have_north_pole) then
8243  jn1g1 = jm
8244  jn1g2 = jm
8245  jn2gc = jm-1 ! NG latitudes on N (ending at jm-1)
8246  jn2gd = jm-1
8247  jn2gsp1 = jm-1
8248  endif
8249 !
8250 ! Treat the special case of ng = 1
8251 !
8252  if ( ng == 1 .AND. ng > 1 ) THEN
8253  js2gc1 = js2gc
8254  else
8255  js2gc1 = jfirst-ng+1
8256  if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2)
8257  endif
8258 
8259  do k=1,km
8260 
8261  if ((have_south_pole) .or. (have_north_pole)) then
8262 ! Get D-grid V-wind at the poles.
8263  call vpol5(u(1:im,:), v(1:im,:), im, jm, &
8264  coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast )
8265  call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:))
8266  endif
8267 
8268  call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng)
8269  if (.not. nested) call fill_corners(ua, va, im, jm, vector=.true., agrid=.true.)
8270 
8271  if ( have_south_pole ) then
8272 ! Projection at SP
8273  us = 0.
8274  vs = 0.
8275  do i=1,im2
8276  us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) &
8277  + (va(i,2)-va(i+im2,2))*coslon(i,2)
8278  vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) &
8279  + (va(i+im2,2)-va(i,2))*sinlon(i,2)
8280  enddo
8281  us = us/im
8282  vs = vs/im
8283 ! SP
8284  do i=1,im2
8285  ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1)
8286  va(i,1) = us*coslon(i,1) - vs*sinlon(i,1)
8287  ua(i+im2,1) = -ua(i,1)
8288  va(i+im2,1) = -va(i,1)
8289  enddo
8290  ua(0 ,1) = ua(im,1)
8291  ua(im+1,1) = ua(1 ,1)
8292  va(im+1,1) = va(1 ,1)
8293  endif
8294 
8295  if ( have_north_pole ) then
8296 ! Projection at NP
8297  un = 0.
8298  vn = 0.
8299  j = jm-1
8300  do i=1,im2
8301  un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) &
8302  + (va(i+im2,j)-va(i,j))*coslon(i,j)
8303  vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) &
8304  + (va(i+im2,j)-va(i,j))*sinlon(i,j)
8305  enddo
8306  un = un/im
8307  vn = vn/im
8308 ! NP
8309  do i=1,im2
8310  ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm)
8311  va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm)
8312  ua(i+im2,jm) = -ua(i,jm)
8313  va(i+im2,jm) = -va(i,jm)
8314  enddo
8315  ua(0 ,jm) = ua(im,jm)
8316  ua(im+1,jm) = ua(1 ,jm)
8317  va(im+1,jm) = va(1 ,jm)
8318  endif
8319 
8320  if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:))
8321  if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:))
8322 
8323 ! A -> C
8324  call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, nested, domain, nocomm=.true.)
8325 
8326  enddo ! km loop
8327 
8328  if (.not. nested) call fill_corners(uc, vc, im, jm, vector=.true., cgrid=.true.)
8329  endif
8330 
8331 
8332  end subroutine d2a2c
8333 
8334  subroutine atob_s(qin, qout, npx, npy, dxa, dya, nested, cubed_sphere, altInterp)
8335  integer, intent(IN) :: npx, npy
8336  real , intent(IN) :: qin(isd:ied ,jsd:jed )
8337  real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1)
8338  integer, OPTIONAL, intent(IN) :: altInterp
8339  logical, intent(IN) :: nested, cubed_sphere
8340  real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8341 
8342  integer :: i,j,n
8343 
8344  real :: tmp1j(jsd:jed+1)
8345  real :: tmp2j(jsd:jed+1)
8346  real :: tmp3j(jsd:jed+1)
8347  real :: tmp1i(isd:ied+1)
8348  real :: tmp2i(isd:ied+1)
8349  real :: tmp3i(isd:ied+1)
8350  real :: tmpq(isd:ied ,jsd:jed )
8351  real :: tmpq1(isd:ied+1,jsd:jed+1)
8352  real :: tmpq2(isd:ied+1,jsd:jed+1)
8353 
8354  if (present(altinterp)) then
8355 
8356  tmpq(:,:) = qin(:,:)
8357 
8358  if (.not. nested) call fill_corners(tmpq , npx, npy, fill=xdir, agrid=.true.)
8359 ! ATOC
8360  do j=jsd,jed
8361  call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altinterp)
8362  enddo
8363 
8364  if (.not. nested) call fill_corners(tmpq , npx, npy, fill=ydir, agrid=.true.)
8365 ! ATOD
8366  do i=isd,ied
8367  tmp1j(jsd:jed) = 0.0
8368  tmp2j(jsd:jed) = tmpq(i,jsd:jed)
8369  tmp3j(jsd:jed) = dya(i,jsd:jed)
8370  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altinterp)
8371  tmpq2(i,jsd:jed) = tmp1j(jsd:jed)
8372  enddo
8373 
8374 ! CTOB
8375  do i=isd,ied
8376  tmp1j(:) = tmpq1(i,:)
8377  tmp2j(:) = tmpq1(i,:)
8378  tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8379  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altinterp)
8380  tmpq1(i,:) = tmp1j(:)
8381  enddo
8382 
8383 ! DTOB
8384  do j=jsd,jed
8385  tmp1i(:) = tmpq2(:,j)
8386  tmp2i(:) = tmpq2(:,j)
8387  tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8388  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altinterp)
8389  tmpq2(:,j) = tmp1i(:)
8390  enddo
8391 
8392 ! Average
8393  do j=jsd,jed+1
8394  do i=isd,ied+1
8395  qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j))
8396  enddo
8397  enddo
8398 
8399 ! Fix Corners
8400  if (cubed_sphere .and. .not. nested) then
8401  i=1
8402  j=1
8403  if ( (is==i) .and. (js==j) ) then
8404  qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8405  endif
8406 
8407  i=npx
8408  j=1
8409  if ( (ie+1==i) .and. (js==j) ) then
8410  qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8411  endif
8412 
8413  i=1
8414  j=npy
8415  if ( (is==i) .and. (je+1==j) ) then
8416  qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8417  endif
8418 
8419  i=npx
8420  j=npy
8421  if ( (ie+1==i) .and. (je+1==j) ) then
8422  qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8423  endif
8424  endif
8425 
8426  else ! altInterp
8427 
8428  do j=js,je+1
8429  do i=is,ie+1
8430  qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + &
8431  qin(i ,j) + qin(i ,j-1))
8432  enddo
8433  enddo
8434 
8435  if (.not. nested) then
8436  i=1
8437  j=1
8438  if ( (is==i) .and. (js==j) ) then
8439  qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8440  endif
8441 
8442  i=npx
8443  j=1
8444  if ( (ie+1==i) .and. (js==j) ) then
8445  qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8446  endif
8447 
8448  i=1
8449  j=npy
8450  if ( (is==i) .and. (je+1==j) ) then
8451  qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8452  endif
8453 
8454  i=npx
8455  j=npy
8456  if ( (ie+1==i) .and. (je+1==j) ) then
8457  qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8458  endif
8459  endif !not nested
8460 
8461  endif ! altInterp
8462 
8463  end subroutine atob_s
8464 !
8465 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8466 !-------------------------------------------------------------------------------
8467 
8468 !-------------------------------------------------------------------------------
8469 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8470  subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, domain)
8471  integer, intent(IN) :: npx, npy, ng
8472  real , intent(IN) :: uin(isd:ied ,jsd:jed )
8473  real , intent(IN) :: vin(isd:ied ,jsd:jed )
8474  real , intent(OUT) :: uout(isd:ied ,jsd:jed+1)
8475  real , intent(OUT) :: vout(isd:ied+1,jsd:jed )
8476  logical, intent(IN) :: nested
8477  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8478  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc
8479  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc
8480  type(domain2d), intent(INOUT) :: domain
8481 
8482  integer :: i,j
8483  real :: tmp1i(isd:ied+1)
8484  real :: tmp2i(isd:ied)
8485  real :: tmp3i(isd:ied)
8486  real :: tmp1j(jsd:jed+1)
8487  real :: tmp2j(jsd:jed)
8488  real :: tmp3j(jsd:jed)
8489 
8490  do j=jsd+1,jed
8491  tmp1i(:) = 0.0
8492  tmp2i(:) = vin(:,j)*dxa(:,j)
8493  tmp3i(:) = dxa(:,j)
8494  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interporder)
8495  vout(:,j) = tmp1i(:)/dxc(:,j)
8496  enddo
8497  do i=isd+1,ied
8498  tmp1j(:) = 0.0
8499  tmp2j(:) = uin(i,:)*dya(i,:)
8500  tmp3j(:) = dya(i,:)
8501  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8502  uout(i,:) = tmp1j(:)/dyc(i,:)
8503  enddo
8504  call mp_update_dwinds(uout, vout, npx, npy, domain)
8505  if (.not. nested) call fill_corners(uout, vout, npx, npy, vector=.true., dgrid=.true.)
8506  end subroutine atod
8507 !
8508 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8509 !-------------------------------------------------------------------------------
8510 
8511 !-------------------------------------------------------------------------------
8512 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8513  subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng)
8514  integer, intent(IN) :: npx, npy, ng
8515  real , intent(IN) :: uin(isd:ied ,jsd:jed+1)
8516  real , intent(IN) :: vin(isd:ied+1,jsd:jed )
8517  real , intent(OUT) :: uout(isd:ied ,jsd:jed )
8518  real , intent(OUT) :: vout(isd:ied ,jsd:jed )
8519  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx, dyc
8520  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy, dxc
8521  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8522 
8523  integer :: i,j,n
8524 
8525  real :: tmp1i(isd:ied+1)
8526  real :: tmp2i(isd:ied+1)
8527  real :: tmp3i(isd:ied+1)
8528  real :: tmp1j(jsd:jed+1)
8529  real :: tmp2j(jsd:jed+1)
8530  real :: tmp3j(jsd:jed+1)
8531 
8532 !CLEANUP: replace dxa with rdxa, and dya with rdya; may change numbers.
8533 #ifdef VORT_ON
8534 ! circulation (therefore, vort) conserving:
8535  do j=jsd,jed
8536  do i=isd,ied
8537  uout(i,j) = 0.5*(uin(i,j)*dx(i,j)+uin(i,j+1)*dx(i,j+1))/dxa(i,j)
8538  vout(i,j) = 0.5*(vin(i,j)*dy(i,j)+vin(i+1,j)*dy(i+1,j))/dya(i,j)
8539  enddo
8540  enddo
8541 #else
8542  do i=isd,ied
8543  tmp1j(:) = 0.0
8544  tmp2j(:) = uin(i,:)*dyc(i,:)
8545  tmp3j(:) = dyc(i,:)
8546  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interporder)
8547  uout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dya(i,jsd:jed)
8548  enddo
8549  do j=jsd,jed
8550  tmp1i(:) = 0.0
8551  tmp2i(:) = vin(:,j)*dxc(:,j)
8552  tmp3i(:) = dxc(:,j)
8553  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interporder)
8554  vout(isd:ied,j) = tmp1i(isd+1:ied+1)/dxa(isd:ied,j)
8555  enddo
8556 #endif
8557 
8558  end subroutine dtoa
8559 !
8560 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8561 !-------------------------------------------------------------------------------
8562 
8563 !-------------------------------------------------------------------------------
8564 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8565  subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, domain, noComm)
8566  integer, intent(IN) :: npx, npy, ng
8567  real , intent(IN) :: uin(isd:ied ,jsd:jed )
8568  real , intent(IN) :: vin(isd:ied ,jsd:jed )
8569  real , intent(OUT) :: uout(isd:ied+1,jsd:jed )
8570  real , intent(OUT) :: vout(isd:ied ,jsd:jed+1)
8571  logical, intent(IN) :: nested
8572  logical, OPTIONAL, intent(IN) :: noComm
8573  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx
8574  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy
8575  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8576  type(domain2d), intent(INOUT) :: domain
8577 
8578  real :: ang1
8579  integer :: i,j,n
8580 
8581  real :: tmp1i(isd:ied+1)
8582  real :: tmp2i(isd:ied)
8583  real :: tmp3i(isd:ied)
8584  real :: tmp1j(jsd:jed+1)
8585  real :: tmp2j(jsd:jed)
8586  real :: tmp3j(jsd:jed)
8587 
8588 #if !defined(ALT_INTERP)
8589 #ifdef VORT_ON
8590 ! Circulation conserving
8591  do j=jsd,jed
8592  do i=isd+1,ied
8593  uout(i,j) = ( uin(i,j)*dxa(i,j) + uin(i-1,j)*dxa(i-1,j) ) &
8594  / ( dxa(i,j) + dxa(i-1,j) )
8595  enddo
8596  enddo
8597  do j=jsd+1,jed
8598  do i=isd,ied
8599  vout(i,j) = ( vin(i,j)*dya(i,j) + vin(i,j-1)*dya(i,j-1) ) &
8600  / ( dya(i,j) + dya(i,j-1) )
8601  enddo
8602  enddo
8603 #else
8604  do j=jsd,jed
8605  call interp_left_edge_1d(uout(:,j), uin(:,j), dxa(:,j), isd, ied, interporder)
8606  enddo
8607  do i=isd,ied
8608 !!$ tmp1j(:) = vout(i,:)
8609  tmp2j(:) = vin(i,:)
8610  tmp3j(:) = dya(i,:)
8611  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8612  vout(i,:) = tmp1j(:)
8613  enddo
8614 #endif
8615 #else
8616 
8617  do j=jsd,jed
8618 !!$ tmp1i(:) = uout(:,j)
8619  tmp2i(:) = uin(:,j)*dya(:,j)
8620  tmp3i(:) = dxa(:,j)
8621  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interporder)
8622  uout(:,j) = tmp1i(:)/dy(:,j)
8623  enddo
8624  do i=isd,ied
8625 !!$ tmp1j(:) = vout(i,:)
8626  tmp2j(:) = vin(i,:)*dxa(i,:)
8627  tmp3j(:) = dya(i,:)
8628  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8629  vout(i,:) = tmp1j(:)/dx(i,:)
8630  enddo
8631 
8632  if (cubed_sphere .and. .not. nested) then
8633  csfac = cos(30.0*pi/180.0)
8634  ! apply Corner scale factor for interp on Cubed-Sphere
8635  if ( (is==1) .and. (js==1) ) then
8636  i=1
8637  j=1
8638  uout(i,j)=uout(i,j)*csfac
8639  uout(i,j-1)=uout(i,j-1)*csfac
8640  vout(i,j)=vout(i,j)*csfac
8641  vout(i-1,j)=vout(i-1,j)*csfac
8642  endif
8643  if ( (is==1) .and. (je==npy-1) ) then
8644  i=1
8645  j=npy-1
8646  uout(i,j)=uout(i,j)*csfac
8647  uout(i,j+1)=uout(i,j+1)*csfac
8648  vout(i,j+1)=vout(i,j+1)*csfac
8649  vout(i-1,j+1)=vout(i-1,j+1)*csfac
8650  endif
8651  if ( (ie==npx-1) .and. (je==npy-1) ) then
8652  i=npx-1
8653  j=npy-1
8654  uout(i+1,j)=uout(i+1,j)*csfac
8655  uout(i+1,j+1)=uout(i+1,j+1)*csfac
8656  vout(i,j+1)=vout(i,j+1)*csfac
8657  vout(i+1,j+1)=vout(i+1,j+1)*csfac
8658  endif
8659  if ( (ie==npx-1) .and. (js==1) ) then
8660  i=npx-1
8661  j=1
8662  uout(i+1,j)=uout(i+1,j)*csfac
8663  uout(i+1,j-1)=uout(i+1,j-1)*csfac
8664  vout(i,j)=vout(i,j)*csfac
8665  vout(i+1,j)=vout(i+1,j)*csfac
8666  endif
8667  endif
8668 
8669 #endif
8670 
8671  if (present(nocomm)) then
8672  if (.not. nocomm) call mpp_update_domains( uout,vout, domain, gridtype=cgrid_ne_param, complete=.true.)
8673  else
8674  call mpp_update_domains( uout,vout, domain, gridtype=cgrid_ne_param, complete=.true.)
8675  endif
8676  if (.not. nested) call fill_corners(uout, vout, npx, npy, vector=.true., cgrid=.true.)
8677 
8678  end subroutine atoc
8679 !
8680 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8681 !-------------------------------------------------------------------------------
8682 
8683 !-------------------------------------------------------------------------------
8684 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8685  subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng)
8686  integer, intent(IN) :: npx, npy, ng
8687  real , intent(IN) :: uin(isd:ied+1,jsd:jed )
8688  real , intent(IN) :: vin(isd:ied ,jsd:jed+1)
8689  real , intent(OUT) :: uout(isd:ied ,jsd:jed )
8690  real , intent(OUT) :: vout(isd:ied ,jsd:jed )
8691  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc, dy
8692  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc, dx
8693  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8694 
8695  integer :: i,j
8696 
8697  real :: tmp1i(isd:ied+1)
8698  real :: tmp2i(isd:ied+1)
8699  real :: tmp3i(isd:ied+1)
8700  real :: tmp1j(jsd:jed+1)
8701  real :: tmp2j(jsd:jed+1)
8702  real :: tmp3j(jsd:jed+1)
8703 
8704  ! do j=jsd,jed
8705  ! do i=isd,ied
8706  ! uout(i,j) = 0.5 * (uin(i,j)*dy(i,j) + uin(i+1,j)*dy(i+1,j))/dya(i,j)
8707  ! enddo
8708  ! enddo
8709  ! do j=jsd,jed
8710  ! do i=isd,ied
8711  ! vout(i,j) = 0.5 * (vin(i,j)*dx(i,j) + vin(i,j+1)*dx(i,j+1))/dxa(i,j)
8712  ! enddo
8713  ! enddo
8714  do i=isd,ied
8715  tmp1j(:) = 0.0
8716  tmp2j(:) = vin(i,:)*dx(i,:)
8717  tmp3j(:) = dyc(i,:)
8718  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interporder)
8719  vout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dxa(i,jsd:jed)
8720  enddo
8721  do j=jsd,jed
8722  tmp1i(:) = 0.0
8723  tmp2i(:) = uin(:,j)*dy(:,j)
8724  tmp3i(:) = dxc(:,j)
8725  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interporder)
8726  uout(isd:ied,j) = tmp1i(isd+1:ied+1)/dya(isd:ied,j)
8727  enddo
8728 
8729  end subroutine ctoa
8730 !
8731 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8732 !-------------------------------------------------------------------------------
8733 
8734 !-------------------------------------------------------------------------------
8735 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8736  subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
8737  integer, intent(IN) :: ndims
8738  real , intent(INOUT) :: myU
8739  real , intent(INOUT) :: myV
8740  real(kind=R_GRID) , intent(IN) :: p1(ndims) ! p4
8741  real(kind=R_GRID) , intent(IN) :: p2(ndims) !
8742  real(kind=R_GRID) , intent(IN) :: p3(ndims) ! p1 t1 p3
8743  real(kind=R_GRID) , intent(IN) :: p4(ndims) !
8744  real(kind=R_GRID) , intent(IN) :: t1(ndims) ! p2
8745  integer, intent(IN) :: dir
8746 
8747  real(kind=R_GRID) :: ee1(3), ee2(3), ee3(3), elon(3), elat(3)
8748 
8749  real :: g11, g12, g21, g22
8750 
8751  real :: newu, newv
8752 
8753  call get_unit_vector(p3, t1, p1, ee1)
8754  call get_unit_vector(p4, t1, p2, ee2)
8755  elon(1) = -sin(t1(1) - pi)
8756  elon(2) = cos(t1(1) - pi)
8757  elon(3) = 0.0
8758  elat(1) = -sin(t1(2))*cos(t1(1) - pi)
8759  elat(2) = -sin(t1(2))*sin(t1(1) - pi)
8760  elat(3) = cos(t1(2))
8761 
8762  g11 = inner_prod(ee1,elon)
8763  g12 = inner_prod(ee1,elat)
8764  g21 = inner_prod(ee2,elon)
8765  g22 = inner_prod(ee2,elat)
8766 
8767  if (dir == 1) then ! Sphere to Cube Rotation
8768  newu = myu*g11 + myv*g12
8769  newv = myu*g21 + myv*g22
8770  else
8771  newu = ( myu*g22 - myv*g12)/(g11*g22 - g21*g12)
8772  newv = (-myu*g21 + myv*g11)/(g11*g22 - g21*g12)
8773  endif
8774  myu = newu
8775  myv = newv
8776 
8777  end subroutine rotate_winds
8778 
8779  subroutine mp_update_dwinds_2d(u, v, npx, npy, domain)
8780  use mpp_parameter_mod, only: dgrid_ne
8781  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1)
8782  real , intent(INOUT) :: v(isd:ied+1,jsd:jed )
8783  integer, intent(IN) :: npx, npy
8784  type(domain2d), intent(INOUT) :: domain
8785 
8786  call mpp_update_domains( u, v, domain, gridtype=dgrid_ne, complete=.true.)
8787 ! if (.not. nested) call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.)
8788 
8789  end subroutine mp_update_dwinds_2d
8790 !
8791 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8792 !-------------------------------------------------------------------------------
8793 
8794 !-------------------------------------------------------------------------------
8795 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8796 !
8797  subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain)
8798  use mpp_parameter_mod, only: dgrid_ne
8799  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
8800  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
8801  integer, intent(IN) :: npx, npy, npz
8802  type(domain2d), intent(INOUT) :: domain
8803  integer k
8804 
8805  call mpp_update_domains( u, v, domain, gridtype=dgrid_ne, complete=.true.)
8806 ! do k=1,npz
8807 ! if (.not. nested) call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.)
8808 ! enddo
8809 
8810  end subroutine mp_update_dwinds_3d
8811 
8812 !-------------------------------------------------------------------------------
8813 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8814  real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile) result (gsum)
8815  integer, intent(IN) :: npx, npy
8816  integer, intent(IN) :: ifirst, ilast
8817  integer, intent(IN) :: jfirst, jlast
8818  integer, intent(IN) :: isd, ied
8819  integer, intent(IN) :: jsd, jed, tile
8820  real , intent(IN) :: p(ifirst:ilast,jfirst:jlast)
8821  type(fv_grid_type), intent(IN), target :: gridstruct
8822 
8823  integer :: i,j,k,n
8824  integer :: j1, j2
8825  real :: gsum0
8826  real, allocatable :: p_r8(:,:,:)
8827 
8828  real, pointer, dimension(:,:,:) :: agrid, grid
8829  real, pointer, dimension(:,:) :: area, rarea, fc, f0
8830  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8831 
8832  logical, pointer :: cubed_sphere, latlon
8833 
8834  logical, pointer :: have_south_pole, have_north_pole
8835 
8836  integer, pointer :: ntiles_g
8837  real, pointer :: acapn, acaps, globalarea
8838 
8839  grid => gridstruct%grid
8840  agrid=> gridstruct%agrid
8841 
8842  area => gridstruct%area
8843  rarea => gridstruct%rarea
8844 
8845  fc => gridstruct%fC
8846  f0 => gridstruct%f0
8847 
8848  dx => gridstruct%dx
8849  dy => gridstruct%dy
8850  dxa => gridstruct%dxa
8851  dya => gridstruct%dya
8852  rdxa => gridstruct%rdxa
8853  rdya => gridstruct%rdya
8854  dxc => gridstruct%dxc
8855  dyc => gridstruct%dyc
8856 
8857  cubed_sphere => gridstruct%cubed_sphere
8858  latlon => gridstruct%latlon
8859 
8860  have_south_pole => gridstruct%have_south_pole
8861  have_north_pole => gridstruct%have_north_pole
8862 
8863  ntiles_g => gridstruct%ntiles_g
8864  acapn => gridstruct%acapN
8865  acaps => gridstruct%acapS
8866  globalarea => gridstruct%globalarea
8867 
8868  allocate(p_r8(npx-1,npy-1,ntiles_g))
8869  gsum = 0.
8870 
8871  if (latlon) then
8872  j1 = 2
8873  j2 = npy-2
8874  !!! WARNING: acapS and acapN have NOT been initialized.
8875  gsum = gsum + p(1,1)*acaps
8876  gsum = gsum + p(1,npy-1)*acapn
8877  do j=j1,j2
8878  do i=1,npx-1
8879  gsum = gsum + p(i,j)*cos(agrid(i,j,2))
8880  enddo
8881  enddo
8882  else
8883 
8884  do n=tile,tile
8885  do j=jfirst,jlast
8886  do i=ifirst,ilast
8887  p_r8(i,j,n) = p(i,j)*area(i,j)
8888  enddo
8889  enddo
8890  enddo
8891  call mp_gather(p_r8, ifirst,ilast, jfirst,jlast, npx-1, npy-1, ntiles_g)
8892  if (is_master()) then
8893  do n=1,ntiles_g
8894  do j=1,npy-1
8895  do i=1,npx-1
8896  gsum = gsum + p_r8(i,j,n)
8897  enddo
8898  enddo
8899  enddo
8900  gsum = gsum/globalarea
8901  endif
8902  call mpp_broadcast(gsum, mpp_root_pe())
8903 
8904  endif
8905 
8906  deallocate(p_r8)
8907 
8908  end function globalsum
8909 
8910 
8911  subroutine get_unit_vector( p1, p2, p3, uvect )
8912  real(kind=R_GRID), intent(in):: p1(2), p2(2), p3(2) ! input position unit vectors (spherical coordinates)
8913  real(kind=R_GRID), intent(out):: uvect(3) ! output unit spherical cartesian
8914 ! local
8915  integer :: n
8916  real(kind=R_GRID) :: xyz1(3), xyz2(3), xyz3(3)
8917  real :: dp(3)
8918 
8919  call spherical_to_cartesian(p1(1), p1(2), one, xyz1(1), xyz1(2), xyz1(3))
8920  call spherical_to_cartesian(p2(1), p2(2), one, xyz2(1), xyz2(2), xyz2(3))
8921  call spherical_to_cartesian(p3(1), p3(2), one, xyz3(1), xyz3(2), xyz3(3))
8922  do n=1,3
8923  uvect(n) = xyz3(n)-xyz1(n)
8924  enddo
8925  call project_sphere_v(1, uvect,xyz2)
8926  call normalize_vect(1, uvect)
8927 
8928  end subroutine get_unit_vector
8929 
8930 
8931  subroutine normalize_vect(np, e)
8932 !
8933 ! Make e an unit vector
8934 !
8935  implicit none
8936  integer, intent(in):: np
8937  real(kind=R_GRID), intent(inout):: e(3,np)
8938 ! local:
8939  integer k, n
8940  real pdot
8941 
8942  do n=1,np
8943  pdot = sqrt(e(1,n)**2+e(2,n)**2+e(3,n)**2)
8944  do k=1,3
8945  e(k,n) = e(k,n) / pdot
8946  enddo
8947  enddo
8948 
8949  end subroutine normalize_vect
8950 !------------------------------------------------------------------------------
8951 !BOP
8952 ! !ROUTINE: mp_ghost_ew --- Ghost 4d east/west "lat/lon periodic
8953 !
8954 ! !INTERFACE:
8955  subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
8956  kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
8957 !
8958 ! !INPUT PARAMETERS:
8959  integer, intent(in):: im, jm, km, nq
8960  integer, intent(in):: ifirst, ilast
8961  integer, intent(in):: jfirst, jlast
8962  integer, intent(in):: kfirst, klast
8963  integer, intent(in):: ng_e ! eastern zones to ghost
8964  integer, intent(in):: ng_w ! western zones to ghost
8965  integer, intent(in):: ng_s ! southern zones to ghost
8966  integer, intent(in):: ng_n ! northern zones to ghost
8967  real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
8968  real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq)
8969 !
8970 ! !DESCRIPTION:
8971 !
8972 ! Ghost 4d east/west
8973 !
8974 ! !REVISION HISTORY:
8975 ! 2005.08.22 Putman
8976 !
8977 !EOP
8978 !------------------------------------------------------------------------------
8979 !BOC
8980  integer :: i,j,k,n
8981 
8982  if (present(q)) then
8983  q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = &
8984  q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq)
8985  endif
8986 
8987 ! Assume Periodicity in X-dir and not overlapping
8988  do n=1,nq
8989  do k=kfirst,klast
8990  do j=jfirst-ng_s,jlast+ng_n
8991  do i=1, ng_w
8992  q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n)
8993  enddo
8994  do i=1, ng_e
8995  q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n)
8996  enddo
8997  enddo
8998  enddo
8999  enddo
9000 
9001 !EOC
9002  end subroutine mp_ghost_ew
9003 
9004 
9005 
9006 
9007 
9008 
9009 !-------------------------------------------------------------------------------
9010 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9011  subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
9012  integer, intent(in):: ifirst,ilast
9013  real, intent(out) :: qout(ifirst:)
9014  real, intent(in) :: qin(ifirst:)
9015  real, intent(in) :: dx(ifirst:)
9016  integer, intent(in):: order
9017  integer :: i
9018 
9019  real :: dm(ifirst:ilast),qmax,qmin
9020  real :: r3, da1, da2, a6da, a6, al, ar
9021  real :: qLa, qLb1, qLb2
9022  real :: x
9023 
9024  r3 = 1./3.
9025 
9026  qout(:) = 0.0
9027  if (order==1) then
9028 ! 1st order Uniform linear averaging
9029  do i=ifirst+1,ilast
9030  qout(i) = 0.5 * (qin(i-1) + qin(i))
9031  enddo
9032  elseif (order==2) then
9033 ! Non-Uniform 1st order average
9034  do i=ifirst+1,ilast
9035  qout(i) = (dx(i-1)*qin(i-1) + dx(i)*qin(i))/(dx(i-1)+dx(i))
9036  enddo
9037  elseif (order==3) then
9038 
9039 ! PPM - Uniform
9040  do i=ifirst+1,ilast-1
9041  dm(i) = 0.25*(qin(i+1) - qin(i-1))
9042  enddo
9043 !
9044 ! Applies monotonic slope constraint
9045 !
9046  do i=ifirst+1,ilast-1
9047  qmax = max(qin(i-1),qin(i),qin(i+1)) - qin(i)
9048  qmin = qin(i) - min(qin(i-1),qin(i),qin(i+1))
9049  dm(i) = sign(min(abs(dm(i)),qmin,qmax),dm(i))
9050  enddo
9051 
9052  do i=ifirst+1,ilast-1
9053  qout(i) = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9054  ! al = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9055  ! da1 = dm(i) + dm(i)
9056  ! qout(i) = qin(i) - sign(min(abs(da1),abs(al-qin(i))), da1)
9057  enddo
9058 
9059 ! First order average to fill in end points
9060  qout(ifirst+1) = 0.5 * (qin(ifirst) + qin(ifirst+1))
9061  qout(ilast) = 0.5 * (qin(ilast-1) + qin(ilast))
9062 
9063  elseif (order==4) then
9064 
9065  ! Non-Uniform PPM
9066  do i=ifirst+1,ilast-1
9067  dm(i) = ( (2.*dx(i-1) + dx(i) ) / &
9068  ( dx(i+1) + dx(i) ) ) * ( qin(i+1) - qin(i) ) + &
9069  ( (dx(i) + 2.*dx(i+1)) / &
9070  (dx(i-1) + dx(i) ) ) * ( qin(i) - qin(i-1) )
9071  dm(i) = ( dx(i) / ( dx(i-1) + dx(i) + dx(i+1) ) ) * dm(i)
9072  if ( (qin(i+1)-qin(i))*(qin(i)-qin(i-1)) > 0.) then
9073  dm(i) = sign( min( abs(dm(i)), 2.*abs(qin(i)-qin(i-1)), 2.*abs(qin(i+1)-qin(i)) ) , dm(i) )
9074  else
9075  dm(i) = 0.
9076  endif
9077  enddo
9078 
9079  do i=ifirst+2,ilast-1
9080  qla = ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) - &
9081  ( (dx(i+1) + dx(i)) / (2.*dx(i) + dx(i-1)) )
9082  qla = ( (2.*dx(i) * dx(i-1)) / (dx(i-1) + dx(i)) ) * qla * &
9083  (qin(i) - qin(i-1))
9084  qlb1 = dx(i-1) * ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) * &
9085  dm(i)
9086  qlb2 = dx(i) * ( (dx(i) + dx(i+1)) / (dx(i-1) + 2.*dx(i)) ) * &
9087  dm(i-1)
9088 
9089  qout(i) = 1. / ( dx(i-2) + dx(i-1) + dx(i) + dx(i+1) )
9090  qout(i) = qout(i) * ( qla - qlb1 + qlb2 )
9091  qout(i) = qin(i-1) + ( dx(i-1) / ( dx(i-1) + dx(i) ) ) * (qin(i) - qin(i-1)) + qout(i)
9092  enddo
9093 
9094  elseif (order==5) then
9095 
9096  ! Linear Spline
9097  do i=ifirst+1,ilast-1
9098  x = float(i-(ifirst+1))*float(ilast-ifirst+1-1)/float(ilast-ifirst-1)
9099  qout(i) = qin(ifirst+nint(x)) + (x - nint(x)) * (qin(ifirst+nint(x+1)) - qin(ifirst+nint(x)))
9100  ! if (tile==1) print*, ifirst+NINT(x+1), ifirst+NINT(x), (x - NINT(x))
9101  ! if (tile==1) print*, 0.5*(qin(i-1)+qin(i)), qout(i)
9102  enddo
9103 
9104 !!$ if (tile==1) print*,'x=fltarr(28)'
9105 !!$ do i=ifirst,ilast
9106 !!$ if (tile==1) print*, 'x(',i-ifirst,')=',qin(i)
9107 !!$ enddo
9108 
9109 
9110  call mp_stop
9111  stop
9112 
9113  endif
9114 
9115  end subroutine interp_left_edge_1d
9116 !------------------------------------------------------------------------------
9117 !-----------------------------------------------------------------------
9118  subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, &
9119  ng_d, ng_s, jfirst, jlast)
9120 ! !INPUT PARAMETERS:
9121  integer im
9122  integer jm
9123  integer jfirst
9124  integer jlast
9125  integer, intent(in):: ng_s, ng_d
9126  real, intent(in):: coslon(im,jm), sinlon(im,jm)
9127  real, intent(in):: cosl5(im,jm),sinl5(im,jm)
9128  real, intent(in):: u(im,jfirst-ng_d:jlast+ng_s)
9129 
9130 ! !INPUT/OUTPUT PARAMETERS:
9131  real, intent(inout):: v(im,jfirst-ng_d:jlast+ng_d)
9132 
9133 ! !LOCAL VARIABLES:
9134 
9135  integer i, imh
9136  real uanp(im), uasp(im), vanp(im), vasp(im)
9137  real un, vn, us, vs, r2im
9138 
9139 ! WS 99.05.25 : Replaced conversions of IMR with IM
9140  r2im = 0.5d0/dble(im)
9141  imh = im / 2
9142 
9143 ! WS 990726 : Added condition to decide if poles are on this processor
9144 
9145  if ( jfirst-ng_d <= 1 ) then
9146  do i=1,im
9147  uasp(i) = u(i, 2) + u(i,3)
9148  enddo
9149 
9150  do i=1,im-1
9151  vasp(i) = v(i, 2) + v(i+1,2)
9152  enddo
9153  vasp(im) = v(im,2) + v(1,2)
9154 
9155 ! Projection at SP
9156  us = 0.; vs = 0.
9157 
9158  do i=1,imh
9159  us = us + (uasp(i+imh)-uasp(i))*sinlon(i,1) &
9160  + (vasp(i)-vasp(i+imh))*coslon(i,1)
9161  vs = vs + (uasp(i+imh)-uasp(i))*coslon(i,1) &
9162  + (vasp(i+imh)-vasp(i))*sinlon(i,1)
9163  enddo
9164  us = us*r2im
9165  vs = vs*r2im
9166 
9167 ! get V-wind at SP
9168 
9169  do i=1,imh
9170  v(i, 1) = us*cosl5(i,1) - vs*sinl5(i,1)
9171  v(i+imh,1) = -v(i,1)
9172  enddo
9173 
9174  endif
9175 
9176  if ( jlast+ng_d >= jm ) then
9177 
9178  do i=1,im
9179  uanp(i) = u(i,jm-1) + u(i,jm)
9180  enddo
9181 
9182  do i=1,im-1
9183  vanp(i) = v(i,jm-1) + v(i+1,jm-1)
9184  enddo
9185  vanp(im) = v(im,jm-1) + v(1,jm-1)
9186 
9187 ! Projection at NP
9188 
9189  un = 0.
9190  vn = 0.
9191  do i=1,imh
9192  un = un + (uanp(i+imh)-uanp(i))*sinlon(i,jm) &
9193  + (vanp(i+imh)-vanp(i))*coslon(i,jm)
9194  vn = vn + (uanp(i)-uanp(i+imh))*coslon(i,jm) &
9195  + (vanp(i+imh)-vanp(i))*sinlon(i,jm)
9196  enddo
9197  un = un*r2im
9198  vn = vn*r2im
9199 
9200 ! get V-wind at NP
9201 
9202  do i=1,imh
9203  v(i, jm) = -un*cosl5(i,jm) - vn*sinl5(i,jm)
9204  v(i+imh,jm) = -v(i,jm)
9205  enddo
9206 
9207  endif
9208 
9209  end subroutine vpol5
9210 
9211  subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
9212 ! Single PE version
9213  character(len=*), intent(in):: qname
9214  integer, intent(in):: is, ie, js, je
9215  integer, intent(in):: n_g, km
9216  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
9217  real, intent(in):: fac
9218 
9219  real qmin, qmax
9220  integer i,j,k
9221 
9222  qmin = q(is,js,1)
9223  qmax = qmin
9224 
9225  do k=1,km
9226  do j=js,je
9227  do i=is,ie
9228  if( q(i,j,k) < qmin ) then
9229  qmin = q(i,j,k)
9230  elseif( q(i,j,k) > qmax ) then
9231  qmax = q(i,j,k)
9232  endif
9233  enddo
9234  enddo
9235  enddo
9236 
9237  write(*,*) qname, ' max = ', qmax*fac, ' min = ', qmin*fac
9238 
9239  end subroutine prt_m1
9240 
9241  subroutine var_dz(km, ztop, ze)
9242  integer, intent(in):: km
9243  real, intent(in):: ztop
9244  real, intent(out), dimension(km+1):: ze
9245 ! Local
9246  real, dimension(km):: dz, s_fac
9247  real dz0, sum1
9248  integer k
9249 
9250  s_fac(km ) = 0.25
9251  s_fac(km-1) = 0.30
9252  s_fac(km-2) = 0.50
9253  s_fac(km-3) = 0.70
9254  s_fac(km-4) = 0.90
9255  s_fac(km-5) = 1.
9256  do k=km-6, 5, -1
9257  s_fac(k) = 1.05 * s_fac(k+1)
9258  enddo
9259  s_fac(4) = 1.1*s_fac(5)
9260  s_fac(3) = 1.2*s_fac(4)
9261  s_fac(2) = 1.3*s_fac(3)
9262  s_fac(1) = 1.5*s_fac(2)
9263 
9264  sum1 = 0.
9265  do k=1,km
9266  sum1 = sum1 + s_fac(k)
9267  enddo
9268 
9269  dz0 = ztop / sum1
9270 
9271  do k=1,km
9272  dz(k) = s_fac(k) * dz0
9273  enddo
9274 
9275  ze(km+1) = 0.
9276  do k=km,1,-1
9277  ze(k) = ze(k+1) + dz(k)
9278  enddo
9279 
9280 ! Re-scale dz with the stretched ztop
9281  do k=1,km
9282  dz(k) = dz(k) * (ztop/ze(1))
9283  enddo
9284 
9285  do k=km,1,-1
9286  ze(k) = ze(k+1) + dz(k)
9287  enddo
9288  ze(1) = ztop
9289 
9290  call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 1)
9291 
9292  if ( is_master() ) then
9293  write(*,*) 'var_dz: model top (km)=', ztop*0.001
9294  do k=km,1,-1
9295  dz(k) = ze(k) - ze(k+1)
9296  write(*,*) k, 0.5*(ze(k)+ze(k+1)), 'dz=', dz(k)
9297  enddo
9298  endif
9299 
9300  end subroutine var_dz
9301 
9302  subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
9303  integer, intent(in):: is, ie, js, je, km
9304  integer, intent(in):: ntimes, i, j
9305  real, intent(inout):: ze(is:ie,js:je,km+1)
9306 ! local:
9307  real, parameter:: df = 0.25
9308  real dz(km)
9309  real flux(km+1)
9310  integer k, n, k1, k2
9311 
9312  k2 = km-1
9313  do k=1,km
9314  dz(k) = ze(i,j,k+1) - ze(i,j,k)
9315  enddo
9316 
9317  do n=1,ntimes
9318  k1 = 2 + (ntimes-n)
9319 
9320  flux(k1 ) = 0.
9321  flux(k2+1) = 0.
9322  do k=k1+1,k2
9323  flux(k) = df*(dz(k) - dz(k-1))
9324  enddo
9325 
9326  do k=k1,k2
9327  dz(k) = dz(k) - flux(k) + flux(k+1)
9328  enddo
9329  enddo
9330 
9331  do k=km,1,-1
9332  ze(i,j,k) = ze(i,j,k+1) - dz(k)
9333  enddo
9334 
9335  end subroutine sm1_edge
9336 
9337 
9338 
9339 end module test_cases_mod
test_cases_mod::case9_b
real, dimension(:,:), allocatable case9_b
Definition: test_cases.F90:206
test_cases_mod::ctoa
subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng)
Definition: test_cases.F90:8686
fv_grid_utils_mod::cart_to_latlon
subroutine, public cart_to_latlon(np, q, xs, ys)
Definition: fv_grid_utils.F90:1716
test_cases_mod::gh0
real gh0
Definition: test_cases.F90:203
fv_grid_utils_mod::mid_pt_sphere
subroutine, public mid_pt_sphere(p1, p2, pm)
Definition: fv_grid_utils.F90:1954
test_cases_mod::dcmip16_tc
subroutine dcmip16_tc(delp, pt, u, v, q, w, delz, is, ie, js, je, isd, ied, jsd, jed, npz, nq, ak, bk, ptop, pk, peln, pe, pkz, gz, phis, ps, grid, agrid, hydrostatic, nwat, adiabatic)
Definition: test_cases.F90:7488
test_cases_mod::bubble_do
logical, public bubble_do
Definition: test_cases.F90:174
test_cases_mod::mp_ghost_ew
subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
Definition: test_cases.F90:8957
test_cases_mod::get_case9_b
subroutine get_case9_b(B, agrid)
Definition: test_cases.F90:4131
test_cases_mod::interp_left_edge_1d
subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
Definition: test_cases.F90:9012
fv_diagnostics_mod::qcly0
real, public qcly0
Definition: fv_diagnostics.F90:182
test_cases_mod::init_double_periodic
subroutine, public init_double_periodic(u, v, w, pt, delp, q, phis, ps, pe, peln, pk, pkz, uc, vc, ua, va, ak, bk, gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd)
Definition: test_cases.F90:6072
test_cases_mod::ubar
real ubar
Definition: test_cases.F90:201
test_cases_mod::init_case
subroutine, public init_case(u, v, w, pt, delp, q, phis, ps, pe, peln, pk, pkz, uc, vc, ua, va, ak, bk, gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, adiabatic, ks, npx_global, ptop, domain_in, tile_in, bd)
Definition: test_cases.F90:541
fv_mp_mod
The module &#39;fv_mp_mod&#39; is a single program multiple data (SPMD) parallel decompostion/communication m...
Definition: fv_mp_mod.F90:24
test_cases_mod::interporder
integer, parameter interporder
Definition: test_cases.F90:223
test_cases_mod::theta_d
integer theta_d
Definition: test_cases.F90:170
test_cases_mod::get_vorticity
subroutine get_vorticity(isc, iec, jsc, jec, isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
Definition: test_cases.F90:3820
test_cases_mod::get_vector_stats
subroutine get_vector_stats(varU, varUT, varV, varVT, npx, npy, ndims, nregions, vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
Definition: test_cases.F90:5104
fv_arrays_mod::fv_grid_type
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
test_cases_mod::radius
real(kind=r_grid), parameter radius
Definition: test_cases.F90:171
fv_eta_mod::hybrid_z_dz
subroutine, public hybrid_z_dz(km, dz, ztop, s_rate)
Definition: fv_eta.F90:2523
test_cases_mod::tvort_orig
real tvort_orig
enstrophy (integral of total vorticity)
Definition: test_cases.F90:220
test_cases_mod::get_stats
subroutine, public get_stats(dt, dtout, nt, maxnt, ndays, u, v, pt, delp, q, phis, ps, uc, vc, ua, va, npx, npy, npz, ncnst, ndims, nregions, gridstruct, stats_lun, consv_lun, monitorFreq, tile, domain, nested)
Definition: test_cases.F90:4535
fv_arrays_mod::fv_grid_bounds_type
Definition: fv_arrays.F90:1137
test_cases_mod
Definition: test_cases.F90:22
fv_grid_tools_mod::missing
real(kind=r_grid), parameter, public missing
Definition: fv_grid_tools.F90:161
test_cases_mod::sm1_edge
subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
Definition: test_cases.F90:9303
test_cases_mod::p0_c0
real p0_c0
Definition: test_cases.F90:180
test_cases_mod::lats_table
real, dimension(:), allocatable lats_table
Definition: test_cases.F90:215
test_cases_mod::atoc
subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, domain, noComm)
Definition: test_cases.F90:8566
test_cases_mod::pi_shift
real, parameter pi_shift
3.0*pi/4.
Definition: test_cases.F90:186
test_cases_mod::mp_update_dwinds_3d
subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain)
Definition: test_cases.F90:8798
test_cases_mod::mp_update_dwinds
Definition: test_cases.F90:235
fv_diagnostics_mod::eqv_pot
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.
Definition: fv_diagnostics.F90:4594
fv_eta_mod::set_hybrid_z
subroutine, public set_hybrid_z(is, ie, js, je, ng, km, ztop, dz, rgrav, hs, ze, dz3)
Definition: fv_eta.F90:2840
test_cases_mod::superk_u
subroutine superk_u(km, zz, um, dudz)
Definition: test_cases.F90:7077
dcmip16_bc_uwind
real function dcmip16_bc_uwind(z, T, lat)
Definition: test_cases.F90:7435
test_cases_mod::test_case
integer, public test_case
Definition: test_cases.F90:173
test_cases_mod::normalize_vect
subroutine normalize_vect(np, e)
Definition: test_cases.F90:8932
dcmip16_tc_uwind_pert
subroutine dcmip16_tc_uwind_pert(z, r, lon, lat, uu, vv)
Definition: test_cases.F90:7792
fv_grid_utils_mod::g_sum
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;.
Definition: fv_grid_utils.F90:2902
test_cases_mod::var_dz
subroutine var_dz(km, ztop, ze)
Definition: test_cases.F90:9242
fv_grid_utils_mod::inner_prod
real function, public inner_prod(v1, v2)
Definition: fv_grid_utils.F90:973
test_cases_mod::get_scalar_stats
subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
Definition: test_cases.F90:5015
fv_grid_utils_mod::get_latlon_vector
subroutine, public get_latlon_vector(pp, elon, elat)
Definition: fv_grid_utils.F90:3274
fv_grid_utils_mod::get_unit_vect2
subroutine, public get_unit_vect2(e1, e2, uc)
Definition: fv_grid_utils.F90:1821
test_cases_mod::lon0
real lon0
pi-0.8
Definition: test_cases.F90:183
fv_grid_tools_mod::todeg
real(kind=r_grid), parameter, public todeg
convert to degrees
Definition: fv_grid_tools.F90:159
fv_arrays_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays.F90:35
fv_eta_mod::gw_1d
subroutine, public gw_1d(km, p0, ak, bk, ptop, ztop, pt1)
Definition: fv_eta.F90:3015
fv_sg_mod
The module &#39;fv_sg&#39; performs FV sub-grid mixing.
Definition: fv_sg.F90:54
test_cases_mod::initwindscase2
integer, parameter initwindscase2
Definition: test_cases.F90:191
test_cases_mod::tracer_test
integer, public tracer_test
Definition: test_cases.F90:198
test_cases_mod::u_jet
real function u_jet(lat)
Definition: test_cases.F90:4115
test_cases_mod::terminator_tracers
subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, km, q, delp, ncnst, lon, lat)
Definition: test_cases.F90:3923
test_cases_mod::gh_jet
real function gh_jet(npy, lat_in)
Definition: test_cases.F90:4068
test_cases_mod::atob_s
subroutine atob_s(qin, qout, npx, npy, dxa, dya, nested, cubed_sphere, altInterp)
Definition: test_cases.F90:8335
fv_grid_utils_mod::make_eta_level
subroutine, public make_eta_level(km, pe, area, kks, ak, bk, ptop, domain, bd)
Definition: fv_grid_utils.F90:3105
init_hydro_mod::hydro_eq
subroutine, public hydro_eq(km, is, ie, js, je, ps, hs, drym, delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
The subroutine &#39;hydro_eq&#39; computes a hydrostatically balanced and isothermal basic state from input h...
Definition: init_hydro.F90:330
test_cases_mod::initwindscase6
integer, parameter initwindscase6
Definition: test_cases.F90:193
test_cases_mod::alpha
real, public alpha
Definition: test_cases.F90:175
test_cases_mod::rankine_vortex
subroutine rankine_vortex(ubar, r0, p1, u, v, grid)
Definition: test_cases.F90:3991
test_cases_mod::lat0
real lat0
pi/4.8
Definition: test_cases.F90:182
test_cases_mod::d2a2c
subroutine d2a2c(im, jm, km, ifirst, ilast, jfirst, jlast, ng, nested, u, v, ua, va, uc, vc, gridstruct, domain)
Definition: test_cases.F90:8102
fv_grid_utils_mod::ptop_min
real, parameter, public ptop_min
Definition: fv_grid_utils.F90:109
fv_grid_utils_mod::f_p
integer, parameter, public f_p
Definition: fv_grid_utils.F90:102
fv_diagnostics_mod::ppme
subroutine, public ppme(p, qe, delp, im, km)
Definition: fv_diagnostics.F90:4327
fv_eta_mod::compute_dz_l32
subroutine, public compute_dz_l32(km, ztop, dz)
Definition: fv_eta.F90:2729
test_cases_mod::get_pt_on_great_circle
subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
Definition: test_cases.F90:4979
test_cases_mod::globalsum
real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile)
Definition: test_cases.F90:8815
dcmip16_tc_temperature
real function dcmip16_tc_temperature(z, r)
Definition: test_cases.F90:7761
fv_sg_mod::qsmith
subroutine, public qsmith(im, km, k1, t, p, q, qs, dqdt)
Definition: fv_sg.F90:1320
test_cases_mod::wind_field
integer, public wind_field
Definition: test_cases.F90:198
test_cases_mod::initwindscase9
integer, parameter initwindscase9
Definition: test_cases.F90:194
test_cases_mod::rgamma
real rgamma
Definition: test_cases.F90:181
test_cases_mod::vbar
real vbar
Definition: test_cases.F90:201
test_cases_mod::tmass_orig
real tmass_orig
total mass
Definition: test_cases.F90:219
fv_arrays_mod
The module &#39;fv_arrays&#39; contains the &#39;fv_atmos_type&#39; and associated datatypes.
Definition: fv_arrays.F90:24
fv_grid_utils_mod::great_circle_dist
real function, public great_circle_dist(q1, q2, radius)
Definition: fv_grid_utils.F90:2013
test_cases_mod::sphum
integer sphum
Definition: test_cases.F90:170
test_cases_mod::aoft
real, dimension(2) aoft
Definition: test_cases.F90:207
fv_surf_map_mod
Definition: fv_surf_map.F90:22
test_cases_mod::soliton_umax
real, public soliton_umax
Definition: test_cases.F90:177
test_cases_mod::initwindscase0
integer, parameter initwindscase0
Definition: test_cases.F90:189
test_cases_mod::case9_forcing2
subroutine, public case9_forcing2(phis)
Definition: test_cases.F90:4195
fv_eta_mod
The module &#39;fv_eta&#39; contains routine to set up the reference (Eulerian) pressure coordinate.
Definition: fv_eta.F90:25
dcmip16_bc_sphum
real function dcmip16_bc_sphum(p, ps, lat, lon)
Definition: test_cases.F90:7468
test_cases_mod::pz0
real, dimension(:), allocatable, public pz0
Definition: test_cases.F90:196
test_cases_mod::pmxn
subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
Definition: test_cases.F90:5326
test_cases_mod::init_winds
subroutine init_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, npx, npy, ng, ndims, nregions, nested, gridstruct, domain, tile)
Definition: test_cases.F90:245
test_cases_mod::soliton_size
real, public soliton_size
Definition: test_cases.F90:177
test_cases_mod::nsolitons
integer, public nsolitons
Definition: test_cases.F90:176
test_cases_mod::case51_forcing
subroutine, public case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain)
Definition: test_cases.F90:4213
dcmip16_tc_sphum
real function dcmip16_tc_sphum(z)
Definition: test_cases.F90:7823
fv_grid_utils_mod::project_sphere_v
subroutine, public project_sphere_v(np, f, e)
Definition: fv_grid_utils.F90:3293
test_cases_mod::ua0
real, dimension(:,:,:), allocatable ua0
Validating U-Wind.
Definition: test_cases.F90:212
fv_mp_mod::ng
integer, parameter, public ng
Definition: fv_mp_mod.F90:2716
init_hydro_mod
Definition: init_hydro.F90:23
fv_surf_map_mod::surfdrv
subroutine, public surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_sg, phis, stretch_fac, nested, npx_global, domain, grid_number, bd, regional)
Definition: fv_surf_map.F90:135
test_cases_mod::case9_forcing1
subroutine, public case9_forcing1(phis, time_since_start)
Definition: test_cases.F90:4160
fv_diagnostics_mod
@ The module &#39;fv_diagnostics&#39; contains routines to compute diagnosic fields.
Definition: fv_diagnostics.F90:24
fv_arrays_mod::fv_flags_type
Definition: fv_arrays.F90:245
test_cases_mod::balanced_k
subroutine balanced_k(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, delz, zvir, ptop, ak, bk, agrid)
Definition: test_cases.F90:6923
fv_grid_tools_mod::spherical_to_cartesian
subroutine, public spherical_to_cartesian(lon, lat, r, x, y, z)
Definition: fv_grid_tools.F90:1941
fv_grid_utils_mod
The module &#39;fv_grid_utils&#39; contains routines for setting up and computing grid-related quantities...
Definition: fv_grid_utils.F90:26
test_cases_mod::get_unit_vector
subroutine get_unit_vector(p1, p2, p3, uvect)
Definition: test_cases.F90:8912
fv_diagnostics_mod::prt_maxmin
subroutine, public prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac)
Definition: fv_diagnostics.F90:3210
test_cases_mod::rotate_winds
subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
Definition: test_cases.F90:8737
test_cases_mod::atod
subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, domain)
Definition: test_cases.F90:8471
test_cases_mod::zz0
real, dimension(:), allocatable, public zz0
Definition: test_cases.F90:196
test_cases_mod::init_latlon
subroutine, public init_latlon(u, v, pt, delp, q, phis, ps, pe, peln, pk, pkz, uc, vc, ua, va, ak, bk, gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in)
Definition: test_cases.F90:7838
test_cases_mod::checker_tracers
subroutine, public checker_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, nq, km, q, lon, lat, nx, ny, rn)
Definition: test_cases.F90:3854
dcmip16_bc_uwind_pert
real function dcmip16_bc_uwind_pert(z, lat, lon)
Definition: test_cases.F90:7451
test_cases_mod::prt_m1
subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
Definition: test_cases.F90:9212
fv_grid_tools_mod
Definition: fv_grid_tools.F90:21
test_cases_mod::mp_update_dwinds_2d
subroutine mp_update_dwinds_2d(u, v, npx, npy, domain)
Definition: test_cases.F90:8780
test_cases_mod::va0
real, dimension(:,:,:), allocatable va0
Validating V-Windfms_io_exit, get_tile_string, &.
Definition: test_cases.F90:213
dcmip16_bc_temperature
real function dcmip16_bc_temperature(z, lat)
Definition: test_cases.F90:7402
test_cases_mod::phi0
real, dimension(:,:,:), allocatable phi0
Validating Field.
Definition: test_cases.F90:211
test_cases_mod::init_latlon_winds
subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct)
Definition: test_cases.F90:8016
dcmip16_tc_pressure
real function dcmip16_tc_pressure(z, r)
Definition: test_cases.F90:7779
test_cases_mod::one
real(kind=r_grid), parameter one
Definition: test_cases.F90:172
fv_grid_utils_mod::cubed_to_latlon
subroutine, public cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, mode, grid_type, domain, nested, c2l_ord, bd)
Definition: fv_grid_utils.F90:2346
test_cases_mod::gh_initialized
logical gh_initialized
Definition: test_cases.F90:216
dcmip16_bc_pressure
real function dcmip16_bc_pressure(z, lat)
Definition: test_cases.F90:7419
test_cases_mod::tener_orig
real tener_orig
energy
Definition: test_cases.F90:221
test_cases_mod::dcmip16_bc
subroutine dcmip16_bc(delp, pt, u, v, q, w, delz, is, ie, js, je, isd, ied, jsd, jed, npz, nq, ak, bk, ptop, pk, peln, pe, pkz, gz, phis, ps, grid, agrid, hydrostatic, nwat, adiabatic, do_pert, domain)
Definition: test_cases.F90:7115
test_cases_mod::superk_sounding
subroutine superk_sounding(km, pe, p00, ze, pt, qz)
Definition: test_cases.F90:6793
test_cases_mod::vpol5
subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, ng_d, ng_s, jfirst, jlast)
Definition: test_cases.F90:9120
test_cases_mod::initwindscase1
integer, parameter initwindscase1
Definition: test_cases.F90:190
test_cases_mod::gh_table
real, dimension(:), allocatable gh_table
Definition: test_cases.F90:215
test_cases_mod::dtoa
subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng)
Definition: test_cases.F90:8514
init_hydro_mod::p_var
subroutine, public p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, delp, delz, pt, ps, pe, peln, pk, pkz, cappa, q, ng, nq, area, dry_mass, adjust_dry_mass, mountain, moist_phys, hydrostatic, nwat, domain, make_nh)
the subroutine &#39;p_var&#39; computes auxiliary pressure variables for a hydrostatic state.
Definition: init_hydro.F90:87
test_cases_mod::initwindscase5
integer, parameter initwindscase5
Definition: test_cases.F90:192
fv_eta_mod::compute_dz_l101
subroutine, public compute_dz_l101(km, ztop, dz)
Definition: fv_eta.F90:2798
fv_grid_utils_mod::latlon2xyz
subroutine, public latlon2xyz(p, e, id)
The subroutine &#39;latlon2xyz&#39; maps (lon, lat) to (x,y,z)
Definition: fv_grid_utils.F90:1622
test_cases_mod::check_courant_numbers
subroutine, public check_courant_numbers(uc, vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint)
Definition: test_cases.F90:5199