FV3DYCORE  Version 2.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: is_master, &
103  domain_decomp, fill_corners, xdir, ydir, &
104  mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst
105  use fv_grid_utils_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere, &
106  ptop_min, inner_prod, get_latlon_vector, get_unit_vect2, &
107  g_sum, latlon2xyz, cart_to_latlon, make_eta_level, f_p, project_sphere_v
108  use fv_surf_map_mod, only: surfdrv
109 
110  use fv_grid_tools_mod, only: todeg, missing, spherical_to_cartesian
111  use fv_eta_mod, only: compute_dz_l32, compute_dz_l101, set_hybrid_z, gw_1d, &
112  hybrid_z_dz
113 
114  use mpp_mod, only: mpp_error, fatal, mpp_root_pe, mpp_broadcast, mpp_sum
115  use mpp_mod, only: stdlog, input_nml_file
116  use fms_mod, only: check_nml_error, close_file, open_namelist_file
117  use mpp_domains_mod, only: mpp_update_domains, domain2d
118  use mpp_parameter_mod, only: agrid_param=>agrid,cgrid_ne_param=>cgrid_ne, &
119  scalar_pair
120  use fv_sg_mod, only: qsmith
121  use fv_diagnostics_mod, only: prt_maxmin, ppme, eqv_pot, qcly0
122 !!! DEBUG CODE
123  use mpp_mod, only: mpp_pe, mpp_chksum, stdout
124 !!! END DEBUG CODE
125  use fv_arrays_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, r_grid
126  use tracer_manager_mod, only: get_tracer_index
127  use field_manager_mod, only: model_atmos
128  implicit none
129  private
130 
131 !!! A NOTE ON TEST CASES
132 !!! If you have a DRY test case with no physics, be sure to set adiabatic = .TRUE. in your runscript.
133 !!!! This is especially important for nonhydrostatic cases in which delz will be initialized with the
134 !!!! virtual temperature effect.
135 
136 ! Test Case Number (cubed-sphere domain)
137 ! -1 = Divergence conservation test
138 ! 0 = Idealized non-linear deformational flow
139 ! 1 = Cosine Bell advection
140 ! 2 = Zonal geostrophically balanced flow
141 ! 3 = non-rotating potential flow
142 ! 4 = Tropical cyclones (merger of Rankine vortices)
143 ! 5 = Zonal geostrophically balanced flow over an isolated mountain
144 ! 6 = Rossby Wave number 4
145 ! 7 = Barotropic instability
146 ! ! 8 = Potential flow (as in 5 but no rotation and initially at rest)
147 ! 8 = "Soliton" propagation twin-vortex along equator
148 ! 9 = Polar vortex
149 ! 10 = hydrostatically balanced 3D test with idealized mountain
150 ! 11 = Use this for cold starting the climate model with USGS terrain
151 ! 12 = Jablonowski & Williamson Baroclinic test case (Steady State)
152 ! 13 = Jablonowski & Williamson Baroclinic test case Perturbation
153 ! -13 = DCMIP 2016 J&W BC Wave, with perturbation
154 ! 14 = Use this for cold starting the Aqua-planet model
155 ! 15 = Small Earth density current
156 ! 16 = 3D hydrostatic non-rotating Gravity waves
157 ! 17 = 3D hydrostatic rotating Inertial Gravity waves (case 6-3-0)
158 ! 18 = 3D mountain-induced Rossby wave
159 ! 19 = As in 15 but without rotation
160 ! 20 = 3D non-hydrostatic lee vortices; non-rotating (small planet)
161 ! 21 = 3D non-hydrostatic lee vortices; rotating (small planet)
162 ! 30 = Super-Cell storm, curved hodograph, centered at OKC, no rotation
163 ! 31 = Super-Cell storm, curved hodograph, centered at OKC, with rotation
164 ! 32 = Super-Cell storm, straight hodograph, centered at OKC, no rotation
165 ! 33 = HIWPP Schar mountain waves, Ridge mountain (M1)
166 ! 34 = HIWPP Schar mountain waves, Circular mountain (M2)
167 ! 35 = HIWPP Schar mountain waves, Circular mountain with shear (M3)
168 ! 36 = HIWPP Super_Cell; no perturbation
169 ! 37 = HIWPP Super_Cell; with the prescribed thermal
170 ! 44 = Lock-exchange on the sphere; atm at rest with no mountain
171 ! 45 = New test
172 ! 51 = 3D tracer advection (deformational nondivergent flow)
173 ! 55 = TC
174 ! -55 = DCMIP 2016 TC test
175 ! 101 = 3D non-hydrostatic Large-Eddy-Simulation (LES) with hybrid_z IC
176 
177  integer :: sphum, theta_d
178  real(kind=R_GRID), parameter :: radius = cnst_radius
179  real(kind=R_GRID), parameter :: one = 1.d0
180  integer :: test_case = 11
181  logical :: bubble_do = .false.
182  real :: alpha = 0.0
183  integer :: nsolitons = 1
184  real :: soliton_size = 750.e3, soliton_umax = 50.
185 
186 ! Case 0 parameters
187  real :: p0_c0 = 3.0
188  real :: rgamma = 5.0
189  real :: lat0 = pi/2.0
190  real :: lon0 = 0.0
191 
192 ! pi_shift moves the initial location of the cosine bell for Case 1
193  real, parameter :: pi_shift = 0.0
194 
195  ! -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
196  integer, parameter :: initwindscase0 =-1
197  integer, parameter :: initwindscase1 = 1
198  integer, parameter :: initwindscase2 = 5
199  integer, parameter :: initwindscase5 = 5
200  integer, parameter :: initwindscase6 =-1
201  integer, parameter :: initwindscase9 =-1
202 
203  real, allocatable, dimension(:) :: pz0, zz0
204 
205  integer :: tracer_test, wind_field
206 
207  ! Ubar = initial wind speed parameter
208  real :: ubar, vbar
209  ! gh0 = initial surface height parameter
210  real :: gh0
211 
212  ! case 9 parameters
213  real , allocatable :: case9_b(:,:)
214  real :: aoft(2)
215 
216 
217  ! Validating fields used in statistics
218  real , allocatable :: phi0(:,:,:)
219  real , allocatable :: ua0(:,:,:)
220  real , allocatable :: va0(:,:,:)
221 
222  real , allocatable :: gh_table(:), lats_table(:)
223  logical :: gh_initialized = .false.
224 
225  ! Initial Conservation statistics ; total mass ; enstrophy ; energy
226  real :: tmass_orig
227  real :: tvort_orig
228  real :: tener_orig
229 
230  integer, parameter :: interporder = 1
231 
232  public :: pz0, zz0
233  public :: read_namelist_test_case_nml, alpha
234  public :: init_case
235 #ifdef NCDF_OUTPUT
236  public :: output, output_ncdf
237 #endif
238  public :: case9_forcing1, case9_forcing2, case51_forcing
239  public :: init_double_periodic
240  public :: checker_tracers
241 
242  INTERFACE mp_update_dwinds
243  MODULE PROCEDURE mp_update_dwinds_2d
244  MODULE PROCEDURE mp_update_dwinds_3d
245  END INTERFACE
246 
247  contains
248 
249 !-------------------------------------------------------------------------------
250 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
251 !
252 ! init_winds :: initialize the winds
253 !
254  subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions, bounded_domain, gridstruct, domain, tile, bd)
255  ! 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
256 
257  type(fv_grid_bounds_type), intent(IN) :: bd
258  real , intent(INOUT) :: UBar
259  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1)
260  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed )
261  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed )
262  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1)
263  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed )
264  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed )
265  integer, intent(IN) :: defOnGrid
266  integer, intent(IN) :: npx, npy
267  integer, intent(IN) :: ng
268  integer, intent(IN) :: ndims
269  integer, intent(IN) :: nregions
270  logical, intent(IN) :: bounded_domain
271  type(fv_grid_type), intent(IN), target :: gridstruct
272  type(domain2d), intent(INOUT) :: domain
273  integer, intent(IN) :: tile
274 
275  real(kind=R_GRID) :: p1(2), p2(2), p3(2), p4(2), pt(2)
276  real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3)
277 
278  real :: dist, r, r0
279  integer :: i,j,k,n
280  real :: utmp, vtmp
281 
282  real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1), psi(bd%isd:bd%ied,bd%jsd:bd%jed), psi1, psi2
283  integer :: is2, ie2, js2, je2
284 
285  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
286  real, pointer, dimension(:,:) :: area, rarea, fC, f0
287  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
288  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
289  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
290 
291  logical, pointer :: cubed_sphere, latlon
292 
293  logical, pointer :: have_south_pole, have_north_pole
294 
295  integer, pointer :: ntiles_g
296  real, pointer :: acapN, acapS, globalarea
297 
298  integer :: is, ie, js, je
299  integer :: isd, ied, jsd, jed
300 
301  grid => gridstruct%grid_64
302  agrid=> gridstruct%agrid_64
303 
304  area => gridstruct%area
305  rarea => gridstruct%rarea
306 
307  fc => gridstruct%fC
308  f0 => gridstruct%f0
309 
310  ee1 => gridstruct%ee1
311  ee2 => gridstruct%ee2
312  ew => gridstruct%ew
313  es => gridstruct%es
314  en1 => gridstruct%en1
315  en2 => gridstruct%en2
316 
317  dx => gridstruct%dx
318  dy => gridstruct%dy
319  dxa => gridstruct%dxa
320  dya => gridstruct%dya
321  rdxa => gridstruct%rdxa
322  rdya => gridstruct%rdya
323  dxc => gridstruct%dxc
324  dyc => gridstruct%dyc
325 
326  cubed_sphere => gridstruct%cubed_sphere
327  latlon => gridstruct%latlon
328 
329  have_south_pole => gridstruct%have_south_pole
330  have_north_pole => gridstruct%have_north_pole
331 
332  ntiles_g => gridstruct%ntiles_g
333  acapn => gridstruct%acapN
334  acaps => gridstruct%acapS
335  globalarea => gridstruct%globalarea
336 
337  is = bd%is
338  ie = bd%ie
339  js = bd%js
340  je = bd%je
341  isd = bd%isd
342  ied = bd%ied
343  jsd = bd%jsd
344  jed = bd%jed
345 
346  if (bounded_domain) then
347 
348  is2 = is-2
349  ie2 = ie+2
350  js2 = js-2
351  je2 = je+2
352 
353  else
354 
355  is2 = is
356  ie2 = ie
357  js2 = js
358  je2 = je
359 
360  end if
361 
362  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)
363 
364  psi(:,:) = 1.e25
365  psi_b(:,:) = 1.e25
366  do j=jsd,jed
367  do i=isd,ied
368  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
369  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
370  enddo
371  enddo
372  call mpp_update_domains( psi, domain )
373  do j=jsd,jed+1
374  do i=isd,ied+1
375  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
376  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
377  enddo
378  enddo
379 
380  if ( (cubed_sphere) .and. (defongrid==0) ) then
381  do j=js,je+1
382  do i=is,ie
383  dist = dx(i,j)
384  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
385  if (dist==0) vc(i,j) = 0.
386  enddo
387  enddo
388  do j=js,je
389  do i=is,ie+1
390  dist = dy(i,j)
391  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
392  if (dist==0) uc(i,j) = 0.
393  enddo
394  enddo
395  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
396  call fill_corners(uc, vc, npx, npy, vector=.true., cgrid=.true.)
397  do j=js,je
398  do i=is,ie+1
399  dist = dxc(i,j)
400  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
401  if (dist==0) v(i,j) = 0.
402  enddo
403  enddo
404  do j=js,je+1
405  do i=is,ie
406  dist = dyc(i,j)
407  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
408  if (dist==0) u(i,j) = 0.
409  enddo
410  enddo
411  call mp_update_dwinds(u, v, npx, npy, domain, bd)
412  do j=js,je
413  do i=is,ie
414  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
415  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
416  dist = dya(i,j)
417  ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
418  if (dist==0) ua(i,j) = 0.
419  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
420  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
421  dist = dxa(i,j)
422  va(i,j) = (psi2 - psi1) / (dist)
423  if (dist==0) va(i,j) = 0.
424  enddo
425  enddo
426 
427  elseif ( (cubed_sphere) .and. (defongrid==1) ) then
428  do j=js,je+1
429  do i=is,ie
430  dist = dx(i,j)
431  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
432  if (dist==0) vc(i,j) = 0.
433  enddo
434  enddo
435  do j=js,je
436  do i=is,ie+1
437  dist = dy(i,j)
438  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
439  if (dist==0) uc(i,j) = 0.
440  enddo
441  enddo
442  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
443  call fill_corners(uc, vc, npx, npy, vector=.true., cgrid=.true.)
444  call ctoa(uc,vc,ua,va,dx, dy, dxc,dyc,dxa,dya,npx,npy,ng, bd)
445  call atod(ua,va,u ,v ,dxa, dya,dxc,dyc,npx,npy,ng, bounded_domain, domain, bd)
446  ! call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd),v(isd,jsd), &
447  ! ua(isd,jsd),va(isd,jsd), uc(isd,jsd),vc(isd,jsd))
448  elseif ( (cubed_sphere) .and. (defongrid==2) ) then
449  do j=js2,je2
450  do i=is2,ie2+1
451  dist = dxc(i,j)
452  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
453  if (dist==0) v(i,j) = 0.
454  enddo
455  enddo
456  do j=js2,je2+1
457  do i=is2,ie2
458  dist = dyc(i,j)
459  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
460  if (dist==0) u(i,j) = 0.
461  enddo
462  enddo
463  call mp_update_dwinds(u, v, npx, npy, domain, bd)
464  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng, bd)
465  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain, domain, bd)
466  elseif ( (cubed_sphere) .and. (defongrid==3) ) then
467  do j=js,je
468  do i=is,ie
469  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
470  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
471  dist = dya(i,j)
472  ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
473  if (dist==0) ua(i,j) = 0.
474  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
475  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
476  dist = dxa(i,j)
477  va(i,j) = (psi2 - psi1) / (dist)
478  if (dist==0) va(i,j) = 0.
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, bounded_domain, domain, bd)
483  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain,domain, bd)
484  elseif ( (latlon) .or. (defongrid==4) ) then
485 
486  do j=js,je
487  do i=is,ie
488  ua(i,j) = ubar * ( cos(agrid(i,j,2))*cos(alpha) + &
489  sin(agrid(i,j,2))*cos(agrid(i,j,1))*sin(alpha) )
490  va(i,j) = -ubar * sin(agrid(i,j,1))*sin(alpha)
491  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
492  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
493  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
494  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
495  if (cubed_sphere) call rotate_winds(ua(i,j), va(i,j), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
496 
497  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
498  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
499  dist = dya(i,j)
500  if ( (tile==1) .and.(i==1) ) print*, ua(i,j), -1.0 * (psi2 - psi1) / (dist)
501 
502  enddo
503  enddo
504  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
505  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, bounded_domain, domain, bd)
506  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain, domain, bd)
507  elseif ( (latlon) .or. (defongrid==5) ) then
508 ! SJL mods:
509 ! v-wind:
510  do j=js2,je2
511  do i=is2,ie2+1
512  p1(:) = grid(i ,j ,1:2)
513  p2(:) = grid(i,j+1 ,1:2)
514  call mid_pt_sphere(p1, p2, pt)
515  call get_unit_vect2 (p1, p2, e2)
516  call get_latlon_vector(pt, ex, ey)
517  utmp = ubar * ( cos(pt(2))*cos(alpha) + &
518  sin(pt(2))*cos(pt(1))*sin(alpha) )
519  vtmp = -ubar * sin(pt(1))*sin(alpha)
520  v(i,j) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
521  enddo
522  enddo
523 ! D grid u-wind:
524  do j=js2,je2+1
525  do i=is2,ie2
526  p1(:) = grid(i ,j ,1:2)
527  p2(:) = grid(i+1,j ,1:2)
528  call mid_pt_sphere(p1, p2, pt)
529  call get_unit_vect2 (p1, p2, e1)
530  call get_latlon_vector(pt, ex, ey)
531  utmp = ubar * ( cos(pt(2))*cos(alpha) + &
532  sin(pt(2))*cos(pt(1))*sin(alpha) )
533  vtmp = -ubar * sin(pt(1))*sin(alpha)
534  u(i,j) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
535  enddo
536  enddo
537 
538  call mp_update_dwinds(u, v, npx, npy, domain, bd)
539  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng, bd)
540  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, bounded_domain, domain, bd)
541  else
542  !print*, 'Choose an appropriate grid to define the winds on'
543  !stop
544  endif
545 
546  end subroutine init_winds
547 !
548 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
549 !-------------------------------------------------------------------------------
550 
551 !-------------------------------------------------------------------------------
552 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
553 !
554 ! init_case :: initialize the Williamson test cases:
555 ! case 1 (2-D advection of a cosine bell)
556 ! case 2 (Steady State Zonal Geostrophic Flow)
557 ! case 5 (Steady State Zonal Geostrophic Flow over Mountain)
558 ! case 6 (Rossby Wave-4 Case)
559 ! case 9 (Stratospheric Vortex Breaking Case)
560 !
561  subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
562  gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, &
563  dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, adiabatic, &
564  ks, npx_global, ptop, domain_in, tile_in, bd)
565 
566  type(fv_grid_bounds_type), intent(IN) :: bd
567  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
568  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
569  real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
570  real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
571  real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
572  real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
573 
574  real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
575 
576  real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
577  real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
578  real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
579  real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
580  real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
581 
582  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
583  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
584  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
585  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
586  real , intent(inout) :: delz(bd%is:,bd%js:,1:)
587  real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
588 
589  real , intent(inout) :: ak(npz+1)
590  real , intent(inout) :: bk(npz+1)
591 
592  integer, intent(IN) :: npx, npy, npz
593  integer, intent(IN) :: ng, ncnst, nwat
594  integer, intent(IN) :: ndims
595  integer, intent(IN) :: nregions
596 
597  real, intent(IN) :: dry_mass
598  logical, intent(IN) :: mountain
599  logical, intent(IN) :: moist_phys
600  logical, intent(IN) :: hydrostatic
601  logical, intent(IN) :: hybrid_z
602  logical, intent(IN) :: adiabatic
603  integer, intent(IN) :: ks
604 
605  type(fv_grid_type), target :: gridstruct
606  type(fv_flags_type), target, intent(IN) :: flagstruct
607 
608  integer, intent(IN) :: npx_global
609  integer, intent(IN), target :: tile_in
610  real, intent(INOUT) :: ptop
611 
612  type(domain2d), intent(IN), target :: domain_in
613 
614  real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
615  real :: tmp1(1 :npx ,1 :npy ,1:nregions)
616 
617  real(kind=R_GRID) :: p0(2) ! Temporary Point
618  real(kind=R_GRID) :: p1(2) ! Temporary Point
619  real(kind=R_GRID) :: p2(2) ! Temporary Point
620  real(kind=R_GRID) :: p3(2) ! Temporary Point
621  real(kind=R_GRID) :: p4(2) ! Temporary Point
622  real(kind=R_GRID) :: pa(2) ! Temporary Point
623  real(kind=R_GRID) :: pb(2) ! Temporary Point
624  real(kind=R_GRID) :: pcen(2) ! Temporary Point
625  real(kind=R_GRID) :: e1(3), e2(3), e3(3), ex(3), ey(3)
626  real :: dist, r, r1, r2, r0, omg, A, B, C
627  integer :: i,j,k,nreg,z,zz
628  integer :: i0,j0,n0, nt
629  real :: utmp,vtmp,ftmp
630  real :: rk
631 
632  integer, parameter :: jm = 5761
633  real :: ll_phi(jm)
634  real :: ll_u(jm)
635  real :: ll_j(jm)
636  real :: cose(jm)
637  real :: sine(jm)
638  real :: cosp(jm)
639  real :: ddeg, deg, DDP, DP, ph5
640  real :: myB, myC, yy
641  integer :: jj,jm1
642 
643  real :: Vtx, p, w_p
644  real :: x1,y1,z1,x2,y2,z2,ang
645 
646  integer :: initWindsCase
647 
648  real :: dummy
649  real :: ftop
650  real :: v1,v2
651  real :: m=1
652  real :: n=1
653  real :: L1_norm
654  real :: L2_norm
655  real :: Linf_norm
656  real :: pmin, pmin1
657  real :: pmax, pmax1
658  real :: grad(bd%isd:bd%ied ,bd%jsd:bd%jed,2)
659  real :: div0(bd%isd:bd%ied ,bd%jsd:bd%jed )
660  real :: vor0(bd%isd:bd%ied ,bd%jsd:bd%jed )
661  real :: divg(bd%isd:bd%ied ,bd%jsd:bd%jed )
662  real :: vort(bd%isd:bd%ied ,bd%jsd:bd%jed )
663  real :: ztop, rgrav, p00, pturb, zmid, pk0, t00
664  real :: dz1(npz), ppt(npz)
665  real :: ze1(npz+1), pe1(npz+1)
666 
667  integer :: nlon,nlat
668  character(len=80) :: oflnm, hgtflnm
669  integer :: is2, ie2, js2, je2
670 
671  real :: psi(bd%isd:bd%ied,bd%jsd:bd%jed)
672  real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1)
673  real :: psi1, psi2
674 
675 ! Baroclinic Test Case 12
676  real :: eta(npz), eta_0, eta_s, eta_t
677  real :: eta_v(npz), press, anti_rot
678  real :: T_0, T_mean, delta_T, lapse_rate, n2, zeta, s0
679  real :: pt1,pt2,pt3,pt4,pt5,pt6, pt7, pt8, pt9, u1, pt0
680  real :: uu1, uu2, uu3, vv1, vv2, vv3
681 ! real wbuffer(npx+1,npz)
682 ! real sbuffer(npy+1,npz)
683  real wbuffer(npy+2,npz)
684  real sbuffer(npx+2,npz)
685 
686  real :: gz(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1), zt, zdist
687  real :: zvir
688 
689  integer :: Cl, Cl2
690 
691 ! Super-Cell
692  real :: us0 = 30.
693  real, dimension(npz):: pk1, ts1, qs1, uz1, zs1, dudz
694  real:: zm, zc
695  real(kind=R_GRID):: pp0(2) ! center position
696 
697 !Test case 35
698  real:: cs_m3
699 !Test case 51
700  real :: omega0, k_cell, z0, H, px
701  real :: d1, d2, p1p(2), rt, s
702  real :: wind_alpha, period, h0, rm, zp3(3), dz3(3), k0, lp
703 
704 
705 !Test case 55
706  real, dimension(npz+1) :: pe0, gz0, ue, ve, we, pte, qe
707  real :: d, cor, exppr, exppz, gamma, Ts0, q00, exponent, ztrop, height, zp, rp
708  real :: qtrop, ttrop, zq1, zq2
709  real :: dum, dum1, dum2, dum3, dum4, dum5, dum6, ptmp, uetmp, vetmp
710  real :: pe_u(bd%is:bd%ie,npz+1,bd%js:bd%je+1)
711  real :: pe_v(bd%is:bd%ie+1,npz+1,bd%js:bd%je)
712  real :: ps_u(bd%is:bd%ie,bd%js:bd%je+1)
713  real :: ps_v(bd%is:bd%ie+1,bd%js:bd%je)
714 
715 
716  real :: dz, zetam
717 
718  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
719  real(kind=R_GRID), pointer, dimension(:,:) :: area
720  real, pointer, dimension(:,:) :: rarea, fC, f0
721  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
722  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
723  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
724 
725  logical, pointer :: cubed_sphere, latlon
726 
727  type(domain2d), pointer :: domain
728  integer, pointer :: tile
729 
730  logical, pointer :: have_south_pole, have_north_pole
731 
732  integer, pointer :: ntiles_g
733  real, pointer :: acapN, acapS, globalarea
734 
735  integer :: is, ie, js, je
736  integer :: isd, ied, jsd, jed
737 
738  is = bd%is
739  ie = bd%ie
740  js = bd%js
741  je = bd%je
742  isd = bd%isd
743  ied = bd%ied
744  jsd = bd%jsd
745  jed = bd%jed
746 
747  grid => gridstruct%grid_64
748  agrid=> gridstruct%agrid_64
749 
750  area => gridstruct%area_64
751  rarea => gridstruct%rarea
752 
753  fc => gridstruct%fC
754  f0 => gridstruct%f0
755 
756  ee1 => gridstruct%ee1
757  ee2 => gridstruct%ee2
758  ew => gridstruct%ew
759  es => gridstruct%es
760  en1 => gridstruct%en1
761  en2 => gridstruct%en2
762 
763  dx => gridstruct%dx
764  dy => gridstruct%dy
765  dxa => gridstruct%dxa
766  dya => gridstruct%dya
767  rdxa => gridstruct%rdxa
768  rdya => gridstruct%rdya
769  dxc => gridstruct%dxc
770  dyc => gridstruct%dyc
771 
772  cubed_sphere => gridstruct%cubed_sphere
773  latlon => gridstruct%latlon
774 
775  domain => domain_in
776  tile => tile_in
777 
778  have_south_pole => gridstruct%have_south_pole
779  have_north_pole => gridstruct%have_north_pole
780 
781  ntiles_g => gridstruct%ntiles_g
782  acapn => gridstruct%acapN
783  acaps => gridstruct%acapS
784  globalarea => gridstruct%globalarea
785 
786  if (gridstruct%bounded_domain) then
787  is2 = isd
788  ie2 = ied
789  js2 = jsd
790  je2 = jed
791  else
792  is2 = is
793  ie2 = ie
794  js2 = js
795  je2 = je
796  end if
797 
798  pe(:,:,:) = 0.0
799  pt(:,:,:) = 1.0
800  f0(:,:) = huge(dummy)
801  fc(:,:) = huge(dummy)
802  do j=jsd,jed+1
803  do i=isd,ied+1
804  fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
805  sin(grid(i,j,2))*cos(alpha) )
806  enddo
807  enddo
808  do j=jsd,jed
809  do i=isd,ied
810  f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
811  sin(agrid(i,j,2))*cos(alpha) )
812  enddo
813  enddo
814  call mpp_update_domains( f0, domain )
815  if (cubed_sphere) call fill_corners(f0, npx, npy, ydir)
816 
817  delp(isd:is-1,jsd:js-1,1:npz)=0.
818  delp(isd:is-1,je+1:jed,1:npz)=0.
819  delp(ie+1:ied,jsd:js-1,1:npz)=0.
820  delp(ie+1:ied,je+1:jed,1:npz)=0.
821 
822 #if defined(SW_DYNAMICS)
823  select case (test_case)
824  case(-2)
825  case(-1)
826  ubar = (2.0*pi*radius)/(12.0*86400.0)
827  gh0 = 2.94e4
828  phis = 0.0
829  do j=js,je
830  do i=is,ie
831  delp(i,j,1) = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
832  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
833  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
834  enddo
835  enddo
836  call init_winds(ubar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile)
837 
838 ! Test Divergence operator at cell centers
839  do j=js,je
840  do i=is,ie
841  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
842  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
843  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)
844  enddo
845  enddo
846 ! Test Vorticity operator at cell centers
847  do j=js,je
848  do i=is,ie
849  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
850  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
851  enddo
852  enddo
853  div0(:,:) = 1.e-20
854  ! call mpp_update_domains( div0, domain )
855  ! call mpp_update_domains( vor0, domain )
856  ! call mpp_update_domains( divg, domain )
857  ! call mpp_update_domains( vort, domain )
858  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
859  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
860  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)
861  201 format(' ',a,e21.14,' ',e21.14)
862  202 format(' ',a,i4.4,'x',i4.4,'x',i4.4)
863  if ( is_master() ) then
864  write(*,*) ' Error Norms of Analytical Divergence field C-Winds initialized'
865  write(*,201) 'Divergence MAX error : ', pmax
866  write(*,201) 'Divergence MIN error : ', pmin
867  write(*,201) 'Divergence L1_norm : ', l1_norm
868  write(*,201) 'Divergence L2_norm : ', l2_norm
869  write(*,201) 'Divergence Linf_norm : ', linf_norm
870  endif
871 
872  call init_winds(ubar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile, bd)
873 ! Test Divergence operator at cell centers
874  do j=js,je
875  do i=is,ie
876  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
877  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
878  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)
879  enddo
880  enddo
881 ! Test Vorticity operator at cell centers
882  do j=js,je
883  do i=is,ie
884  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
885  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
886  enddo
887  enddo
888  ua0 = ua
889  va0 = va
890  div0(:,:) = 1.e-20
891  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
892  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
893  if ( is_master() ) then
894  write(*,*) ' Error Norms of Analytical Divergence field A-Winds initialized'
895  write(*,201) 'Divergence MAX error : ', pmax
896  write(*,201) 'Divergence MIN error : ', pmin
897  write(*,201) 'Divergence L1_norm : ', l1_norm
898  write(*,201) 'Divergence L2_norm : ', l2_norm
899  write(*,201) 'Divergence Linf_norm : ', linf_norm
900  endif
901 
902  call init_winds(ubar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile, bd)
903  !call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd,1),v(isd,jsd,1), &
904  ! ua(isd,jsd,1),va(isd,jsd,1), uc(isd,jsd,1),vc(isd,jsd,1))
905 ! Test Divergence operator at cell centers
906  do j=js,je
907  do i=is,ie
908  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
909  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
910  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)
911  enddo
912  enddo
913 ! Test Vorticity operator at cell centers
914  do j=js,je
915  do i=is,ie
916  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
917  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
918  enddo
919  enddo
920  div0(:,:) = 1.e-20
921  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
922  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
923  if ( is_master() ) then
924  write(*,*) ' Error Norms of Analytical Divergence field D-Winds initialized'
925  write(*,201) 'Divergence MAX error : ', pmax
926  write(*,201) 'Divergence MIN error : ', pmin
927  write(*,201) 'Divergence L1_norm : ', l1_norm
928  write(*,201) 'Divergence L2_norm : ', l2_norm
929  write(*,201) 'Divergence Linf_norm : ', linf_norm
930  endif
931 
932  call mp_stop()
933  stop
934  case(0)
935  do j=jsd,jed
936  do i=isd,ied
937 
938  x1 = agrid(i,j,1)
939  y1 = agrid(i,j,2)
940  z1 = radius
941 
942  p = p0_c0 * cos(y1)
943  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
944  w_p = 0.0
945  if (p /= 0.0) w_p = vtx/p
946  delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*0.0) )
947  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)))
948  va(i,j,1) = w_p*cos(lat0)*sin(agrid(i,j,1) - lon0)
949  ua(i,j,1) = ua(i,j,1)*radius/86400.0
950  va(i,j,1) = va(i,j,1)*radius/86400.0
951 
952  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
953  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
954  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
955  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
956  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)
957 
958  enddo
959  enddo
960  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
961  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
962  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
963  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
964  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
965  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
966  initwindscase=initwindscase0
967  case(1)
968  ubar = (2.0*pi*radius)/(12.0*86400.0)
969  gh0 = 1.0
970  phis = 0.0
971  r0 = radius/3. !RADIUS radius/3.
972  p1(1) = pi/2. + pi_shift
973  p1(2) = 0.
974  do j=jsd,jed
975  do i=isd,ied
976  p2(1) = agrid(i,j,1)
977  p2(2) = agrid(i,j,2)
978  r = great_circle_dist( p1, p2, radius )
979  if (r < r0) then
980  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
981  else
982  delp(i,j,1) = phis(i,j)
983  endif
984  enddo
985  enddo
986  initwindscase=initwindscase1
987  case(2)
988 #ifdef TEST_TRACER
989 !!$ do j=js2,je2
990 !!$ do i=is2,ie2
991 !!$ q(i,j,1,:) = 1.e-3*cos(agrid(i,j,2))!*(1.+cos(agrid(i,j,1)))
992 !!$ enddo
993 !!$ enddo
994  gh0 = 1.0e-6
995  r0 = radius/3. !RADIUS radius/3.
996  p1(2) = 35./180.*pi !0.
997  p1(1) = pi/4.!pi/2.
998  do j=jsd,jed
999  do i=isd,ied
1000  p2(1) = agrid(i,j,1)
1001  p2(2) = agrid(i,j,2)
1002  r = great_circle_dist( p1, p2, radius )
1003  if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.)) then
1004  !q(i,j,k,1) = max(gh0*0.5*(1.0+cos(PI*r/r0))*exp(real(k-npz)),0.)
1005  q(i,j,1,1) = gh0
1006  else
1007  q(i,j,1,1) = 0.
1008  endif
1009  enddo
1010  enddo
1011 #endif
1012  ubar = (2.0*pi*radius)/(12.0*86400.0)
1013  gh0 = 2.94e4
1014  phis = 0.0
1015  do j=js2,je2
1016  do i=is2,ie2
1017 ! do j=jsd,jed
1018 ! do i=isd,ied
1019 #ifdef FIVE_AVG
1020  pt5 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1021  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1022  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
1023  pt1 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1024  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
1025  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0
1026  pt2 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1027  ( -1.*cos(grid(i+1,j ,1))*cos(grid(i+1,j ,2))*sin(alpha) + &
1028  sin(grid(i+1,j ,2))*cos(alpha) ) ** 2.0
1029  pt3 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1030  ( -1.*cos(grid(i+1,j+1,1))*cos(grid(i+1,j+1,2))*sin(alpha) + &
1031  sin(grid(i+1,j+1,2))*cos(alpha) ) ** 2.0
1032  pt4 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1033  ( -1.*cos(grid(i,j+1,1))*cos(grid(i,j+1,2))*sin(alpha) + &
1034  sin(grid(i,j+1,2))*cos(alpha) ) ** 2.0
1035  delp(i,j,1) = (0.25*(pt1+pt2+pt3+pt4) + 3.*pt5) / 4.
1036 #else
1037  delp(i,j,1) = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1038  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1039  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
1040 #endif
1041  enddo
1042  enddo
1043  initwindscase=initwindscase2
1044  case(3)
1045 !----------------------------
1046 ! Non-rotating potential flow
1047 !----------------------------
1048 #ifdef NO_WIND
1049  ubar = 0.
1050 #else
1051  ubar = 40.
1052 #endif
1053  gh0 = 1.0e3 * grav
1054  phis = 0.0
1055  r0 = radius/3. !RADIUS radius/3.
1056  p1(1) = pi*1.5
1057  p1(2) = 0.
1058  do j=jsd,jed
1059  do i=isd,ied
1060  p2(1) = agrid(i,j,1)
1061  p2(2) = agrid(i,j,2)
1062  r = great_circle_dist( p1, p2, radius )
1063  if (r < r0) then
1064  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
1065  else
1066  delp(i,j,1) = phis(i,j)
1067  endif
1068 ! Add a constant:
1069  delp(i,j,1) = delp(i,j,1) + grav*2.e3
1070  enddo
1071  enddo
1072 
1073 #ifdef NO_WIND
1074  u = 0.; v = 0.
1075  f0 = 0.; fc = 0.
1076 #else
1077 
1078  do j=js,je
1079  do i=is,ie+1
1080  p1(:) = grid(i ,j ,1:2)
1081  p2(:) = grid(i,j+1 ,1:2)
1082  call mid_pt_sphere(p1, p2, p3)
1083  call get_unit_vect2(p1, p2, e2)
1084  call get_latlon_vector(p3, ex, ey)
1085  utmp = ubar * cos(p3(2))
1086  vtmp = 0.
1087  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1088  enddo
1089  enddo
1090  do j=js,je+1
1091  do i=is,ie
1092  p1(:) = grid(i, j,1:2)
1093  p2(:) = grid(i+1,j,1:2)
1094  call mid_pt_sphere(p1, p2, p3)
1095  call get_unit_vect2(p1, p2, e1)
1096  call get_latlon_vector(p3, ex, ey)
1097  utmp = ubar * cos(p3(2))
1098  vtmp = 0.
1099  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1100  enddo
1101  enddo
1102 
1103  anti_rot = -ubar/ radius
1104  do j=jsd,jed+1
1105  do i=isd,ied+1
1106  fc(i,j) = 2.*anti_rot*sin(grid(i,j,2))
1107  enddo
1108  enddo
1109  do j=jsd,jed
1110  do i=isd,ied
1111  f0(i,j) = 2.*anti_rot*sin(agrid(i,j,2))
1112  enddo
1113  enddo
1114 #endif
1115  initwindscase= -1
1116 
1117  case(4)
1118 
1119 !----------------------------
1120 ! Tropical cyclones
1121 !----------------------------
1122 ! f0 = 0.; fC = 0. ! non-rotating planet setup
1123  u = 0.
1124  v = 0.
1125  phis = 0.0 ! flat terrain
1126 
1127  ubar = 50. ! maxmium wind speed (m/s)
1128  r0 = 250.e3 ! RADIUS of the maximum wind of the Rankine vortex
1129  gh0 = grav * 1.e3
1130 
1131  do j=jsd,jed
1132  do i=isd,ied
1133  delp(i,j,1) = gh0
1134  enddo
1135  enddo
1136 
1137 ! ddeg = 2.*r0/radius ! no merger
1138  ddeg = 1.80*r0/radius ! merged
1139 
1140  p1(1) = pi*1.5 - ddeg
1141  p1(2) = pi/18. ! 10 N
1142  call rankine_vortex(ubar, r0, p1, u, v, grid, bd)
1143 
1144  p2(1) = pi*1.5 + ddeg
1145  p2(2) = pi/18. ! 10 N
1146  call rankine_vortex(ubar, r0, p2, u, v, grid, bd)
1147 
1148 #ifndef SINGULAR_VORTEX
1149 !-----------
1150 ! Anti-pole:
1151 !-----------
1152  ubar = -ubar
1153  call latlon2xyz(p1, e1)
1154  do i=1,3
1155  e1(i) = -e1(i)
1156  enddo
1157  call cart_to_latlon(1, e1, p3(1), p3(2))
1158  call rankine_vortex(ubar, r0, p3, u, v, grid, bd)
1159 
1160  call latlon2xyz(p2, e1)
1161  do i=1,3
1162  e1(i) = -e1(i)
1163  enddo
1164  call cart_to_latlon(1, e1, p4(1), p4(2))
1165  call rankine_vortex(ubar, r0, p4, u, v, grid, bd)
1166 #endif
1167  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
1168  initwindscase=-1 ! do nothing
1169 
1170  case(5)
1171 
1172  ubar = 20.
1173  gh0 = 5960.*grav
1174  phis = 0.0
1175  r0 = pi/9.
1176  p1(1) = pi/2.
1177  p1(2) = pi/6.
1178  do j=js2,je2
1179  do i=is2,ie2
1180  p2(1) = agrid(i,j,1)
1181  p2(2) = agrid(i,j,2)
1182  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1183  r = sqrt(r)
1184  phis(i,j) = 2000.0*grav*(1.0-(r/r0))
1185  enddo
1186  enddo
1187  do j=js2,je2
1188  do i=is2,ie2
1189  delp(i,j,1) =gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1190  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1191  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2 - phis(i,j)
1192  enddo
1193  enddo
1194  initwindscase=initwindscase5
1195  case(6)
1196  gh0 = 8.e3*grav
1197  r = 4.
1198  omg = 7.848e-6
1199  rk = 7.848e-6
1200  phis = 0.0
1201  do j=js,je
1202  do i=is,ie
1203  a = 0.5*omg*(2.*omega+omg)*(cos(agrid(i,j,2))**2) + &
1204  0.25*rk*rk*(cos(agrid(i,j,2))**(r+r)) * &
1205  ( (r+1)*(cos(agrid(i,j,2))**2) + (2.*r*r-r-2.) - &
1206  2.*(r*r)*cos(agrid(i,j,2))**(-2.) )
1207  b = (2.*(omega+omg)*rk / ((r+1)*(r+2))) * (cos(agrid(i,j,2))**r) * &
1208  ( (r*r+2.*r+2.) - ((r+1.)*cos(agrid(i,j,2)))**2 )
1209  c = 0.25*rk*rk*(cos(agrid(i,j,2))**(2.*r)) * ( &
1210  (r+1) * (cos(agrid(i,j,2))**2.) - (r+2.) )
1211  delp(i,j,1) =gh0 + radius*radius*(a+b*cos(r*agrid(i,j,1))+c*cos(2.*r*agrid(i,j,1)))
1212  delp(i,j,1) = delp(i,j,1) - phis(i,j)
1213  enddo
1214  enddo
1215  do j=js,je
1216  do i=is,ie+1
1217  p1(:) = grid(i ,j ,1:2)
1218  p2(:) = grid(i,j+1 ,1:2)
1219  call mid_pt_sphere(p1, p2, p3)
1220  call get_unit_vect2(p1, p2, e2)
1221  call get_latlon_vector(p3, ex, ey)
1222  utmp = radius*omg*cos(p3(2)) + &
1223  radius*rk*(cos(p3(2))**(r-1))*(r*sin(p3(2))**2-cos(p3(2))**2)*cos(r*p3(1))
1224  vtmp = -radius*rk*r*sin(p3(2))*sin(r*p3(1))*cos(p3(2))**(r-1)
1225  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1226  enddo
1227  enddo
1228  do j=js,je+1
1229  do i=is,ie
1230  p1(:) = grid(i, j,1:2)
1231  p2(:) = grid(i+1,j,1:2)
1232  call mid_pt_sphere(p1, p2, p3)
1233  call get_unit_vect2(p1, p2, e1)
1234  call get_latlon_vector(p3, ex, ey)
1235  utmp = radius*omg*cos(p3(2)) + &
1236  radius*rk*(cos(p3(2))**(r-1))*(r*sin(p3(2))**2-cos(p3(2))**2)*cos(r*p3(1))
1237  vtmp = -radius*rk*r*sin(p3(2))*sin(r*p3(1))*cos(p3(2))**(r-1)
1238  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1239  enddo
1240  enddo
1241  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
1242  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng,bd)
1243  !call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
1244  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
1245  initwindscase=initwindscase6
1246  case(7)
1247 ! Barotropically unstable jet
1248  gh0 = 10.e3*grav
1249  phis = 0.0
1250  r0 = radius/12.
1251  p2(1) = pi/2.
1252  p2(2) = pi/4.
1253  do j=js,je
1254  do i=is,ie
1255 ! ftmp = gh0
1256 ! 9-point average:
1257 ! 9 4 8
1258 !
1259 ! 5 1 3
1260 !
1261 ! 6 2 7
1262  pt1 = gh_jet(npy, agrid(i,j,2))
1263  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), pa)
1264  pt2 = gh_jet(npy, pa(2))
1265  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), pa)
1266  pt3 = gh_jet(npy, pa(2))
1267  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), pa)
1268  pt4 = gh_jet(npy, pa(2))
1269  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), pa)
1270  pt5 = gh_jet(npy, pa(2))
1271  pt6 = gh_jet(npy, grid(i, j, 2))
1272  pt7 = gh_jet(npy, grid(i+1,j, 2))
1273  pt8 = gh_jet(npy, grid(i+1,j+1,2))
1274  pt9 = gh_jet(npy, grid(i ,j+1,2))
1275  ftmp = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1276 #ifndef NEW_PERT
1277  delp(i,j,1) = ftmp + 120.*grav*cos(agrid(i,j,2)) * &
1278  exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1279 ! phis(i,j) = ftmp
1280 ! delp(i,j,1) = 10.E3*grav + 120.*grav*cos(agrid(i,j,2)) * &
1281 ! exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1282 #else
1283 ! Using great circle dist:
1284  p1(:) = agrid(i,j,1:2)
1285  delp(i,j,1) = ftmp
1286  r = great_circle_dist(p1, p2, radius)
1287  if ( r < 3.*r0 ) then
1288  delp(i,j,1) = delp(i,j,1) + 1000.*grav*exp(-(r/r0)**2)
1289  endif
1290 #endif
1291  enddo
1292  enddo
1293 
1294 ! v-wind:
1295  do j=js,je
1296  do i=is,ie+1
1297  p2(:) = grid(i,j+1,1:2)
1298  vv1 = u_jet(p2(2))*(ee2(2,i,j+1)*cos(p2(1)) - ee2(1,i,j+1)*sin(p2(1)))
1299  p1(:) = grid(i,j,1:2)
1300  vv3 = u_jet(p1(2))*(ee2(2,i,j)*cos(p1(1)) - ee2(1,i,j)*sin(p1(1)))
1301 ! Mid-point:
1302  call mid_pt_sphere(p1, p2, pa)
1303  vv2 = u_jet(pa(2))*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1304 ! 3-point average:
1305  v(i,j,1) = 0.25*(vv1 + 2.*vv2 + vv3)
1306 ! v(i,j,1) = vv2
1307  enddo
1308  enddo
1309 ! U-wind:
1310  do j=js,je+1
1311  do i=is,ie
1312  p1(:) = grid(i,j,1:2)
1313  uu1 = u_jet(p1(2))*(ee1(2,i,j)*cos(p1(1)) - ee1(1,i,j)*sin(p1(1)))
1314  p2(:) = grid(i+1,j,1:2)
1315  uu3 = u_jet(p2(2))*(ee1(2,i+1,j)*cos(p2(1)) - ee1(1,i+1,j)*sin(p2(1)))
1316 ! Mid-point:
1317  call mid_pt_sphere(p1, p2, pa)
1318  uu2 = u_jet(pa(2))*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1319 ! 3-point average:
1320  u(i,j,1) = 0.25*(uu1 + 2.*uu2 + uu3)
1321 ! u(i,j,1) = uu2
1322  enddo
1323  enddo
1324  initwindscase=initwindscase6 ! shouldn't do anything with this
1325 !initialize tracer with shallow-water PV
1326  !Compute vorticity
1327  call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,1), dx, dy, rarea)
1328  do j=jsd,jed+1
1329  do i=isd,ied+1
1330  fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
1331  sin(grid(i,j,2))*cos(alpha) )
1332  enddo
1333  enddo
1334  do j=jsd,jed
1335  do i=isd,ied
1336  f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
1337  sin(agrid(i,j,2))*cos(alpha) )
1338  enddo
1339  enddo
1340  call mpp_update_domains( f0, domain )
1341  if (cubed_sphere) call fill_corners(f0, npx, npy, ydir)
1342  do j=js,je
1343  do i=is,ie
1344  q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) / delp(i,j,npz) * 1.e6 ! PVU
1345  !q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) * grav / delp(i,j,npz)
1346  enddo
1347  enddo
1348 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
1349 
1350  case(8)
1351 #ifdef USE_OLD
1352 !----------------------------
1353 ! Non-rotating potential flow
1354 !----------------------------
1355  gh0 = 5960.*grav
1356  phis = 0.0
1357  r0 = pi/9.
1358  p1(1) = pi/2.
1359  p1(2) = pi/6.
1360  do j=js,je
1361  do i=is,ie
1362  p2(1) = agrid(i,j,1)
1363  p2(2) = agrid(i,j,2)
1364  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1365  r = sqrt(r)
1366  phis(i,j) = 2000.0*grav*(1.0-(r/r0))
1367  enddo
1368  enddo
1369  do j=js,je
1370  do i=is,ie
1371  delp(i,j,1) = gh0
1372  enddo
1373  enddo
1374  u = 0.; v = 0.
1375  f0 = 0.; fc = 0.
1376  initwindscase= -1
1377 #endif
1378 !----------------------------
1379 ! Soliton twin-vortex
1380 !----------------------------
1381  if ( is_master() ) write(*,*) 'Initialzing case-8: soliton twin cycolne...'
1382  f0 = 0.; fc = 0. ! non-rotating planet setup
1383  phis = 0.0 ! flat terrain
1384  gh0 = 5.e3*grav
1385  do j=js,je
1386  do i=is,ie
1387  delp(i,j,1) = gh0
1388  enddo
1389  enddo
1390 
1391 ! Initiate the westerly-wind-burst:
1392  ubar = soliton_umax
1393  r0 = soliton_size
1394 !!$ ubar = 200. ! maxmium wind speed (m/s)
1395 !!$ r0 = 250.e3
1396 !!$ ubar = 50. ! maxmium wind speed (m/s)
1397 !!$ r0 = 750.e3
1398 ! #1 1: westerly
1399  p0(1) = pi*0.5
1400  p0(2) = 0.
1401 
1402  do j=js,je
1403  do i=is,ie+1
1404  p1(:) = grid(i ,j ,1:2)
1405  p2(:) = grid(i,j+1 ,1:2)
1406  call mid_pt_sphere(p1, p2, p3)
1407  r = great_circle_dist( p0, p3, radius )
1408  utmp = ubar*exp(-(r/r0)**2)
1409  call get_unit_vect2(p1, p2, e2)
1410  call get_latlon_vector(p3, ex, ey)
1411  v(i,j,1) = utmp*inner_prod(e2,ex)
1412  enddo
1413  enddo
1414  do j=js,je+1
1415  do i=is,ie
1416  p1(:) = grid(i, j,1:2)
1417  p2(:) = grid(i+1,j,1:2)
1418  call mid_pt_sphere(p1, p2, p3)
1419  r = great_circle_dist( p0, p3, radius )
1420  utmp = ubar*exp(-(r/r0)**2)
1421  call get_unit_vect2(p1, p2, e1)
1422  call get_latlon_vector(p3, ex, ey)
1423  u(i,j,1) = utmp*inner_prod(e1,ex)
1424  enddo
1425  enddo
1426 
1427 ! #1 2: easterly
1428  p0(1) = p0(1) + pi
1429  p0(2) = 0.
1430 
1431  do j=js,je
1432  do i=is,ie+1
1433  p1(:) = grid(i ,j ,1:2)
1434  p2(:) = grid(i,j+1 ,1:2)
1435  call mid_pt_sphere(p1, p2, p3)
1436  r = great_circle_dist( p0, p3, radius )
1437  utmp = ubar*exp(-(r/r0)**2)
1438  call get_unit_vect2(p1, p2, e2)
1439  call get_latlon_vector(p3, ex, ey)
1440  v(i,j,1) = v(i,j,1) - utmp*inner_prod(e2,ex)
1441  enddo
1442  enddo
1443  do j=js,je+1
1444  do i=is,ie
1445  p1(:) = grid(i, j,1:2)
1446  p2(:) = grid(i+1,j,1:2)
1447  call mid_pt_sphere(p1, p2, p3)
1448  r = great_circle_dist( p0, p3, radius )
1449  utmp = ubar*exp(-(r/r0)**2)
1450  call get_unit_vect2(p1, p2, e1)
1451  call get_latlon_vector(p3, ex, ey)
1452  u(i,j,1) = u(i,j,1) - utmp*inner_prod(e1,ex)
1453  enddo
1454  enddo
1455  initwindscase= -1
1456 
1457  case(9)
1458 #ifdef USE_OLD
1459  jm1 = jm - 1
1460  ddp = pi/dble(jm1)
1461  dp = ddp
1462  ll_j(1) = -0.5*pi
1463  do j=2,jm
1464  ph5 = -0.5*pi + (dble(j-1)-0.5)*ddp
1465  ll_j(j) = -0.5*pi + (dble(j-1)*ddp)
1466  sine(j) = sin(ph5)
1467  enddo
1468  cosp( 1) = 0.
1469  cosp(jm) = 0.
1470  do j=2,jm1
1471  cosp(j) = (sine(j+1)-sine(j)) / dp
1472  enddo
1473  do j=2,jm
1474  cose(j) = 0.5 * (cosp(j-1) + cosp(j))
1475  enddo
1476  cose(1) = cose(2)
1477  ddeg = 180./float(jm-1)
1478  do j=2,jm
1479  deg = -90. + (float(j-1)-0.5)*ddeg
1480  if (deg <= 0.) then
1481  ll_u(j) = -10.*(deg+90.)/90.
1482  elseif (deg <= 60.) then
1483  ll_u(j) = -10. + deg
1484  else
1485  ll_u(j) = 50. - (50./30.)* (deg - 60.)
1486  endif
1487  enddo
1488  ll_phi(1) = 6000. * grav
1489  do j=2,jm1
1490  ll_phi(j)=ll_phi(j-1) - dp*sine(j) * &
1491  (radius*2.*omega + ll_u(j)/cose(j))*ll_u(j)
1492  enddo
1493  phis = 0.0
1494  do j=js,je
1495  do i=is,ie
1496  do jj=1,jm1
1497  if ( (ll_j(jj) <= agrid(i,j,2)) .and. (agrid(i,j,2) <= ll_j(jj+1)) ) then
1498  delp(i,j,1)=0.5*(ll_phi(jj)+ll_phi(jj+1))
1499  endif
1500  enddo
1501  enddo
1502  enddo
1503 
1504  do j=js,je
1505  do i=is,ie
1506  if (agrid(i,j,2)*todeg <= 0.0) then
1507  ua(i,j,1) = -10.*(agrid(i,j,2)*todeg + 90.)/90.
1508  elseif (agrid(i,j,2)*todeg <= 60.0) then
1509  ua(i,j,1) = -10. + agrid(i,j,2)*todeg
1510  else
1511  ua(i,j,1) = 50. - (50./30.)* (agrid(i,j,2)*todeg - 60.)
1512  endif
1513  va(i,j,1) = 0.0
1514  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1515  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
1516  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
1517  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
1518  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)
1519  enddo
1520  enddo
1521 
1522  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
1523  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
1524  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
1525  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
1526  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
1527  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
1528  initwindscase=initwindscase9
1529 
1530 
1531  call get_case9_b(case9_b, agrid, isd, ied, jsd, jed)
1532  aoft(:) = 0.0
1533 #else
1534 !----------------------------
1535 ! Soliton twin-vortex
1536 !----------------------------
1537  if ( is_master() ) write(*,*) 'Initialzing case-9: soliton cyclones...'
1538  f0 = 0.; fc = 0. ! non-rotating planet setup
1539  phis = 0.0 ! flat terrain
1540  gh0 = 5.e3*grav
1541  do j=js,je
1542  do i=is,ie
1543  delp(i,j,1) = gh0
1544  enddo
1545  enddo
1546 
1547 ! Initiate the westerly-wind-burst:
1548  ubar = soliton_umax
1549  r0 = soliton_size
1550 !!$ ubar = 200. ! maxmium wind speed (m/s)
1551 !!$ r0 = 250.e3
1552 !!$ ubar = 50. ! maxmium wind speed (m/s)
1553 !!$ r0 = 750.e3
1554  p0(1) = pi*0.5
1555  p0(2) = 0.
1556 
1557  do j=js,je
1558  do i=is,ie+1
1559  p1(:) = grid(i ,j ,1:2)
1560  p2(:) = grid(i,j+1 ,1:2)
1561  call mid_pt_sphere(p1, p2, p3)
1562  r = great_circle_dist( p0, p3, radius )
1563  utmp = ubar*exp(-(r/r0)**2)
1564  call get_unit_vect2(p1, p2, e2)
1565  call get_latlon_vector(p3, ex, ey)
1566  v(i,j,1) = utmp*inner_prod(e2,ex)
1567  enddo
1568  enddo
1569  do j=js,je+1
1570  do i=is,ie
1571  p1(:) = grid(i, j,1:2)
1572  p2(:) = grid(i+1,j,1:2)
1573  call mid_pt_sphere(p1, p2, p3)
1574  r = great_circle_dist( p0, p3, radius )
1575  utmp = ubar*exp(-(r/r0)**2)
1576  call get_unit_vect2(p1, p2, e1)
1577  call get_latlon_vector(p3, ex, ey)
1578  u(i,j,1) = utmp*inner_prod(e1,ex)
1579  enddo
1580  enddo
1581  initwindscase= -1
1582 #endif
1583  end select
1584 !--------------- end s-w cases --------------------------
1585 
1586 ! Copy 3D data for Shallow Water Tests
1587  do z=2,npz
1588  delp(:,:,z) = delp(:,:,1)
1589  enddo
1590 
1591  call mpp_update_domains( delp, domain )
1592  call mpp_update_domains( phis, domain )
1593  phi0 = delp
1594 
1595  call init_winds(ubar, u,v,ua,va,uc,vc, initwindscase, npx, npy, ng, ndims, nregions, gridstruct%bounded_domain, gridstruct, domain, tile, bd)
1596 ! Copy 3D data for Shallow Water Tests
1597  do z=2,npz
1598  u(:,:,z) = u(:,:,1)
1599  v(:,:,z) = v(:,:,1)
1600  enddo
1601 
1602  do j=js,je
1603  do i=is,ie
1604  ps(i,j) = delp(i,j,1)
1605  enddo
1606  enddo
1607 ! -------- end s-w section ----------------------------------
1608 #else
1609 
1610  if (test_case==10 .or. test_case==14) then
1611 
1612  alpha = 0.
1613 
1614  ! Initialize dry atmosphere
1615  q(:,:,:,:) = 3.e-6
1616  u(:,:,:) = 0.0
1617  v(:,:,:) = 0.0
1618  if (.not.hydrostatic) w(:,:,:)= 0.0
1619 
1620  if ( test_case==14 ) then
1621 ! Aqua-planet case: mean SLP=1.E5
1622  phis = 0.0
1623  call hydro_eq(npz, is, ie, js, je, ps, phis, 1.e5, &
1624  delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
1625  else
1626 ! Initialize topography
1627  gh0 = 5960.*grav
1628  phis = 0.0
1629  r0 = pi/9.
1630  p1(1) = pi/4.
1631  p1(2) = pi/6. + (7.5/180.0)*pi
1632  do j=js2,je2
1633  do i=is2,ie2
1634  p2(1) = agrid(i,j,1)
1635  p2(2) = agrid(i,j,2)
1636  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1637  r = sqrt(r)
1638  phis(i,j) = gh0*(1.0-(r/r0))
1639  enddo
1640  enddo
1641  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1642  delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1643  endif
1644 
1645  else if (test_case==11) then
1646  call surfdrv(npx, npy, gridstruct%grid_64, gridstruct%agrid_64, &
1647  gridstruct%area_64, dx, dy, dxa, dya, dxc, dyc, &
1648  gridstruct%sin_sg, phis, &
1649  flagstruct%stretch_fac, gridstruct%nested, gridstruct%bounded_domain, &
1650  npx_global, domain, flagstruct%grid_number, bd)
1651  call mpp_update_domains( phis, domain )
1652 
1653  if ( hybrid_z ) then
1654  rgrav = 1./ grav
1655  if( npz==32 ) then
1656  call compute_dz_l32( npz, ztop, dz1 )
1657  else
1658 ! call mpp_error(FATAL, 'You must provide a routine for hybrid_z')
1659  if ( is_master() ) write(*,*) 'Using const DZ'
1660  ztop = 45.e3 ! assuming ptop = 100.
1661  dz1(1) = ztop / real(npz)
1662  dz1(npz) = 0.5*dz1(1)
1663  do z=2,npz-1
1664  dz1(z) = dz1(1)
1665  enddo
1666  dz1(1) = 2.*dz1(2)
1667  endif
1668 
1669  call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
1670  phis, ze0, delz)
1671 ! call prt_maxmin('ZE0', ze0, is, ie, js, je, 0, npz, 1.E-3)
1672 ! call prt_maxmin('DZ0', delz, is, ie, js, je, 0, npz, 1. )
1673  endif
1674 
1675 ! Initialize dry atmosphere
1676  u = 0.
1677  v = 0.
1678  q(:,:,:,:) = 0.
1679  q(:,:,:,1) = 3.e-6
1680 
1681  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1682  delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1683 
1684  else if ( (test_case==12) .or. (test_case==13) ) then
1685 
1686 #ifdef HIWPP_TRACER
1687  if (is_master()) print*, 'TEST TRACER enabled for this test case'
1688 #ifdef HIWPP
1689  call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
1690  ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
1691 #else
1692  !For consistency with earlier single-grid simulations use gh0 = 1.0e-6 and p1(1) = 195.*pi/180.
1693  q(:,:,:,:) = 0.
1694  gh0 = 1.0e-3
1695  r0 = radius/3. !RADIUS radius/3.
1696  p1(2) = 51.*pi/180.
1697  p1(1) = 205.*pi/180. !231.*pi/180.
1698  do k=1,npz
1699  do j=jsd,jed
1700  do i=isd,ied
1701  p2(1) = agrid(i,j,1)
1702  p2(2) = agrid(i,j,2)
1703  r = great_circle_dist( p1, p2, radius )
1704  if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.) .and. k > 16) then
1705  q(i,j,k,1) = gh0
1706  else
1707  q(i,j,k,1) = 0.
1708  endif
1709  enddo
1710  enddo
1711  enddo
1712 #endif
1713 
1714 #else
1715 
1716  q(:,:,:,:) = 0.
1717 
1718 #ifdef HIWPP
1719 
1720  cl = get_tracer_index(model_atmos, 'cl')
1721  cl2 = get_tracer_index(model_atmos, 'cl2')
1722  if (cl > 0 .and. cl2 > 0) then
1723  call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
1724  q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2),bd)
1725  call mpp_update_domains(q,domain)
1726  endif
1727 
1728 #endif
1729 #endif
1730  ! Initialize surface Pressure
1731  ps(:,:) = 1.e5
1732  ! Initialize detla-P
1733 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,ak,ps,bk)
1734  do z=1,npz
1735  do j=js,je
1736  do i=is,ie
1737  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
1738  enddo
1739  enddo
1740  enddo
1741 
1742 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,ptop,peln,pk,delp)
1743  do j=js,je
1744  do i=is, ie
1745  pe(i,1,j) = ptop
1746  peln(i,1,j) = log(ptop)
1747  pk(i,j,1) = ptop**kappa
1748  enddo
1749 ! Top down
1750  do k=2,npz+1
1751  do i=is,ie
1752  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
1753  pk(i,j,k) = exp( kappa*log(pe(i,k,j)) )
1754  peln(i,k,j) = log(pe(i,k,j))
1755  enddo
1756  enddo
1757  enddo
1758 
1759 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,pk,peln)
1760  do k=1,npz
1761  do j=js,je
1762  do i=is,ie
1763  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
1764  enddo
1765  enddo
1766  enddo
1767 
1768  ! Setup ETA auxil variable
1769  eta_0 = 0.252
1770  do k=1,npz
1771  eta(k) = 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
1772  eta_v(k) = (eta(k) - eta_0)*pi*0.5
1773  enddo
1774 
1775  if ( .not. adiabatic ) then
1776  !Set up moisture
1777  sphum = get_tracer_index(model_atmos, 'sphum')
1778  pcen(1) = pi/9.
1779  pcen(2) = 2.0*pi/9.
1780 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pe,q,agrid,pcen,delp,peln) &
1781 !$OMP private(ptmp)
1782  do k=1,npz
1783  do j=js,je
1784  do i=is,ie
1785  !r = great_circle_dist(pcen, agrid(i,j,:), radius)
1786  !ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j)) - 100000.
1787  !q(i,j,k,1) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1788  ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - 100000.
1789  q(i,j,k,sphum) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1790 ! SJL:
1791 ! q(i,j,k,sphum) = max(1.e-25, q(i,j,k,sphum))
1792  enddo
1793  enddo
1794  enddo
1795  endif
1796 
1797  ! Initialize winds
1798  ubar = 35.0
1799  r0 = 1.0
1800  pcen(1) = pi/9.
1801  pcen(2) = 2.0*pi/9.
1802  if (test_case == 13) then
1803 #ifdef ALT_PERT
1804  u1 = 0.0
1805  pt0 = 3.0
1806 #else
1807  u1 = 1.0
1808  pt0 = 0.0
1809 #endif
1810  r0 = radius/10.0
1811  endif
1812 
1813 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta_v,grid,Ubar,pcen,r0,ee2,v,ee1,es,u,u1,ew) &
1814 !$OMP private(utmp,r,vv1,vv3,p1,p2,vv2,uu1,uu2,uu3,pa)
1815  do z=1,npz
1816  do j=js,je
1817  do i=is,ie+1
1818  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j+1,2))**2.0
1819  ! Perturbation if Case==13
1820  r = great_circle_dist( pcen, grid(i,j+1,1:2), radius )
1821  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1822  vv1 = utmp*(ee2(2,i,j+1)*cos(grid(i,j+1,1)) - ee2(1,i,j+1)*sin(grid(i,j+1,1)))
1823 
1824  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j,2))**2.0
1825  ! Perturbation if Case==13
1826  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1827  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1828  vv3 = utmp*(ee2(2,i,j)*cos(grid(i,j,1)) - ee2(1,i,j)*sin(grid(i,j,1)))
1829 ! Mid-point:
1830  p1(:) = grid(i ,j ,1:2)
1831  p2(:) = grid(i,j+1 ,1:2)
1832  call mid_pt_sphere(p1, p2, pa)
1833  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*pa(2))**2.0
1834  ! Perturbation if Case==13
1835  r = great_circle_dist( pcen, pa, radius )
1836  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1837  vv2 = utmp*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1838 ! 3-point average:
1839  v(i,j,z) = 0.25*(vv1 + 2.*vv2 + vv3)
1840  enddo
1841  enddo
1842  do j=js,je+1
1843  do i=is,ie
1844  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j,2))**2.0
1845  ! Perturbation if Case==13
1846  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1847  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1848  uu1 = utmp*(ee1(2,i,j)*cos(grid(i,j,1)) - ee1(1,i,j)*sin(grid(i,j,1)))
1849 
1850  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i+1,j,2))**2.0
1851  ! Perturbation if Case==13
1852  r = great_circle_dist( pcen, grid(i+1,j,1:2), radius )
1853  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1854  uu3 = utmp*(ee1(2,i+1,j)*cos(grid(i+1,j,1)) - ee1(1,i+1,j)*sin(grid(i+1,j,1)))
1855 ! Mid-point:
1856  p1(:) = grid(i ,j ,1:2)
1857  p2(:) = grid(i+1,j ,1:2)
1858  call mid_pt_sphere(p1, p2, pa)
1859  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*pa(2))**2.0
1860  ! Perturbation if Case==13
1861  r = great_circle_dist( pcen, pa, radius )
1862  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1863  uu2 = utmp*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1864 ! 3-point average:
1865  u(i,j,z) = 0.25*(uu1 + 2.*uu2 + uu3)
1866  enddo
1867  enddo
1868  enddo ! z-loop
1869 
1870  ! Temperature
1871  eta_s = 1.0 ! Surface Level
1872  eta_t = 0.2 ! Tropopause
1873  t_0 = 288.0
1874  delta_t = 480000.0
1875  lapse_rate = 0.005
1876 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta,ak,bk,T_0,lapse_rate,eta_t, &
1877 !$OMP delta_T,ptop,delp,Ubar,eta_v,agrid,grid,pcen,pt,r0) &
1878 !$OMP private(T_mean,press,pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1,r)
1879  do z=1,npz
1880  eta(z) = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
1881  ! if (is_master()) print*, z, eta
1882  t_mean = t_0 * eta(z)**(rdgas*lapse_rate/grav)
1883  if (eta_t > eta(z)) t_mean = t_mean + delta_t*(eta_t - eta(z))**5.0
1884 
1885  230 format(i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
1886  press = ptop
1887  do zz=1,z
1888  press = press + delp(is,js,zz)
1889  enddo
1890  if (is_master()) write(*,230) z, eta(z), press/100., t_mean
1891  do j=js,je
1892  do i=is,ie
1893 ! A-grid cell center: i,j
1894  pt1 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1895  ( -2.0*(sin(agrid(i,j,2))**6.0) *(cos(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1896  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1897  ( (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 )
1898 #ifndef NO_AVG13
1899 ! 9-point average: should be 2nd order accurate for a rectangular cell
1900 !
1901 ! 9 4 8
1902 !
1903 ! 5 1 3
1904 !
1905 ! 6 2 7
1906 !
1907  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1908  pt2 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1909  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1910  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1911  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1912  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1913  pt3 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1914  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(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(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1917  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1918  pt4 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1919  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1920  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1921  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1922  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1923  pt5 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1924  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1925  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1926  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1927 
1928  pt6 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1929  ( -2.0*(sin(grid(i,j,2))**6.0) *(cos(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1930  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1931  ( (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 )
1932  pt7 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1933  ( -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 ) * &
1934  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1935  ( (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 )
1936  pt8 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1937  ( -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 ) * &
1938  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1939  ( (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 )
1940  pt9 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1941  ( -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 ) * &
1942  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1943  ( (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 )
1944  pt(i,j,z) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1945 #else
1946  pt(i,j,z) = pt1
1947 #endif
1948 
1949 #ifdef ALT_PERT
1950  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
1951  if ( (r/r0)**2 < 40. ) then
1952  pt(i,j,z) = pt(i,j,z) + pt0*exp(-(r/r0)**2)
1953  endif
1954 #endif
1955 
1956  enddo
1957  enddo
1958  enddo
1959  if (is_master()) print*,' '
1960  ! Surface Geopotential
1961  phis(:,:)=1.e25
1962 !$OMP parallel do default(none) shared(is2,ie2,js2,je2,Ubar,eta_s,eta_0,agrid,grid,phis) &
1963 !$OMP private(pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1)
1964  do j=js2,je2
1965  do i=is2,ie2
1966  pt1 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1967  ( -2.0*(sin(agrid(i,j,2))**6.0) *(cos(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1968  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1969  ( (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 )
1970 #ifndef NO_AVG13
1971 ! 9-point average:
1972 !
1973 ! 9 4 8
1974 !
1975 ! 5 1 3
1976 !
1977 ! 6 2 7
1978 !
1979  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1980  pt2 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1981  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1982  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1983  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1984  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1985  pt3 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1986  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(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(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1989  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1990  pt4 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1991  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1992  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1993  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1994  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1995  pt5 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1996  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1997  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1998  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1999 
2000  pt6 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
2001  ( -2.0*(sin(grid(i,j,2))**6.0) *(cos(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
2002  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
2003  ( (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 )
2004  pt7 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
2005  ( -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 ) * &
2006  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
2007  ( (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 )
2008  pt8 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
2009  ( -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 ) * &
2010  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
2011  ( (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 )
2012  pt9 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
2013  ( -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 ) * &
2014  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
2015  ( (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 )
2016  phis(i,j) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
2017 #else
2018  phis(i,j) = pt1
2019 #endif
2020  enddo
2021  enddo
2022 
2023  if ( .not.hydrostatic ) then
2024 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,delz,peln,w)
2025  do k=1,npz
2026  do j=js,je
2027  do i=is,ie
2028  w(i,j,k) = 0.
2029  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
2030  enddo
2031  enddo
2032  enddo
2033  endif
2034  !Assume pt is virtual temperature at this point; then convert to regular temperature
2035  if (.not. adiabatic) then
2036  zvir = rvgas/rdgas - 1.
2037 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pt,zvir,q)
2038  do k=1,npz
2039  do j=js,je
2040  do i=is,ie
2041  pt(i,j,k) = pt(i,j,k)/(1. + zvir*q(i,j,k,sphum))
2042  enddo
2043  enddo
2044  enddo
2045  endif
2046 
2047  !Set up tracer #2 to be the initial EPV
2048 ! call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,2))
2049 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
2050 
2051  write(stdout(), *) 'PI:', pi
2052  write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
2053 
2054  else if ( (test_case==-12) .or. (test_case==-13) ) then
2055 
2056  call dcmip16_bc(delp,pt,u,v,q,w,delz, &
2057  is,ie,js,je,isd,ied,jsd,jed,npz,ncnst,ak,bk,ptop, &
2058  pk,peln,pe,pkz,gz,phis,ps,grid,agrid,hydrostatic, &
2059  nwat, adiabatic, test_case == -13, domain, bd)
2060 
2061  write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
2062 
2063  else if ( test_case==15 .or. test_case==19 ) then
2064 !------------------------------------
2065 ! Non-hydrostatic 3D density current:
2066 !------------------------------------
2067 ! C100_L64; hybrid_z = .T., make_nh = .F. , make_hybrid_z = .false.
2068 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
2069 
2070  if ( test_case == 19 ) then
2071  f0(:,:) = 0.
2072  fc(:,:) = 0.
2073  endif
2074 
2075  phis = 0.
2076  u = 0.
2077  v = 0.
2078  w = 0.
2079  t00 = 300.
2080  p00 = 1.e5
2081  pk0 = p00**kappa
2082 ! Set up vertical coordinare with constant del-z spacing:
2083  ztop = 6.4e3
2084  ze1( 1) = ztop
2085  ze1(npz+1) = 0.
2086  do k=npz,2,-1
2087  ze1(k) = ze1(k+1) + ztop/real(npz)
2088  enddo
2089 
2090 ! Provide some room for the top layer
2091  ze1(1) = ztop + 1.5*ztop/real(npz)
2092 
2093  do j=js,je
2094  do i=is,ie
2095  ps(i,j) = p00
2096  pe(i,npz+1,j) = p00
2097  pk(i,j,npz+1) = pk0
2098  enddo
2099  enddo
2100 
2101  do k=npz,1,-1
2102  do j=js,je
2103  do i=is,ie
2104  delz(i,j,k) = ze1(k+1) - ze1(k)
2105  pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
2106  pe(i,k,j) = pk(i,j,k)**(1./kappa)
2107  enddo
2108  enddo
2109  enddo
2110 
2111  ptop = pe(is,1,js)
2112  if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
2113 
2114  do k=1,npz+1
2115  do j=js,je
2116  do i=is,ie
2117  peln(i,k,j) = log(pe(i,k,j))
2118  ze0(i,j,k) = ze1(k)
2119  enddo
2120  enddo
2121  enddo
2122 
2123  do k=1,npz
2124  do j=js,je
2125  do i=is,ie
2126  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2127  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2128  pt(i,j,k) = t00/pk0 ! potential temp
2129  enddo
2130  enddo
2131  enddo
2132 
2133 ! Perturbation: center at 3 km from the ground
2134  pturb = 15.
2135  p1(1) = pi
2136  p1(2) = 0.
2137 
2138  do k=1,npz
2139 #ifndef STD_BUBBLE
2140  r0 = 0.5*(ze1(k)+ze1(k+1)) - 3.2e3
2141 #else
2142  r0 = (0.5*(ze1(k)+ze1(k+1)) - 3.0e3) / 2.e3
2143 #endif
2144  do j=js,je
2145  do i=is,ie
2146 ! Impose perturbation in potential temperature: pturb
2147  p2(1) = agrid(i,j,1)
2148  p2(2) = agrid(i,j,2)
2149 #ifndef STD_BUBBLE
2150  r = great_circle_dist( p1, p2, radius )
2151  dist = sqrt( r**2 + r0**2 ) / 3.2e3
2152 #else
2153  r = great_circle_dist( p1, p2, radius ) / 4.e3
2154  dist = sqrt( r**2 + r0**2 )
2155 #endif
2156  if ( dist<=1. ) then
2157  q(i,j,k,1) = pk0 * pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2158  pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2159  else
2160  q(i,j,k,1) = 0.
2161  endif
2162 ! Transform back to temperature:
2163  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
2164  enddo
2165  enddo
2166  enddo
2167 
2168  else if ( test_case==16 ) then
2169 
2170 ! Non-rotating:
2171  f0(:,:) = 0.
2172  fc(:,:) = 0.
2173 ! Initialize dry atmosphere
2174  phis = 0.
2175  u = 0.
2176  v = 0.
2177  p00 = 1000.e2
2178 ! Set up vertical coordinare with constant del-z spacing:
2179  ztop = 10.e3
2180  call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2181 
2182  do z=1,npz+1
2183  pe1(z) = ak(z) + bk(z)*p00
2184  enddo
2185 
2186  ze1(npz+1) = 0.
2187  do z=npz,2,-1
2188  ze1(z) = ze1(z+1) + ztop/real(npz)
2189  enddo
2190  ze1(1) = ztop
2191 
2192  if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2193 
2194  do j=jsd,jed
2195  do i=isd,ied
2196  ps(i,j) = pe1(npz+1)
2197  enddo
2198  enddo
2199 
2200  do z=1,npz+1
2201  do j=js,je
2202  do i=is,ie
2203  pe(i,z,j) = pe1(z)
2204  peln(i,z,j) = log(pe1(z))
2205  pk(i,j,z) = exp(kappa*peln(i,z,j))
2206  enddo
2207  enddo
2208  enddo
2209 
2210 ! Horizontal shape function
2211  p1(1) = pi
2212  p1(2) = 0.
2213  r0 = radius / 3.
2214  do j=js,je
2215  do i=is,ie
2216  r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2217  if ( r<r0 ) then
2218  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2219  else
2220  vort(i,j) = 0
2221  endif
2222  enddo
2223  enddo
2224 
2225  q = 0.
2226  pk0 = p00**kappa
2227  pturb = 10./pk0
2228  do z=1,npz
2229  zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2230  do j=js,je
2231  do i=is,ie
2232  pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2233  delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2234 ! Impose perturbation in potential temperature: pturb
2235  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2236  q(i,j,z,1) = q(i,j,z,1) + vort(i,j)*zmid
2237  enddo
2238  enddo
2239  enddo
2240 
2241  elseif ( test_case==17 ) then
2242 ! Initialize dry atmosphere
2243  phis = 0.
2244  u = 0.
2245  v = 0.
2246  p00 = 1000.e2
2247 ! Set up vertical coordinare with constant del-z spacing:
2248  ztop = 10.e3
2249  call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2250 
2251  do z=1,npz+1
2252  pe1(z) = ak(z) + bk(z)*p00
2253  enddo
2254 
2255  ze1(npz+1) = 0.
2256  do z=npz,2,-1
2257  ze1(z) = ze1(z+1) + ztop/real(npz)
2258  enddo
2259  ze1(1) = ztop
2260 
2261  if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2262 
2263  do j=jsd,jed
2264  do i=isd,ied
2265  ps(i,j) = pe1(npz+1)
2266  enddo
2267  enddo
2268 
2269  do z=1,npz+1
2270  do j=js,je
2271  do i=is,ie
2272  pe(i,z,j) = pe1(z)
2273  peln(i,z,j) = log(pe1(z))
2274  pk(i,j,z) = exp(kappa*peln(i,z,j))
2275  enddo
2276  enddo
2277  enddo
2278 
2279 ! Horizontal shape function
2280  p1(1) = pi
2281  p1(2) = pi/4.
2282  r0 = radius / 3.
2283  do j=js,je
2284  do i=is,ie
2285  r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2286  if ( r<r0 ) then
2287  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2288  else
2289  vort(i,j) = 0
2290  endif
2291  enddo
2292  enddo
2293 
2294  pk0 = p00**kappa
2295  pturb = 10./pk0
2296  do z=1,npz
2297  zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2298  do j=js,je
2299  do i=is,ie
2300  pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2301  delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2302 ! Impose perturbation in potential temperature: pturb
2303  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2304  enddo
2305  enddo
2306  enddo
2307 
2308  elseif ( test_case==18 ) then
2309  ubar = 20.
2310  pt0 = 288.
2311  n2 = grav**2 / (cp_air*pt0)
2312 
2313  pcen(1) = pi/2.
2314  pcen(2) = pi/6.
2315 
2316  ! Initialize surface Pressure
2317  do j=js2,je2
2318  do i=is2,ie2
2319  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
2320  phis(i,j) = grav*2.e3*exp( -(r/1500.e3)**2 )
2321  ps(i,j) = 930.e2 * exp( -radius*n2*ubar/(2.*grav*grav*kappa)*(ubar/radius+2.*omega)* &
2322  (sin(agrid(i,j,2))**2-1.) - n2/(grav*grav*kappa)*phis(i,j))
2323  enddo
2324  enddo
2325 
2326  do z=1,npz
2327  do j=js,je
2328  do i=is,ie
2329  pt(i,j,z) = pt0
2330  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
2331  enddo
2332  enddo
2333 ! v-wind:
2334  do j=js,je
2335  do i=is,ie+1
2336  p1(:) = grid(i ,j ,1:2)
2337  p2(:) = grid(i,j+1 ,1:2)
2338  call mid_pt_sphere(p1, p2, p3)
2339  call get_unit_vect2(p1, p2, e2)
2340  call get_latlon_vector(p3, ex, ey)
2341  utmp = ubar * cos(p3(2))
2342  vtmp = 0.
2343  v(i,j,z) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2344  enddo
2345  enddo
2346 
2347 ! u-wind
2348  do j=js,je+1
2349  do i=is,ie
2350  p1(:) = grid(i, j,1:2)
2351  p2(:) = grid(i+1,j,1:2)
2352  call mid_pt_sphere(p1, p2, p3)
2353  call get_unit_vect2(p1, p2, e1)
2354  call get_latlon_vector(p3, ex, ey)
2355  utmp = ubar * cos(p3(2))
2356  vtmp = 0.
2357  u(i,j,z) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2358  enddo
2359  enddo
2360  enddo
2361 
2362  else if ( test_case==20 .or. test_case==21 ) then
2363 !------------------------------------
2364 ! Non-hydrostatic 3D lee vortices
2365 !------------------------------------
2366  f0(:,:) = 0.
2367  fc(:,:) = 0.
2368 
2369  if ( test_case == 20 ) then
2370  ubar = 4. ! u = Ubar * cos(lat)
2371  ftop = 2.0e3 * grav
2372  else
2373  ubar = 8. ! u = Ubar * cos(lat)
2374  ftop = 4.0e3 * grav
2375  endif
2376 
2377  w = 0.
2378 
2379  do j=js,je
2380  do i=is,ie+1
2381  p1(:) = grid(i ,j ,1:2)
2382  p2(:) = grid(i,j+1 ,1:2)
2383  call mid_pt_sphere(p1, p2, p3)
2384  call get_unit_vect2(p1, p2, e2)
2385  call get_latlon_vector(p3, ex, ey)
2386  utmp = ubar * cos(p3(2))
2387  vtmp = 0.
2388  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2389  enddo
2390  enddo
2391  do j=js,je+1
2392  do i=is,ie
2393  p1(:) = grid(i, j,1:2)
2394  p2(:) = grid(i+1,j,1:2)
2395  call mid_pt_sphere(p1, p2, p3)
2396  call get_unit_vect2(p1, p2, e1)
2397  call get_latlon_vector(p3, ex, ey)
2398  utmp = ubar * cos(p3(2))
2399  vtmp = 0.
2400  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2401  enddo
2402  enddo
2403 
2404 ! copy vertically; no wind shear
2405  do k=2,npz
2406  do j=js,je+1
2407  do i=is,ie
2408  u(i,j,k) = u(i,j,1)
2409  enddo
2410  enddo
2411  do j=js,je
2412  do i=is,ie+1
2413  v(i,j,k) = v(i,j,1)
2414  enddo
2415  enddo
2416  enddo
2417 
2418 ! Center of the mountain:
2419  p1(1) = (0.5-0.125) * pi
2420  p1(2) = 0.
2421  call latlon2xyz(p1, e1)
2422  uu1 = 5.0e3
2423  uu2 = 10.0e3
2424  do j=js2,je2
2425  do i=is2,ie2
2426  p2(:) = agrid(i,j,1:2)
2427  r = great_circle_dist( p1, p2, radius )
2428  if ( r < pi*radius ) then
2429  p4(:) = p2(:) - p1(:)
2430  if ( abs(p4(1)) > 1.e-12 ) then
2431  zeta = asin( p4(2) / sqrt(p4(1)**2 + p4(2)**2) )
2432  else
2433  zeta = pi/2.
2434  endif
2435  if ( p4(1) <= 0. ) zeta = pi - zeta
2436  zeta = zeta + pi/6.
2437  v1 = r/uu1 * cos( zeta )
2438  v2 = r/uu2 * sin( zeta )
2439  phis(i,j) = ftop / ( 1. + v1**2 + v2**2 )
2440  else
2441  phis(i,j) = 0.
2442  endif
2443  enddo
2444  enddo
2445 
2446  if ( hybrid_z ) then
2447  rgrav = 1./ grav
2448  if( npz==32 ) then
2449  call compute_dz_l32( npz, ztop, dz1 )
2450  elseif( npz.eq.31 .or. npz.eq.41 .or. npz.eq.51 ) then
2451  ztop = 16.e3
2452  call hybrid_z_dz(npz, dz1, ztop, 1.0)
2453  else
2454  if ( is_master() ) write(*,*) 'Using const DZ'
2455  ztop = 15.e3
2456  dz1(1) = ztop / real(npz)
2457  do k=2,npz
2458  dz1(k) = dz1(1)
2459  enddo
2460 ! Make top layer thicker
2461  dz1(1) = max( 1.0e3, 3.*dz1(2) ) ! min 1 km
2462  endif
2463 
2464 ! Re-compute ztop
2465  ze1(npz+1) = 0.
2466  do k=npz,1,-1
2467  ze1(k) = ze1(k+1) + dz1(k)
2468  enddo
2469  ztop = ze1(1)
2470 
2471  call set_hybrid_z( is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
2472  phis, ze0, delz )
2473  else
2474  call mpp_error(fatal, 'This test case is only currently setup for hybrid_z')
2475  endif
2476 
2477  do k=1,npz
2478  do j=js,je
2479  do i=is,ie
2480  delz(i,j,k) = ze0(i,j,k+1) - ze0(i,j,k)
2481  enddo
2482  enddo
2483  enddo
2484 
2485  p00 = 1.e5 ! mean SLP
2486  pk0 = p00**kappa
2487  t00 = 300.
2488  pt0 = t00/pk0
2489  n2 = 1.e-4
2490  s0 = grav*grav / (cp_air*n2)
2491 
2492 ! For constant N2, Given z --> p
2493  do k=1,npz+1
2494  pe1(k) = p00*( (1.-s0/t00) + s0/t00*exp(-n2*ze1(k)/grav) )**(1./kappa)
2495  enddo
2496 
2497  ptop = pe1(1)
2498  if ( is_master() ) write(*,*) 'Lee vortex testcase: model top (mb)=', ptop/100.
2499 
2500 ! Set up fake "sigma" coordinate
2501  ak(1) = pe1(1)
2502  bk(1) = 0.
2503  do k=2,npz
2504  bk(k) = (pe1(k) - pe1(1)) / (pe1(npz+1)-pe1(1)) ! bk == sigma
2505  ak(k) = pe1(1)*(1.-bk(k))
2506  enddo
2507  ak(npz+1) = 0.
2508  bk(npz+1) = 1.
2509 
2510 ! Assuming constant N
2511  do k=2,npz+1
2512  do j=js,je
2513  do i=is,ie
2514  pk(i,j,k) = pk0 - (1.-exp(-n2/grav*ze0(i,j,k))) * (grav*grav)/(n2*cp_air*pt0)
2515  pe(i,k,j) = pk(i,j,k) ** (1./kappa)
2516  peln(i,k,j) = log(pe(i,k,j))
2517  enddo
2518  enddo
2519  enddo
2520 
2521  do j=js,je
2522  do i=is,ie
2523  pe(i,1,j) = ptop
2524  peln(i,1,j) = log(pe(i,1,j))
2525  pk(i,j,1) = pe(i,1,j) ** kappa
2526  ps(i,j) = pe(i,npz+1,j)
2527  enddo
2528  enddo
2529 
2530  do k=1,npz
2531  do j=js,je
2532  do i=is,ie
2533  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2534  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2535  pt(i,j,k) = pkz(i,j,k)*grav*delz(i,j,k) / ( cp_air*(pk(i,j,k)-pk(i,j,k+1)) )
2536  enddo
2537  enddo
2538  enddo
2539 
2540  else if (test_case == 51) then
2541 
2542  alpha = 0.
2543  t00 = 300.
2544 
2545 
2546  if (.not.hydrostatic) w(:,:,:)= 0.0
2547 
2548 
2549  select case (tracer_test)
2550  case (1) !DCMIP 11
2551 
2552  !Need to set up pressure arrays
2553 !!$ p00 = 1.e5
2554 !!$ ps = p00
2555 !!$ phis = 0.
2556 
2557  !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
2558 
2559  dz = 12000./real(npz)
2560 
2561  allocate(zz0(npz+1))
2562  allocate(pz0(npz+1))
2563 
2564  zz0(1) = 12000.
2565  do k=2,npz
2566  zz0(k) = zz0(k-1) - dz
2567  enddo
2568  zz0(npz+1) = 0.
2569 
2570  if (is_master()) print*, 'TRACER ADVECTION TEST CASE'
2571  if (is_master()) print*, 'INITIAL LEVELS'
2572  !This gets interface pressure from input z-levels
2573  do k=1,npz+1
2574  !call test1_advection_deformation(agrid(is,js,1), agrid(is,js,2), pz0(k), zz0(k), 1, &
2575  ! ua(is,js,1), va(is,js,1), dum1, pt(is,js,1), phis(is,js), &
2576  ! 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))
2577  if (is_master()) write(*,*) k, pz0(k), zz0(k)
2578  enddo
2579 
2580  !Pressure
2581  do j=js,je
2582  do k=1,npz+1
2583  do i=is,ie
2584  pe(i,k,j) = pz0(k)
2585  enddo
2586  enddo
2587  enddo
2588 
2589  do k=1,npz
2590  ptmp = 0.5*(pz0(k) + pz0(k+1))
2591  do j=js,je
2592  do i=is,ie
2593  !This gets level-mean values from input pressures
2594  !call test1_advection_deformation(agrid(i,j,1),agrid(i,j,2),ptmp,dum,0, &
2595  ! ua(i,j,k), va(i,j,k), dum4, pt(i,j,k), phis(i,j), &
2596  ! 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))
2597  delp(i,j,k) = pz0(k+1)-pz0(k)
2598  enddo
2599  enddo
2600  enddo
2601 
2602  ptop = 100000.*exp(-12000.*grav/t00/rdgas)
2603 
2604 
2605  psi(:,:) = 1.e25
2606  psi_b(:,:) = 1.e25
2607  do j=jsd,jed
2608  do i=isd,ied
2609  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
2610  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
2611  enddo
2612  enddo
2613  call mpp_update_domains( psi, domain )
2614  do j=jsd,jed+1
2615  do i=isd,ied+1
2616  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
2617  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
2618  enddo
2619  enddo
2620 
2621  k = 1
2622  do j=js,je+1
2623  do i=is,ie
2624  dist = dx(i,j)
2625  vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
2626  if (dist==0) vc(i,j,k) = 0.
2627  enddo
2628  enddo
2629  do j=js,je
2630  do i=is,ie+1
2631  dist = dy(i,j)
2632  uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
2633  if (dist==0) uc(i,j,k) = 0.
2634  enddo
2635  enddo
2636 
2637  do j=js,je
2638  do i=is,ie+1
2639  dist = dxc(i,j)
2640  v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
2641  if (dist==0) v(i,j,k) = 0.
2642  enddo
2643  enddo
2644  do j=js,je+1
2645  do i=is,ie
2646  dist = dyc(i,j)
2647  u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
2648  if (dist==0) u(i,j,k) = 0.
2649  enddo
2650  enddo
2651 
2652  do j=js,je
2653  do i=is,ie
2654  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
2655  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
2656  dist = dya(i,j)
2657  ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
2658  if (dist==0) ua(i,j,k) = 0.
2659  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
2660  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
2661  dist = dxa(i,j)
2662  va(i,j,k) = (psi2 - psi1) / (dist)
2663  if (dist==0) va(i,j,k) = 0.
2664  enddo
2665  enddo
2666 
2667  do k=2,npz
2668  u(:,:,k) = u(:,:,1)
2669  v(:,:,k) = v(:,:,1)
2670  uc(:,:,k) = uc(:,:,1)
2671  vc(:,:,k) = vc(:,:,1)
2672  ua(:,:,k) = ua(:,:,1)
2673  va(:,:,k) = va(:,:,1)
2674  enddo
2675 
2676  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
2677  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
2678  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
2679 
2680  case (2) !DCMIP 12
2681 
2682  case (3) !DCMIP 13
2683 
2684  case default
2685  call mpp_error(fatal, 'Value of tracer_test not implemented ')
2686  end select
2687 
2688  else if (test_case == 52) then
2689 
2690  !Orography and steady-state test: DCMIP 20
2691 
2692 
2693  f0 = 0.
2694  fc = 0.
2695 
2696  u = 0.
2697  v = 0.
2698 
2699  p00 = 1.e5
2700 
2701  wind_field = tracer_test
2702 
2703  if (.not.hydrostatic) w(:,:,:)= 0.0
2704 
2705  !Set up ak and bk
2706 
2707  dz = 12000./real(npz)
2708  t00 = 300.
2709  p00 = 1.e5
2710  h = rdgas*t00/grav
2711  gamma = 0.0065
2712  exponent = rdgas*gamma/grav
2713  px = ((t00-9000.*gamma)/t00)**(1./exponent) !p00 not multiplied in
2714 
2715 
2716  do k=1,npz+1
2717  height = 12000. - dz*real(k-1)
2718  if (height >= 9000. ) then
2719  ak(k) = p00*((t00-height*gamma)/t00)**(1./exponent)
2720  bk(k) = 0.
2721  else
2722  ak(k) = (((t00-height*gamma)/t00)**(1./exponent)-1.)/(px - 1.)*px*p00
2723  bk(k) = (((t00-height*gamma)/t00)**(1./exponent)-px)/(1.-px)
2724  endif
2725  if (is_master()) write(*,*) k, ak(k), bk(k), height, ak(k)+bk(k)*p00
2726  enddo
2727 
2728  ptop = ak(1)
2729 
2730  !Need to set up uniformly-spaced levels
2731  p1(1) = 3.*pi/2. ; p1(2) = 0.
2732  r0 = 0.75*pi
2733  zetam = pi/16.
2734 
2735  !Topography
2736  do j=js,je
2737  do i=is,ie
2738  p2(:) = agrid(i,j,1:2)
2739  r = great_circle_dist( p1, p2, one )
2740  if (r < r0) then
2741  phis(i,j) = grav*0.5*2000.*(1. + cos(pi*r/r0))*cos(pi*r/zetam)**2.
2742  pe(i,npz+1,j) = p00*(1.-gamma/t00*phis(i,j)/grav)**(1./exponent)
2743  else
2744  phis(i,j) = 0.
2745  pe(i,npz+1,j) = p00
2746  endif
2747  ps(i,j) = pe(i,npz+1,j)
2748  enddo
2749  enddo
2750 
2751  do j=js,je
2752  do k=1,npz
2753  do i=is,ie
2754  pe(i,k,j) = ak(k) + bk(k)*ps(i,j)
2755  gz(i,j,k) = t00/gamma*(1. - (pe(i,k,j)/p00)**exponent)
2756  enddo
2757  enddo
2758  enddo
2759 
2760  do k=1,npz
2761  do j=js,je
2762  do i=is,ie
2763 
2764  !call test2_steady_state_mountain(agrid(i,j,1),agrid(i,j,2),dum, dum2, 0, .true., &
2765  ! 0.5*(ak(k)+ak(k+1)), 0.5*(bk(k)+bk(k+1)), dum3, dum4, dum5, &
2766  ! pt(i,j,k), phis(i,j), ps(i,j), dum6, q(i,j,k,1))
2767  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
2768  !Analytic point-value
2769 !!$ ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
2770 !!$ pt(i,j,k) = t00*(ptmp/p00)**exponent
2771  !ANalytic layer-mean
2772  pt(i,j,k) = -grav*t00*p00/(rdgas*gamma + grav)/delp(i,j,k) * &
2773  ( (pe(i,k,j)/p00)**(exponent+1.) - (pe(i,k+1,j)/p00)**(exponent+1.) )
2774 
2775 
2776  enddo
2777  enddo
2778  enddo
2779 
2780  else if ( abs(test_case)==30 .or. abs(test_case)==31 ) then
2781 !------------------------------------
2782 ! Super-Cell; with or with rotation
2783 !------------------------------------
2784  if ( abs(test_case)==30) then
2785  f0(:,:) = 0.
2786  fc(:,:) = 0.
2787  endif
2788 
2789  zvir = rvgas/rdgas - 1.
2790  p00 = 1000.e2
2791  ps(:,:) = p00
2792  phis(:,:) = 0.
2793  do j=js,je
2794  do i=is,ie
2795  pk(i,j,1) = ptop**kappa
2796  pe(i,1,j) = ptop
2797  peln(i,1,j) = log(ptop)
2798  enddo
2799  enddo
2800 
2801  do k=1,npz
2802  do j=js,je
2803  do i=is,ie
2804  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
2805  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
2806  peln(i,k+1,j) = log(pe(i,k+1,j))
2807  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
2808  enddo
2809  enddo
2810  enddo
2811 
2812  i = is
2813  j = js
2814  do k=1,npz
2815  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2816  enddo
2817 
2818 #ifndef GFS_PHYS
2819  call supercell_sounding(npz, p00, pk1, ts1, qs1)
2820 #endif
2821 
2822  w(:,:,:) = 0.
2823  q(:,:,:,:) = 0.
2824 
2825  pp0(1) = 262.0/180.*pi ! OKC
2826  pp0(2) = 35.0/180.*pi
2827 
2828  do k=1,npz
2829  do j=js,je
2830  do i=is,ie
2831  pt(i,j,k) = ts1(k)
2832  q(i,j,k,1) = qs1(k)
2833  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
2834  enddo
2835  enddo
2836  enddo
2837 
2838  ze1(npz+1) = 0.
2839  do k=npz,1,-1
2840  ze1(k) = ze1(k+1) - delz(is,js,k)
2841  enddo
2842 
2843  us0 = 30.
2844  if (is_master()) then
2845  if (test_case > 0) then
2846  write(6,*) 'Toy supercell winds, piecewise approximation'
2847  else
2848  write(6,*) 'Toy supercell winds, tanh approximation'
2849  endif
2850  endif
2851  do k=1,npz
2852 
2853  zm = 0.5*(ze1(k)+ze1(k+1))
2854  ! Quarter-circle hodograph (Harris approximation)
2855 
2856  if (test_case > 0) then
2857  ! SRH = 40
2858  if ( zm .le. 2.e3 ) then
2859  utmp = 8.*(1.-cos(pi*zm/4.e3))
2860  vtmp = 8.*sin(pi*zm/4.e3)
2861  elseif (zm .le. 6.e3 ) then
2862  utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
2863  vtmp = 8.
2864  else
2865  utmp = us0
2866  vtmp = 8.
2867  endif
2868  ubar = utmp - 8.
2869  vbar = vtmp - 4.
2870  else
2871  ! SRH = 39
2872  utmp = 15.0*(1.+tanh(zm/2000. - 1.5))
2873  vtmp = 8.5*tanh(zm/1000.)
2874  ubar = utmp - 8.5
2875  vbar = vtmp - 4.25
2876 !!$ ! SRH = 45
2877 !!$ utmp = 16.0*(1.+tanh(zm/2000. - 1.4))
2878 !!$ vtmp = 8.5*tanh(zm/1000.)
2879 !!$ ubar = utmp - 10.
2880 !!$ vbar = vtmp - 4.25
2881 !!$ ! SRH = 27 (really)
2882 !!$ utmp = 0.5*us0*(1.+tanh((zm-3500.)/2000.))
2883 !!$ vtmp = 8.*tanh(zm/1000.)
2884 !!$ ubar = utmp - 10.
2885 !!$ vbar = vtmp - 4.
2886  endif
2887 
2888  if( is_master() ) then
2889  write(6,*) k, utmp, vtmp
2890  endif
2891 
2892  do j=js,je
2893  do i=is,ie+1
2894  p1(:) = grid(i ,j ,1:2)
2895  p2(:) = grid(i,j+1 ,1:2)
2896  call mid_pt_sphere(p1, p2, p3)
2897  call get_unit_vect2(p1, p2, e2)
2898  call get_latlon_vector(p3, ex, ey)
2899 ! Scaling factor is a Gaussian decay from center
2900  v(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2901  (ubar*inner_prod(e2,ex) + vbar*inner_prod(e2,ey))
2902  enddo
2903  enddo
2904  do j=js,je+1
2905  do i=is,ie
2906  p1(:) = grid(i, j,1:2)
2907  p2(:) = grid(i+1,j,1:2)
2908  call mid_pt_sphere(p1, p2, p3)
2909  call get_unit_vect2(p1, p2, e1)
2910  call get_latlon_vector(p3, ex, ey)
2911 ! Scaling factor is a Gaussian decay from center
2912  u(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2913  (ubar*inner_prod(e1,ex) + vbar*inner_prod(e1,ey))
2914  enddo
2915  enddo
2916  enddo
2917 
2918  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
2919  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
2920  .true., hydrostatic, nwat, domain, adiabatic)
2921 
2922 ! *** Add Initial perturbation ***
2923  pturb = 2.
2924  r0 = 10.e3 ! radius
2925  zc = 1.4e3 ! center of bubble from surface
2926  do k=1, npz
2927  zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
2928  ptmp = ( (zm-zc)/zc ) **2
2929  if ( ptmp < 1. ) then
2930  do j=js,je
2931  do i=is,ie
2932  dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
2933  if ( dist < 1. ) then
2934  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
2935  endif
2936  enddo
2937  enddo
2938  endif
2939  enddo
2940 
2941  elseif (test_case == 32) then
2942 
2943  call mpp_error(fatal, ' test_case 32 not yet implemented')
2944 
2945  else if ( test_case==33 .or. test_case==34 .or. test_case==35 ) then
2946 !------------------------------------
2947 ! HIWPP M0ountain waves tests
2948 !------------------------------------
2949  f0(:,:) = 0.
2950  fc(:,:) = 0.
2951 
2952  phis(:,:) = 1.e30
2953  ps(:,:) = 1.e30
2954 
2955  zvir = 0.
2956  p00 = 1000.e2
2957  t00 = 300.
2958  us0 = 20.
2959 ! Vertical shear parameter for M3 case:
2960  if ( test_case == 35 ) then
2961  cs_m3 = 2.5e-4
2962  else
2963  cs_m3 = 0.
2964  endif
2965 
2966 ! Mountain height:
2967  h0 = 250.
2968 ! Mountain center
2969  p0(1) = 60./180. * pi
2970  p0(2) = 0.
2971 ! 9-point average:
2972 ! 9 4 8
2973 !
2974 ! 5 1 3
2975 !
2976 ! 6 2 7
2977 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
2978  if ( test_case==35 ) then
2979  dum = -cs_m3/grav
2980  do j=js,je
2981  do i=is,ie
2982 ! temperature is function of latitude (due to vertical shear)
2983 #ifdef USE_CELL_AVG
2984  p2(2) = agrid(i,j,2)
2985  pt1 = exp( dum*(us0*sin(p2(2)))**2 )
2986  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2987  pt2 = exp( dum*(us0*sin(p2(2)))**2 )
2988  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2989  pt3 = exp( dum*(us0*sin(p2(2)))**2 )
2990  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
2991  pt4 = exp( dum*(us0*sin(p2(2)))**2 )
2992  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
2993  pt5 = exp( dum*(us0*sin(p2(2)))**2 )
2994  p2(2) = grid(i,j,2)
2995  pt6 = exp( dum*(us0*sin(p2(2)))**2 )
2996  p2(2) = grid(i+1,j,2)
2997  pt7 = exp( dum*(us0*sin(p2(2)))**2 )
2998  p2(2) = grid(i+1,j+1,2)
2999  pt8 = exp( dum*(us0*sin(p2(2)))**2 )
3000  p2(2) = grid(i,j+1,2)
3001  pt9 = exp( dum*(us0*sin(p2(2)))**2 )
3002  ptmp = t00*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3003 #else
3004  ptmp = t00*exp( dum*(us0*sin(agrid(i,j,2)))**2 )
3005 #endif
3006  do k=1,npz
3007  pt(i,j,k) = ptmp
3008  enddo
3009  enddo
3010  enddo
3011  else
3012  pt(:,:,:) = t00
3013  endif
3014 
3015  if( test_case==33 ) then
3016 ! NCAR Ridge-mountain Mods:
3017  do j=js,je
3018  do i=is,ie
3019 #ifdef USE_CELL_AVG
3020  p2(1:2) = agrid(i,j,1:2)
3021  r = radius*(p2(1)-p0(1))
3022  pt1 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3023  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
3024  r = radius*(p2(1)-p0(1))
3025  pt2 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3026  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
3027  r = radius*(p2(1)-p0(1))
3028  pt3 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3029  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
3030  r = radius*(p2(1)-p0(1))
3031  pt4 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3032  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3033  r = radius*(p2(1)-p0(1))
3034  pt5 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3035  p2(1:2) = grid(i,j,1:2)
3036  r = radius*(p2(1)-p0(1))
3037  pt6 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3038  p2(1:2) = grid(i+1,j,1:2)
3039  r = radius*(p2(1)-p0(1))
3040  pt7 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3041  p2(1:2) = grid(i+1,j+1,1:2)
3042  r = radius*(p2(1)-p0(1))
3043  pt8 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3044  p2(1:2) = grid(i,j+1,1:2)
3045  r = radius*(p2(1)-p0(1))
3046  pt9 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3047  phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3048 #else
3049  p2(1:2) = agrid(i,j,1:2)
3050  r = radius*(p2(1)-p0(1))
3051  phis(i,j) = grav*h0*cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3052 #endif
3053  enddo
3054  enddo
3055  else
3056 ! Circular mountain:
3057  do j=js,je
3058  do i=is,ie
3059 ! 9-point average:
3060 ! 9 4 8
3061 !
3062 ! 5 1 3
3063 !
3064 ! 6 2 7
3065 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
3066 #ifdef USE_CELL_AVG
3067  r = great_circle_dist( p0, agrid(i,j,1:2), radius )
3068  pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3069  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
3070  r = great_circle_dist( p0, p2, radius )
3071  pt2 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3072  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
3073  r = great_circle_dist( p0, p2, radius )
3074  pt3 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3075  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
3076  r = great_circle_dist( p0, p2, radius )
3077  pt4 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3078  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3079  r = great_circle_dist( p0, p2, radius )
3080  pt5 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3081  r = great_circle_dist( p0, grid(i,j,1:2), radius )
3082  pt6 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3083  r = great_circle_dist( p0, grid(i+1,j,1:2), radius )
3084  pt7 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3085  r = great_circle_dist( p0, grid(i+1,j+1,1:2), radius )
3086  pt8 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3087  r = great_circle_dist( p0, grid(i,j+1,1:2), radius )
3088  pt9 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3089  phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
3090 #else
3091  r = great_circle_dist( p0, agrid(i,j,1:2), radius )
3092  pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3093  phis(i,j) = grav*h0*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
3094 #endif
3095  enddo
3096  enddo
3097  endif
3098 
3099  do j=js,je
3100  do i=is,ie
3101 ! DCMIP Eq(33)
3102  ps(i,j) = p00*exp( -0.5*(us0*sin(agrid(i,j,2)))**2/(rdgas*t00)-phis(i,j)/(rdgas*pt(i,j,1)) )
3103  pe(i,1,j) = ptop
3104  peln(i,1,j) = log(ptop)
3105  pk(i,j,1) = ptop**kappa
3106  enddo
3107  enddo
3108 
3109  do k=2,npz+1
3110  do j=js,je
3111  do i=is,ie
3112  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
3113  peln(i,k,j) = log(pe(i,k,j))
3114  pk(i,j,k) = exp( kappa*peln(i,k,j) )
3115  enddo
3116  enddo
3117  enddo
3118 
3119  do k=1,npz
3120  do j=js,je
3121  do i=is,ie
3122  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3123  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
3124  enddo
3125  enddo
3126  enddo
3127 
3128 ! Comnpute mid-level height, using w for temp storage
3129  do j=js,je
3130  do i=is,ie
3131  ze1(npz+1) = phis(i,j)/grav
3132  do k=npz,1,-1
3133  ze1(k) = ze1(k+1) - delz(i,j,k)
3134  enddo
3135  do k=1,npz
3136  w(i,j,k) = 0.5*(ze1(k)+ze1(k+1))
3137  enddo
3138  enddo
3139  enddo
3140  call mpp_update_domains( w, domain )
3141 
3142  do k=1,npz
3143  do j=js,je
3144  do i=is,ie+1
3145  p1(:) = grid(i ,j, 1:2)
3146  p2(:) = grid(i,j+1, 1:2)
3147  call mid_pt_sphere(p1, p2, p3)
3148  call get_unit_vect2(p1, p2, e2)
3149  call get_latlon_vector(p3, ex, ey)
3150 ! Joe Klemp's mod:
3151  utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i-1,j,k)+w(i,j,k)) )
3152  v(i,j,k) = utmp*inner_prod(e2,ex)
3153  enddo
3154  enddo
3155  do j=js,je+1
3156  do i=is,ie
3157  p1(:) = grid(i, j, 1:2)
3158  p2(:) = grid(i+1,j, 1:2)
3159  call mid_pt_sphere(p1, p2, p3)
3160  call get_unit_vect2(p1, p2, e1)
3161  call get_latlon_vector(p3, ex, ey)
3162  utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i,j-1,k)+w(i,j,k)) )
3163  u(i,j,k) = utmp*inner_prod(e1,ex)
3164  enddo
3165  enddo
3166  enddo
3167 
3168  w(:,:,:) = 0. ! reset w
3169  q(:,:,:,:) = 0.
3170 
3171  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3172  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
3173  .true., hydrostatic, nwat, domain, adiabatic)
3174 
3175  else if ( test_case==36 .or. test_case==37 ) then
3176 !------------------------------------
3177 ! HIWPP Super-Cell
3178 !------------------------------------
3179 ! HIWPP SUPER_K;
3180  f0(:,:) = 0.
3181  fc(:,:) = 0.
3182  q(:,:,:,:) = 0.
3183  w(:,:,:) = 0.
3184 
3185  zvir = rvgas/rdgas - 1.
3186  p00 = 1000.e2
3187  pk0 = p00**kappa
3188  ps(:,:) = p00
3189  phis(:,:) = 0.
3190 !
3191 ! Set up vertical layer spacing:
3192  ztop = 20.e3
3193  ze1(1) = ztop
3194  ze1(npz+1) = 0.
3195 #ifndef USE_VAR_DZ
3196 ! Truly uniform setup:
3197  do k=npz,2,-1
3198  ze1(k) = ze1(k+1) + ztop/real(npz)
3199  enddo
3200 #else
3201 ! Lowest layer half of the size
3202 ! ze1(npz) = ztop / real(2*npz-1) ! lowest layer thickness
3203 ! zm = (ztop-ze1(npz)) / real(npz-1)
3204 ! do k=npz,2,-1
3205 ! ze1(k) = ze1(k+1) + zm
3206 ! enddo
3207  call var_dz(npz, ztop, ze1)
3208 #endif
3209  do k=1,npz
3210  zs1(k) = 0.5*(ze1(k)+ze1(k+1))
3211  enddo
3212 !-----
3213 ! Get sounding at "equator": initial storm center
3214  call superk_sounding(npz, pe1, p00, ze1, ts1, qs1)
3215 ! ts1 is FV's definition of potential temperature at EQ
3216 
3217  do k=1,npz
3218  ts1(k) = cp_air*ts1(k)*(1.+zvir*qs1(k)) ! cp*thelta_v
3219  enddo
3220 ! Initialize the fields on z-coordinate; adjust top layer mass
3221 ! Iterate then interpolate to get balanced pt & pk on the sphere
3222 ! Adjusting ptop
3223  call superk_u(npz, zs1, uz1, dudz)
3224  call balanced_k(npz, is, ie, js, je, ng, pe1(npz+1), ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
3225  delz, zvir, ptop, ak, bk, agrid)
3226  do j=js,je
3227  do i=is,ie
3228  ps(i,j) = pe(i,npz+1,j)
3229  enddo
3230  enddo
3231 
3232  do k=1,npz+1
3233  do j=js,je
3234  do i=is,ie
3235  peln(i,k,j) = log(pe(i,k,j))
3236  pk(i,j,k) = exp( kappa*peln(i,k,j) )
3237  enddo
3238  enddo
3239  enddo
3240 
3241  do k=1,npz
3242  do j=js,je
3243  do i=is,ie
3244  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3245  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3246  q(i,j,k,1) = qs1(k)
3247  enddo
3248  enddo
3249  enddo
3250 
3251  k = 1 ! keep the same temperature but adjust the height at the top layer
3252  do j=js,je
3253  do i=is,ie
3254  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
3255  enddo
3256  enddo
3257 ! Adjust temperature; enforce constant dz except the top layer
3258  do k=2,npz
3259  do j=js,je
3260  do i=is,ie
3261  delz(i,j,k) = ze1(k+1) - ze1(k)
3262  pt(i,j,k) = delz(i,j,k)*grav/(rdgas*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)))
3263  enddo
3264  enddo
3265  enddo
3266 
3267 ! Wind-profile:
3268  do k=1,npz
3269  do j=js,je
3270  do i=is,ie+1
3271  p1(:) = grid(i ,j ,1:2)
3272  p2(:) = grid(i,j+1 ,1:2)
3273  call mid_pt_sphere(p1, p2, p3)
3274  call get_unit_vect2(p1, p2, e2)
3275  call get_latlon_vector(p3, ex, ey)
3276  v(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e2,ex)
3277  enddo
3278  enddo
3279  do j=js,je+1
3280  do i=is,ie
3281  p1(:) = grid(i, j,1:2)
3282  p2(:) = grid(i+1,j,1:2)
3283  call mid_pt_sphere(p1, p2, p3)
3284  call get_unit_vect2(p1, p2, e1)
3285  call get_latlon_vector(p3, ex, ey)
3286  u(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e1,ex)
3287  enddo
3288  enddo
3289  enddo
3290 
3291 ! *** Add Initial perturbation ***
3292  if ( test_case == 37 ) then
3293  pp0(1) = pi
3294  pp0(2) = 0.
3295  if (adiabatic) then
3296  pturb = 10.
3297  else
3298  pturb = 3. ! potential temperature
3299  endif
3300  r0 = 10.e3 ! radius
3301  zc = 1.5e3 ! center of bubble from surface
3302  do k=1, npz
3303  zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
3304  ptmp = ( (zm-zc)/zc ) **2
3305  if ( ptmp < 1. ) then
3306  do j=js,je
3307  do i=is,ie
3308  dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
3309  dist = sqrt(dist)
3310  if ( dist < 1. ) then
3311  pt(i,j,k) = pt(i,j,k) + (pkz(i,j,k)/pk0)*pturb*cos(0.5*pi*dist)**2
3312  endif
3313  enddo
3314  enddo
3315  endif
3316  enddo
3317  endif
3318 
3319  else if (test_case == 44) then ! Lock-exchange K-H instability on a very large-scale
3320 
3321  !Background state
3322  p00 = 1000.e2
3323  ps(:,:) = p00
3324  phis = 0.0
3325  u(:,:,:) = 0.
3326  v(:,:,:) = 0.
3327  q(:,:,:,:) = 0.
3328 
3329  if (adiabatic) then
3330  zvir = 0.
3331  else
3332  zvir = rvgas/rdgas - 1.
3333  endif
3334 
3335 ! Initialize delta-P
3336  do z=1,npz
3337  do j=js,je
3338  do i=is,ie
3339  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3340  enddo
3341  enddo
3342  enddo
3343 
3344  do j=js,je
3345  do i=is,ie
3346  pe(i,1,j) = ptop
3347  peln(i,1,j) = log(pe(i,1,j))
3348  pk(i,j,1) = exp(kappa*peln(i,1,j))
3349  enddo
3350  do k=2,npz+1
3351  do i=is,ie
3352  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3353  peln(i,k,j) = log(pe(i,k,j))
3354  pk(i,j,k) = exp(kappa*peln(i,k,j))
3355  enddo
3356  enddo
3357  enddo
3358 
3359  p1(1) = pi
3360  p1(2) = 0.
3361  r0 = 1000.e3 ! hurricane size
3362 
3363  do k=1,npz
3364  do j=js,je
3365  do i=is,ie
3366  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3367  dist = great_circle_dist( p0, agrid(i,j,1:2), radius )
3368  if ( dist .le. r0 ) then
3369  pt(i,j,k) = 275.
3370  q(i,j,k,1) = 1.
3371  else
3372  pt(i,j,k) = 265.
3373  q(i,j,k,1) = 0.
3374  end if
3375 ! pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3376  enddo
3377  enddo
3378  enddo
3379 
3380  if (.not.hydrostatic) then
3381  do k=1,npz
3382  do j=js,je
3383  do i=is,ie
3384  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))
3385  w(i,j,k) = 0.0
3386  enddo
3387  enddo
3388  enddo
3389  endif
3390 
3391  else if (test_case == 45 .or. test_case == 46) then ! NGGPS test?
3392 
3393 ! Background state
3394  f0 = 0.; fc = 0.
3395  pt0 = 300. ! potentil temperature
3396  p00 = 1000.e2
3397  ps(:,:) = p00
3398  phis = 0.0
3399  u(:,:,:) = 0.
3400  v(:,:,:) = 0.
3401  q(:,:,:,:) = 0.
3402 
3403  if (adiabatic) then
3404  zvir = 0.
3405  else
3406  zvir = rvgas/rdgas - 1.
3407  endif
3408 
3409 ! Initialize delta-P
3410  do k=1,npz
3411  do j=js,je
3412  do i=is,ie
3413  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
3414  enddo
3415  enddo
3416  enddo
3417 
3418  do j=js,je
3419  do i=is,ie
3420  pe(i,1,j) = ptop
3421  peln(i,1,j) = log(pe(i,1,j))
3422  pk(i,j,1) = exp(kappa*peln(i,1,j))
3423  enddo
3424  do k=2,npz+1
3425  do i=is,ie
3426  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3427  peln(i,k,j) = log(pe(i,k,j))
3428  pk(i,j,k) = exp(kappa*peln(i,k,j))
3429  enddo
3430  enddo
3431  enddo
3432 
3433 ! Initiate the westerly-wind-burst:
3434  ubar = soliton_umax
3435  r0 = soliton_size
3436 !!$ if (test_case == 46) then
3437 !!$ ubar = 200.
3438 !!$ r0 = 250.e3
3439 !!$ else
3440 !!$ ubar = 50. ! Initial maxmium wind speed (m/s)
3441 !!$ r0 = 500.e3
3442 !!$ endif
3443  p0(1) = pi*0.5
3444  p0(2) = 0.
3445 
3446  do k=1,npz
3447  do j=js,je
3448  do i=is,ie+1
3449  p1(:) = grid(i ,j ,1:2)
3450  p2(:) = grid(i,j+1 ,1:2)
3451  call mid_pt_sphere(p1, p2, p3)
3452  r = great_circle_dist( p0, p3, radius )
3453  utmp = ubar*exp(-(r/r0)**2)
3454  call get_unit_vect2(p1, p2, e2)
3455  call get_latlon_vector(p3, ex, ey)
3456  v(i,j,k) = utmp*inner_prod(e2,ex)
3457  enddo
3458  enddo
3459  do j=js,je+1
3460  do i=is,ie
3461  p1(:) = grid(i, j,1:2)
3462  p2(:) = grid(i+1,j,1:2)
3463  call mid_pt_sphere(p1, p2, p3)
3464  r = great_circle_dist( p0, p3, radius )
3465  utmp = ubar*exp(-(r/r0)**2)
3466  call get_unit_vect2(p1, p2, e1)
3467  call get_latlon_vector(p3, ex, ey)
3468  u(i,j,k) = utmp*inner_prod(e1,ex)
3469  enddo
3470  enddo
3471 
3472  do j=js,je
3473  do i=is,ie
3474  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3475 #ifdef USE_PT
3476  pt(i,j,k) = pt0/p00**kappa
3477 ! Convert back to temperature:
3478  pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3479 #else
3480  pt(i,j,k) = pt0
3481 #endif
3482  q(i,j,k,1) = 0.
3483  enddo
3484  enddo
3485 
3486  enddo
3487 
3488 #ifdef NEST_TEST
3489  do k=1,npz
3490  do j=js,je
3491  do i=is,ie
3492  q(i,j,k,:) = agrid(i,j,1)*0.180/pi
3493  enddo
3494  enddo
3495  enddo
3496 #else
3497  call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
3498  ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
3499 #endif
3500 
3501  if ( .not. hydrostatic ) then
3502  do k=1,npz
3503  do j=js,je
3504  do i=is,ie
3505  delz(i,j,k) = rdgas*pt(i,j,k)/grav*log(pe(i,k,j)/pe(i,k+1,j))
3506  w(i,j,k) = 0.0
3507  enddo
3508  enddo
3509  enddo
3510  endif
3511  else if (test_case == 55 .or. test_case == 56 .or. test_case == 57) then
3512 
3513  !Tropical cyclone test case: DCMIP 5X
3514 
3515  !test_case 56 initializes the environment
3516  ! but no vortex
3517 
3518  !test_case 57 uses a globally-uniform f-plane
3519 
3520  ! Initialize surface Pressure
3521  !Vortex perturbation
3522  p0(1) = 180. * pi / 180.
3523  p0(2) = 10. * pi / 180.
3524 
3525  if (test_case == 56) then
3526  dp = 0.
3527  rp = 1.e25
3528  else
3529  dp = 1115.
3530  rp = 282000.
3531  endif
3532  p00 = 101500.
3533 
3534  ps = p00
3535 
3536  do j=js,je
3537  do i=is,ie
3538  p2(:) = agrid(i,j,1:2)
3539  r = great_circle_dist( p0, p2, radius )
3540  ps(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3541  phis(i,j) = 0.
3542  enddo
3543  enddo
3544 
3545  call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3546 
3547  ! Initialize delta-P
3548  do z=1,npz
3549  do j=js,je
3550  do i=is,ie
3551  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3552  enddo
3553  enddo
3554  enddo
3555 
3556  !Pressure
3557  do j=js,je
3558  do i=is,ie
3559  pe(i,1,j) = ptop
3560  enddo
3561  do k=2,npz+1
3562  do i=is,ie
3563  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3564  enddo
3565  enddo
3566  enddo
3567 
3568  !Pressure on v-grid and u-grid points
3569  do j=js,je
3570  do i=is,ie+1
3571  p2(:) = 0.5*(grid(i,j,1:2)+grid(i,j+1,1:2))
3572  r = great_circle_dist( p0, p2, radius )
3573  ps_v(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3574  enddo
3575  enddo
3576  do j=js,je+1
3577  do i=is,ie
3578  p2(:) = 0.5*(grid(i,j,1:2)+grid(i+1,j,1:2))
3579  r = great_circle_dist( p0, p2, radius )
3580  ps_u(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3581  enddo
3582  enddo
3583 
3584  !Pressure
3585  do j=js,je
3586  do i=is,ie+1
3587  pe_v(i,1,j) = ptop
3588  enddo
3589  do k=2,npz+1
3590  do i=is,ie+1
3591  pe_v(i,k,j) = ak(k) + ps_v(i,j)*bk(k)
3592  enddo
3593  enddo
3594  enddo
3595  do j=js,je+1
3596  do i=is,ie
3597  pe_u(i,1,j) = ptop
3598  enddo
3599  do k=2,npz+1
3600  do i=is,ie
3601  pe_u(i,k,j) = ak(k) + ps_u(i,j)*bk(k)
3602  enddo
3603  enddo
3604  enddo
3605 
3606  !Everything else
3607  !if (adiabatic) then
3608  ! zvir = 0.
3609  !else
3610  zvir = rvgas/rdgas - 1.
3611  !endif
3612 
3613  p0 = (/ pi, pi/18. /)
3614 
3615  exppr = 1.5
3616  exppz = 2.
3617  gamma = 0.007
3618  ts0 = 302.15
3619  q00 = 0.021
3620  t00 = ts0*(1.+zvir*q00)
3621  exponent = rdgas*gamma/grav
3622  ztrop = 15000.
3623  zp = 7000.
3624  dp = 1115.
3625  cor = 2.*omega*sin(p0(2)) !Coriolis at vortex center
3626 
3627  !Initialize winds separately on the D-grid
3628  do j=js,je
3629  do i=is,ie+1
3630  p1(:) = grid(i ,j ,1:2)
3631  p2(:) = grid(i,j+1 ,1:2)
3632  call mid_pt_sphere(p1, p2, p3)
3633  call get_unit_vect2(p1, p2, e2)
3634  call get_latlon_vector(p3, ex, ey)
3635 
3636  d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3637  d2 = cos(p0(2))*sin(p3(1)-p0(1))
3638  d = max(1.e-15,sqrt(d1**2+d2**2))
3639 
3640  r = great_circle_dist( p0, p3, radius )
3641 
3642  do k=1,npz
3643  ptmp = 0.5*(pe_v(i,k,j)+pe_v(i,k+1,j))
3644  height = (t00/gamma)*(1.-(ptmp/ps_v(i,j))**exponent)
3645  if (height > ztrop) then
3646  v(i,j,k) = 0.
3647  else
3648  utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3649  - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3650  /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3651  +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3652  vtmp = utmp*d2
3653  utmp = utmp*d1
3654 
3655  v(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
3656 
3657  endif
3658  enddo
3659  enddo
3660  enddo
3661  do j=js,je+1
3662  do i=is,ie
3663  p1(:) = grid(i, j,1:2)
3664  p2(:) = grid(i+1,j,1:2)
3665  call mid_pt_sphere(p1, p2, p3)
3666  call get_unit_vect2(p1, p2, e1)
3667  call get_latlon_vector(p3, ex, ey)
3668 
3669  d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3670  d2 = cos(p0(2))*sin(p3(1)-p0(1))
3671  d = max(1.e-15,sqrt(d1**2+d2**2))
3672 
3673  r = great_circle_dist( p0, p3, radius )
3674 
3675  do k=1,npz
3676  ptmp = 0.5*(pe_u(i,k,j)+pe_u(i,k+1,j))
3677  height = (t00/gamma)*(1.-(ptmp/ps_u(i,j))**exponent)
3678  if (height > ztrop) then
3679  v(i,j,k) = 0.
3680  else
3681  utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3682  - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3683  /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3684  +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3685  vtmp = utmp*d2
3686  utmp = utmp*d1
3687 
3688  u(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
3689  endif
3690  enddo
3691 
3692  enddo
3693  enddo
3694 
3695  qtrop = 1.e-11
3696  ttrop = t00 - gamma*ztrop
3697  zq1 = 3000.
3698  zq2 = 8000.
3699 
3700  q(:,:,:,:) = 0.
3701 
3702  do k=1,npz
3703  do j=js,je
3704  do i=is,ie
3705  ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
3706  height = (t00/gamma)*(1.-(ptmp/ps(i,j))**exponent)
3707  if (height > ztrop) then
3708  q(i,j,k,1) = qtrop
3709  pt(i,j,k) = ttrop
3710  else
3711  q(i,j,k,1) = q00*exp(-height/zq1)*exp(-(height/zq2)**exppz)
3712  p2(:) = agrid(i,j,1:2)
3713  r = great_circle_dist( p0, p2, radius )
3714  pt(i,j,k) = (t00-gamma*height)/(1.d0+zvir*q(i,j,k,1))/(1.d0+exppz*rdgas*(t00-gamma*height)*height &
3715  /(grav*zp**exppz*(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz))))
3716  end if
3717  enddo
3718  enddo
3719  enddo
3720 
3721  !Note that this is already the moist pressure
3722  do j=js,je
3723  do i=is,ie
3724  ps(i,j) = pe(i,npz+1,j)
3725  enddo
3726  enddo
3727 
3728  if (.not.hydrostatic) then
3729  do k=1,npz
3730  do j=js,je
3731  do i=is,ie
3732  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))
3733  w(i,j,k) = 0.0
3734  enddo
3735  enddo
3736  enddo
3737  endif
3738 
3739  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng, bd)
3740 
3741  call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3742 
3743  if (test_case == 57) then
3744  do j=jsd,jed+1
3745  do i=isd,ied+1
3746  fc(i,j) = cor
3747  enddo
3748  enddo
3749  do j=jsd,jed
3750  do i=isd,ied
3751  f0(i,j) = cor
3752  enddo
3753  enddo
3754  endif
3755 
3756 
3757  else if ( test_case == -55 ) then
3758 
3759  call dcmip16_tc (delp, pt, u, v, q, w, delz, &
3760  is, ie, js, je, isd, ied, jsd, jed, npz, ncnst, &
3761  ak, bk, ptop, pk, peln, pe, pkz, gz, phis, &
3762  ps, grid, agrid, hydrostatic, nwat, adiabatic)
3763 
3764  else
3765 
3766  call mpp_error(fatal, " test_case not defined" )
3767 
3768  endif !test_case
3769 
3770  call mpp_update_domains( phis, domain )
3771 
3772  ftop = g_sum(domain, phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
3773  if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav
3774 
3775 ! The flow is initially hydrostatic
3776 #ifndef SUPER_K
3777  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3778  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., mountain, &
3779  moist_phys, hydrostatic, nwat, domain, adiabatic, .not.hydrostatic)
3780 #endif
3781 
3782 #ifdef COLUMN_TRACER
3783  if( ncnst>1 ) q(:,:,:,2:ncnst) = 0.0
3784  ! Initialize a dummy Column Tracer
3785  pcen(1) = pi/9.
3786  pcen(2) = 2.0*pi/9.
3787  r0 = radius/10.0
3788  do z=1,npz
3789  do j=js,je
3790  do i=is,ie
3791  p1(:) = grid(i ,j ,1:2)
3792  p2(:) = grid(i,j+1 ,1:2)
3793  call mid_pt_sphere(p1, p2, pa)
3794  call get_unit_vect2(p1, p2, e2)
3795  call get_latlon_vector(pa, ex, ey)
3796  ! Perturbation Location Case==13
3797  r = great_circle_dist( pcen, pa, radius )
3798  if (-(r/r0)**2.0 > -40.0) q(i,j,z,1) = exp(-(r/r0)**2.0)
3799  enddo
3800  enddo
3801  enddo
3802 #endif
3803 
3804 #endif
3805  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
3806 
3807 
3808  nullify(agrid)
3809  nullify(grid)
3810 
3811  nullify(area)
3812  nullify(rarea)
3813 
3814  nullify(fc)
3815  nullify(f0)
3816 
3817  nullify(dx)
3818  nullify(dy)
3819  nullify(dxa)
3820  nullify(dya)
3821  nullify(rdxa)
3822  nullify(rdya)
3823  nullify(dxc)
3824  nullify(dyc)
3825 
3826  nullify(ee1)
3827  nullify(ee2)
3828  nullify(ew)
3829  nullify(es)
3830  nullify(en1)
3831  nullify(en2)
3832 
3833  nullify(latlon)
3834  nullify(cubed_sphere)
3835 
3836  nullify(domain)
3837  nullify(tile)
3838 
3839  nullify(have_south_pole)
3840  nullify(have_north_pole)
3841 
3842  nullify(ntiles_g)
3843  nullify(acapn)
3844  nullify(acaps)
3845  nullify(globalarea)
3846 
3847  end subroutine init_case
3848 
3849  subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
3850  integer isd, ied, jsd, jed, npz
3851  integer isc, iec, jsc, jec
3852  real, intent(in) :: u(isd:ied, jsd:jed+1, npz), v(isd:ied+1, jsd:jed, npz)
3853  real, intent(out) :: vort(isc:iec, jsc:jec, npz)
3854  real, intent(IN) :: dx(isd:ied,jsd:jed+1)
3855  real, intent(IN) :: dy(isd:ied+1,jsd:jed)
3856  real, intent(IN) :: rarea(isd:ied,jsd:jed)
3857 ! Local
3858  real :: utmp(isc:iec, jsc:jec+1), vtmp(isc:iec+1, jsc:jec)
3859  integer :: i,j,k
3860 
3861  do k=1,npz
3862  do j=jsc,jec+1
3863  do i=isc,iec
3864  utmp(i,j) = u(i,j,k)*dx(i,j)
3865  enddo
3866  enddo
3867  do j=jsc,jec
3868  do i=isc,iec+1
3869  vtmp(i,j) = v(i,j,k)*dy(i,j)
3870  enddo
3871  enddo
3872 
3873  do j=jsc,jec
3874  do i=isc,iec
3875  vort(i,j,k) = rarea(i,j)*(utmp(i,j)-utmp(i,j+1)-vtmp(i,j)+vtmp(i+1,j))
3876  enddo
3877  enddo
3878  enddo
3879 
3880  end subroutine get_vorticity
3881 
3882  subroutine checker_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3883  nq, km, q, lon, lat, nx, ny, rn)
3884 !--------------------------------------------------------------------
3885 ! This routine computes the checker-board tracer pattern with optional
3886 ! random pertubation (if rn/= 0)
3887 ! To get 20 (deg) by 20 (deg) checker boxes: nx=9, ny=9
3888 ! If random noises are desired, rn=0.1 is a good value
3889 ! lon: longitude (Radian)
3890 ! lat: latitude (Radian)
3891 ! Coded by S.-J. Lin for HIWPP benchmark, Oct2, 2014
3892 !--------------------------------------------------------------------
3893  integer, intent(in):: nq ! number of tracers
3894  integer, intent(in):: km ! vertical dimension
3895  integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3896  integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3897  integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3898  real, intent(in):: nx ! east-west wave number
3899  real, intent(in):: ny ! North-south wave number
3900  real, intent(in), optional:: rn ! (optional) magnitude of random perturbation
3901  real(kind=R_GRID), intent(in), dimension(i0:i1,j0:j1):: lon, lat
3902  real, intent(out):: q(ifirst:ilast,jfirst:jlast,km,nq)
3903 ! Local var:
3904  real:: qt(i0:i1,j0:j1)
3905  real:: qtmp, ftmp
3906  integer:: i,j,k,iq
3907 
3908 !$OMP parallel do default(none) shared(i0,i1,j0,j1,nx,lon,ny,lat,qt) &
3909 !$OMP private(qtmp)
3910  do j=j0,j1
3911  do i=i0,i1
3912  qtmp = sin(nx*lon(i,j))*sin(ny*lat(i,j))
3913  if ( qtmp < 0. ) then
3914  qt(i,j) = 0.
3915  else
3916  qt(i,j) = 1.
3917  endif
3918  enddo
3919  enddo
3920 
3921  if ( present(rn) ) then ! Add random noises to the set pattern
3922  do iq=1,nq
3923  call random_seed()
3924 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,rn,iq) &
3925 !$OMP private(ftmp)
3926  do k=1,km
3927  do j=j0,j1
3928  do i=i0,i1
3929  call random_number(ftmp)
3930  q(i,j,k,iq) = qt(i,j) + rn*ftmp
3931  enddo
3932  enddo
3933  enddo
3934  enddo
3935  else
3936  do iq=1,nq
3937 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,iq) &
3938 !$OMP private(ftmp)
3939  do k=1,km
3940  do j=j0,j1
3941  do i=i0,i1
3942  q(i,j,k,iq) = qt(i,j)
3943  enddo
3944  enddo
3945  enddo
3946  enddo
3947  endif
3948 
3949  end subroutine checker_tracers
3950 
3951  subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3952  km, q, delp, ncnst, lon, lat, bd)
3953 !--------------------------------------------------------------------
3954 ! This routine implements the terminator test.
3955 ! Coded by Lucas Harris for DCMIP 2016, May 2016
3956 ! NOTE: Implementation assumes DRY mixing ratio!!!
3957 !--------------------------------------------------------------------
3958  type(fv_grid_bounds_type), intent(IN) :: bd
3959  integer, intent(in):: km ! vertical dimension
3960  integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3961  integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3962  integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3963  integer, intent(in):: ncnst
3964  real(kind=R_GRID), intent(in), dimension(ifirst:ilast,jfirst:jlast):: lon, lat
3965  real, intent(inout):: q(ifirst:ilast,jfirst:jlast,km,ncnst)
3966  real, intent(in):: delp(ifirst:ilast,jfirst:jlast,km)
3967 ! Local var:
3968  real:: D, k1, r, ll, sinthc, costhc, mm
3969  integer:: i,j,k
3970  integer:: Cl, Cl2
3971 
3972  !NOTE: If you change the reaction rates, then you will have to change it both
3973  ! here and in fv_phys
3974  real, parameter :: qcly = 4.e-6
3975  real, parameter :: lc = 5.*pi/3.
3976  real, parameter :: thc = pi/9.
3977  real, parameter :: k2 = 1.
3978 
3979  sinthc = sin(thc)
3980  costhc = cos(thc)
3981 
3982  cl = get_tracer_index(model_atmos, 'Cl')
3983  cl2 = get_tracer_index(model_atmos, 'Cl2')
3984 
3985  do j=j0,j1
3986  do i=i0,i1
3987  k1 = max(0., sin(lat(i,j))*sinthc + cos(lat(i,j))*costhc*cos(lon(i,j) - lc))
3988  r = k1/k2 * 0.25
3989  d = sqrt(r*r + 2.*r*qcly)
3990  q(i,j,1,cl) = d - r
3991  q(i,j,1,cl2) = 0.5*(qcly - q(i,j,1,cl))
3992  enddo
3993  enddo
3994 
3995  do k=2,km
3996  do j=j0,j1
3997  do i=i0,i1
3998  q(i,j,k,cl) = q(i,j,1,cl)
3999  q(i,j,k,cl2) = q(i,j,1,cl2)
4000  enddo
4001  enddo
4002  enddo
4003 
4004  !Compute qcly0
4005  qcly0 = 0.
4006  if (is_master()) then
4007  i = bd%is
4008  j = bd%js
4009  mm = 0.
4010  do k=1,km
4011  qcly0 = qcly0 + (q(i,j,k,cl) + 2.*q(i,j,k,cl2))*delp(i,j,k)
4012  mm = mm + delp(i,j,k)
4013  enddo
4014  qcly0 = qcly0/mm
4015  endif
4016  call mpp_sum(qcly0)
4017  if (is_master()) print*, ' qcly0 = ', qcly0
4018 
4019 
4020 end subroutine terminator_tracers
4021 
4022  subroutine rankine_vortex(ubar, r0, p1, u, v, grid, bd )
4023 !----------------------------
4024 ! Rankine vortex
4025 !----------------------------
4026  type(fv_grid_bounds_type), intent(IN) :: bd
4027 
4028  real, intent(in):: ubar ! max wind (m/s)
4029  real, intent(in):: r0 ! Radius of max wind (m)
4030  real, intent(in):: p1(2) ! center position (longitude, latitude) in radian
4031  real, intent(inout):: u(bd%isd:bd%ied, bd%jsd:bd%jed+1)
4032  real, intent(inout):: v(bd%isd:bd%ied+1,bd%jsd:bd%jed)
4033  real(kind=R_GRID), intent(IN) :: grid(bd%isd:bd%ied+1,bd%jsd:bd%jed+1,2)
4034 ! local:
4035  real(kind=R_GRID):: p2(2), p3(2), p4(2)
4036  real(kind=R_GRID):: e1(3), e2(3), ex(3), ey(3)
4037  real:: vr, r, d2, cos_p, x1, y1
4038  real:: utmp, vtmp
4039  integer i, j
4040 
4041  integer :: is, ie, js, je
4042  integer :: isd, ied, jsd, jed
4043 
4044  is = bd%is
4045  ie = bd%ie
4046  js = bd%js
4047  je = bd%je
4048  isd = bd%isd
4049  ied = bd%ied
4050  jsd = bd%jsd
4051  jed = bd%jed
4052 
4053 ! Compute u-wind
4054  do j=js,je+1
4055  do i=is,ie
4056  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
4057 ! shift:
4058  p2(1) = p2(1) - p1(1)
4059  cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
4060  r = radius*acos(cos_p) ! great circle distance
4061 ! if( r<0.) call mpp_error(FATAL, 'radius negative!')
4062  if( r<r0 ) then
4063  vr = ubar*r/r0
4064  else
4065  vr = ubar*r0/r
4066  endif
4067  x1 = cos(p2(2))*sin(p2(1))
4068  y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
4069  d2 = max(1.e-25, sqrt(x1**2 + y1**2))
4070  utmp = -vr*y1/d2
4071  vtmp = vr*x1/d2
4072  p3(1) = grid(i,j, 1) - p1(1)
4073  p3(2) = grid(i,j, 2)
4074  p4(1) = grid(i+1,j,1) - p1(1)
4075  p4(2) = grid(i+1,j,2)
4076  call get_unit_vect2(p3, p4, e1)
4077  call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
4078  u(i,j) = u(i,j) + utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4079  enddo
4080  enddo
4081 
4082 ! Compute v-wind
4083  do j=js,je
4084  do i=is,ie+1
4085  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
4086 ! shift:
4087  p2(1) = p2(1) - p1(1)
4088  cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
4089  r = radius*acos(cos_p) ! great circle distance
4090  if( r<r0 ) then
4091  vr = ubar*r/r0
4092  else
4093  vr = ubar*r0/r
4094  endif
4095  x1 = cos(p2(2))*sin(p2(1))
4096  y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
4097  d2 = max(1.e-25, sqrt(x1**2 + y1**2))
4098  utmp = -vr*y1/d2
4099  vtmp = vr*x1/d2
4100  p3(1) = grid(i,j, 1) - p1(1)
4101  p3(2) = grid(i,j, 2)
4102  p4(1) = grid(i,j+1,1) - p1(1)
4103  p4(2) = grid(i,j+1,2)
4104  call get_unit_vect2(p3, p4, e2)
4105  call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
4106  v(i,j) = v(i,j) + utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4107  enddo
4108  enddo
4109  end subroutine rankine_vortex
4110 
4111 
4112 
4113  real function gh_jet(npy, lat_in)
4114  integer, intent(in):: npy
4115  real, intent(in):: lat_in
4116  real lat, lon, dp, uu
4117  real h0, ft
4118  integer j,jm
4119 
4120  jm = 4 * npy
4121 ! h0 = 10.E3
4122  h0 = 10.157946867e3
4123  dp = pi / real(jm-1)
4124 
4125  if ( .not. gh_initialized ) then
4126 ! SP:
4127  allocate(gh_table(jm))
4128  allocate(lats_table(jm))
4129  gh_table(1) = grav*h0
4130  lats_table(1) = -pi/2.
4131 ! Using only the mid-point for integration
4132  do j=2,jm
4133  lat = -pi/2. + (real(j-1)-0.5)*dp
4134  uu = u_jet(lat)
4135  ft = 2.*omega*sin(lat)
4136  gh_table(j) = gh_table(j-1) - uu*(radius*ft + tan(lat)*uu) * dp
4137  lats_table(j) = -pi/2. + real(j-1)*dp
4138  enddo
4139  gh_initialized = .true.
4140  endif
4141 
4142  if ( lat_in <= lats_table(1) ) then
4143  gh_jet = gh_table(1)
4144  return
4145  endif
4146  if ( lat_in >= lats_table(jm) ) then
4147  gh_jet = gh_table(jm)
4148  return
4149  endif
4150 
4151 ! Search:
4152  do j=1,jm-1
4153  if ( lat_in >=lats_table(j) .and. lat_in<=lats_table(j+1) ) then
4154  gh_jet = gh_table(j) + (gh_table(j+1)-gh_table(j))/dp * (lat_in-lats_table(j))
4155  return
4156  endif
4157  enddo
4158  end function gh_jet
4159 
4160  real function u_jet(lat)
4161  real lat, lon, dp
4162  real umax, en, ph0, ph1
4163 
4164  umax = 80.
4165  ph0 = pi/7.
4166  ph1 = pi/2. - ph0
4167  en = exp( -4./(ph1-ph0)**2 )
4168 
4169  if ( lat>ph0 .and. lat<ph1 ) then
4170  u_jet = (umax/en)*exp( 1./( (lat-ph0)*(lat-ph1) ) )
4171  else
4172  u_jet = 0.
4173  endif
4174  end function u_jet
4175 
4176  subroutine get_case9_b(B, agrid, isd, ied, jsd, jed)
4177  integer, intent(IN) :: isd, ied, jsd, jed
4178  real, intent(OUT) :: B(isd:ied,jsd:jed)
4179  real, intent(IN) :: agrid(isd:ied,jsd:jed,2)
4180  real :: myC,yy,myB
4181  integer :: i,j
4182 ! Generate B forcing function
4183 !
4184  gh0 = 720.*grav
4185  do j=jsd,jed
4186  do i=isd,ied
4187  if (sin(agrid(i,j,2)) > 0.) then
4188  myc = sin(agrid(i,j,1))
4189  yy = (cos(agrid(i,j,2))/sin(agrid(i,j,2)))**2
4190  myb = gh0*yy*exp(1.-yy)
4191  b(i,j) = myb*myc
4192  else
4193  b(i,j) = 0.
4194  endif
4195  enddo
4196  enddo
4197 
4198  end subroutine get_case9_b
4199 !
4200 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4201 !-------------------------------------------------------------------------------
4202 
4203 !-------------------------------------------------------------------------------
4204 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4205 !
4206  subroutine case9_forcing1(phis,time_since_start,isd,ied,jsd,jed)
4207 
4208  integer, intent(IN) :: isd,ied,jsd,jed
4209  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4210  real , intent(IN) :: time_since_start
4211  real :: tday, amean
4212  integer :: i,j
4213 !
4214 ! Generate B forcing function
4215 !
4216  tday = time_since_start/86400.0
4217  if (tday >= 20.) then
4218  aoft(2) = 0.5*(1.-cos(0.25*pi*(tday-20)))
4219  if (tday == 24) aoft(2) = 1.0
4220  elseif (tday <= 4.) then
4221  aoft(2) = 0.5*(1.-cos(0.25*pi*tday))
4222  elseif (tday <= 16.) then
4223  aoft(2) = 1.
4224  else
4225  aoft(2) = 0.5*(1.+cos(0.25*pi*(tday-16.)))
4226  endif
4227  amean = 0.5*(aoft(1)+aoft(2))
4228  do j=jsd,jed
4229  do i=isd,ied
4230  phis(i,j) = amean*case9_b(i,j)
4231  enddo
4232  enddo
4233 
4234  end subroutine case9_forcing1
4235 !
4236 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4237 !-------------------------------------------------------------------------------
4238 
4239 !-------------------------------------------------------------------------------
4240 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4241 !
4242  subroutine case9_forcing2(phis,isd,ied,jsd,jed)
4243  integer, intent(IN) :: isd,ied,jsd,jed
4244  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4245  integer :: i,j
4246 !
4247 ! Generate B forcing function
4248 !
4249  do j=jsd,jed
4250  do i=isd,ied
4251  phis(i,j) = aoft(2)*case9_b(i,j)
4252  enddo
4253  enddo
4254  aoft(1) = aoft(2)
4255 
4256  end subroutine case9_forcing2
4257 !
4258 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4259 !-------------------------------------------------------------------------------
4260 
4261  subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain, bd)
4262 
4263  type(fv_grid_bounds_type), intent(IN) :: bd
4264  real, intent(INOUT) :: delp(bd%isd:bd%ied,bd%jsd:bd%jed,npz)
4265  real, intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz)
4266  real, intent(INOUT) :: vc(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz)
4267  real, intent(INOUT) :: u(bd%isd:bd%ied,bd%jsd:bd%jed+1,npz)
4268  real, intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed,npz)
4269  real, intent(INOUT) :: ua(bd%isd:bd%ied,bd%jsd:bd%jed,npz)
4270  real, intent(INOUT) :: va(bd%isd:bd%ied,bd%jsd:bd%jed,npz)
4271  real, intent(INOUT) :: pe(bd%is-1:bd%ie+1, npz+1,bd%js-1:bd%je+1) ! edge pressure (pascal)
4272  real, intent(IN) :: time, dt
4273  real, intent(INOUT) :: ptop
4274  integer, intent(IN) :: npx, npy, npz
4275  type(fv_grid_type), intent(IN), target :: gridstruct
4276  type(domain2d), intent(INOUT) :: domain
4277 
4278  real :: period
4279  real :: omega0
4280 
4281  integer :: i,j,k
4282 
4283  real :: s, l, dt2, V0, phase
4284  real :: ull, vll, lonp
4285  real :: p0(2), elon(3), elat(3)
4286 
4287  real :: psi(bd%isd:bd%ied,bd%jsd:bd%jed)
4288  real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1)
4289  real :: dist, psi1, psi2
4290 
4291  real :: k_cell = 5
4292 
4293  real :: utmp, vtmp
4294  real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3), pt(2), p1(2), p2(2), p3(2), rperiod, timefac, t00
4295 
4296  integer :: wind_field = 1 !Should be the same as tracer_test
4297 
4298  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
4299  real, pointer, dimension(:,:) :: dx, dxa, dy, dya, dxc, dyc
4300 
4301  integer :: is, ie, js, je
4302  integer :: isd, ied, jsd, jed, ng
4303 
4304  is = bd%is
4305  ie = bd%ie
4306  js = bd%js
4307  je = bd%je
4308  isd = bd%isd
4309  ied = bd%ied
4310  jsd = bd%jsd
4311  jed = bd%jed
4312  ng = bd%ng
4313 
4314  agrid => gridstruct%agrid_64
4315  grid => gridstruct%grid_64
4316 
4317  dx => gridstruct%dx
4318  dxa => gridstruct%dxa
4319  dxc => gridstruct%dxc
4320  dy => gridstruct%dy
4321  dya => gridstruct%dya
4322  dyc => gridstruct%dyc
4323 
4324  period = real( 12*24*3600 ) !12 days
4325 
4326  l = 2.*pi/period
4327  dt2 = dt*0.5
4328 
4329  phase = pi*time/period
4330 
4331  !call prt_maxmin('pe', pe, is, ie, js, je, 0, npz, 1.E-3)
4332 
4333  !Winds: NONDIVERGENT---just use streamfunction!
4334 
4335  psi(:,:) = 1.e25
4336  psi_b(:,:) = 1.e25
4337 
4338 
4339  select case (wind_field)
4340  case (0)
4341 
4342  omega0 = 23000.*pi/period
4343 
4344  t00 = 300.
4345  ptop = 100000.*exp(-12000.*grav/t00/rdgas)
4346 
4347  do j=js,je
4348  do k=1,npz+1
4349  do i=is,ie
4350  s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4351  pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4352  cos(period*(time+dt2))*sin(s*0.5*pi)
4353  enddo
4354  enddo
4355  enddo
4356 
4357  do k=1,npz
4358  do j=js,je
4359  do i=is,ie
4360  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4361  enddo
4362  enddo
4363  enddo
4364 
4365  v0 = 10.*radius/period !k in DCMIP document
4366  ubar = 40.
4367 
4368  do j=jsd,jed
4369  do i=isd,ied
4370  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
4371  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
4372  enddo
4373  enddo
4374  call mpp_update_domains( psi, domain )
4375  do j=jsd,jed+1
4376  do i=isd,ied+1
4377  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
4378  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
4379  enddo
4380  enddo
4381 
4382  k = 1
4383 
4384  do j=js,je+1
4385  do i=is,ie
4386  dist = dx(i,j)
4387  vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
4388  if (dist==0) vc(i,j,k) = 0.
4389  enddo
4390  enddo
4391  do j=js,je
4392  do i=is,ie+1
4393  dist = dy(i,j)
4394  uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
4395  if (dist==0) uc(i,j,k) = 0.
4396  enddo
4397  enddo
4398 
4399  do j=js,je
4400  do i=is,ie+1
4401  dist = dxc(i,j)
4402  v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
4403  if (dist==0) v(i,j,k) = 0.
4404  enddo
4405  enddo
4406  do j=js,je+1
4407  do i=is,ie
4408  dist = dyc(i,j)
4409  u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
4410  if (dist==0) u(i,j,k) = 0.
4411  enddo
4412  enddo
4413 
4414  do j=js,je
4415  do i=is,ie
4416  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
4417  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
4418  dist = dya(i,j)
4419  ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
4420  if (dist==0) ua(i,j,k) = 0.
4421  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
4422  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
4423  dist = dxa(i,j)
4424  va(i,j,k) = (psi2 - psi1) / (dist)
4425  if (dist==0) va(i,j,k) = 0.
4426  enddo
4427  enddo
4428 
4429  case (1)
4430 
4431  omega0 = 23000.*pi/period
4432 
4433  do j=js,je
4434  do k=1,npz+1
4435  do i=is,ie
4436  s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4437  pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4438  cos(period*(time+dt2))*sin(s*0.5*pi)
4439  enddo
4440  enddo
4441  enddo
4442 
4443  do k=1,npz
4444  do j=js,je
4445  do i=is,ie
4446  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4447  enddo
4448  enddo
4449  enddo
4450 
4451  ubar = 10.*radius/period !k in DCMIP document
4452 
4453 
4454  do j=js,je
4455  do i=is,ie+1
4456  p1(:) = grid(i ,j ,1:2)
4457  p2(:) = grid(i,j+1 ,1:2)
4458  call mid_pt_sphere(p1, p2, p3)
4459  call get_unit_vect2(p1, p2, e2) !! e2 is WRONG in halo??
4460  call get_latlon_vector(p3, ex, ey)
4461  l = p3(1) - 2.*pi*time/period
4462  utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*radius/period*cos(p3(2))
4463  vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4464  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4465  enddo
4466  enddo
4467  do j=js,je+1
4468  do i=is,ie
4469  p1(:) = grid(i, j,1:2)
4470  p2(:) = grid(i+1,j,1:2)
4471  call mid_pt_sphere(p1, p2, p3)
4472  call get_unit_vect2(p1, p2, e1)
4473  call get_latlon_vector(p3, ex, ey)
4474  l = p3(1) - 2.*pi*time/period
4475  utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*radius/period*cos(p3(2))
4476  vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4477  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4478  enddo
4479  enddo
4480 
4481  call mp_update_dwinds(u(:,:,1), v(:,:,1), npx, npy, domain, bd)
4482 
4483 ! copy vertically; no wind shear
4484  do k=2,npz
4485  do j=jsd,jed+1
4486  do i=isd,ied
4487  u(i,j,k) = u(i,j,1)
4488  enddo
4489  enddo
4490  do j=jsd,jed
4491  do i=isd,ied+1
4492  v(i,j,k) = v(i,j,1)
4493  enddo
4494  enddo
4495  enddo
4496 
4497  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
4498 
4499  call dtoa( u(:,:,1), v(:,:,1),ua(:,:,1),va(:,:,1),dx,dy,dxa,dya,dxc,dyc,npx,npy,ng,bd)
4500  call mpp_update_domains( ua, va, domain, gridtype=agrid_param) !! ABSOLUTELY NECESSARY!!
4501  call atoc(ua(:,:,1),va(:,:,1),uc(:,:,1),vc(:,:,1),dx,dy,dxa,dya,npx,npy,ng, gridstruct%bounded_domain, domain, bd)
4502 
4503  do k=2,npz
4504  do j=js,je
4505  do i=is,ie
4506  ua(i,j,k) = ua(i,j,1)
4507  enddo
4508  enddo
4509  do j=js,je
4510  do i=is,ie
4511  va(i,j,k) = va(i,j,1)
4512  enddo
4513  enddo
4514  enddo
4515 
4516  do k=2,npz
4517  do j=js,je+1
4518  do i=is,ie
4519  vc(i,j,k) = vc(i,j,1)
4520  enddo
4521  enddo
4522  do j=js,je
4523  do i=is,ie+1
4524  uc(i,j,k) = uc(i,j,1)
4525  enddo
4526  enddo
4527  enddo
4528 
4529  !cases 2 and 3 are not nondivergent so we cannot use a streamfunction.
4530  case (2)
4531 
4532  omega0 = 0.25
4533 
4534  do j=js,je
4535  do k=1,npz+1
4536  do i=is,ie
4537  pe(i,k,j) = pe(i,k,j) + dt*omega0*grav*pe(i,k,j)/rdgas/300./k_cell* &
4538  (-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)))* &
4539  sin(pi*zz0(k)/12000.)*cos(phase)
4540  enddo
4541  enddo
4542  enddo
4543 
4544  do k=1,npz
4545  do j=js,je
4546  do i=is,ie
4547  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4548  enddo
4549  enddo
4550  enddo
4551 
4552  ubar = 40.
4553 
4554  !Set lat-lon A-grid winds
4555  k = 1
4556  do j=js,je
4557  do i=is,ie
4558  utmp = ubar*cos(agrid(i,j,2))
4559  vtmp = - radius * omega0 * pi / k_cell / 12000. * &
4560  cos(agrid(i,j,2)) * sin(k_cell * agrid(i,j,2)) * &
4561  sin(pi*zz0(k)/12000.)*cos(phase)
4562  enddo
4563  enddo
4564 
4565  end select
4566 
4567  do k=2,npz
4568  u(:,:,k) = u(:,:,1)
4569  v(:,:,k) = v(:,:,1)
4570  uc(:,:,k) = uc(:,:,1)
4571  vc(:,:,k) = vc(:,:,1)
4572  ua(:,:,k) = ua(:,:,1)
4573  va(:,:,k) = va(:,:,1)
4574  enddo
4575 
4576  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
4577  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
4578  call mp_update_dwinds(u, v, npx, npy, npz, domain, bd)
4579 
4580  nullify(agrid)
4581  nullify(grid)
4582 
4583  nullify(dx)
4584  nullify(dxa)
4585  nullify(dy)
4586  nullify(dya)
4587 
4588  end subroutine case51_forcing
4589 
4590 !!$!-------------------------------------------------------------------------------
4591 !!$!
4592 !!$! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined
4593 !!$! in Williamson, 1994 (p.16)
4594 !!$ subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, &
4595 !!$ uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, &
4596 !!$ gridstruct, stats_lun, consv_lun, monitorFreq, tile, &
4597 !!$ domain, bounded_domain, bd)
4598 !!$ type(fv_grid_bounds_type), intent(IN) :: bd
4599 !!$ integer, intent(IN) :: nt, maxnt
4600 !!$ real , intent(IN) :: dt, dtout, ndays
4601 !!$ real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
4602 !!$ real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
4603 !!$ real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
4604 !!$ real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
4605 !!$ real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
4606 !!$ real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
4607 !!$ real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
4608 !!$ real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
4609 !!$ real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
4610 !!$ real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
4611 !!$ real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
4612 !!$ integer, intent(IN) :: npx, npy, npz, ncnst, tile
4613 !!$ integer, intent(IN) :: ndims
4614 !!$ integer, intent(IN) :: nregions
4615 !!$ integer, intent(IN) :: stats_lun
4616 !!$ integer, intent(IN) :: consv_lun
4617 !!$ integer, intent(IN) :: monitorFreq
4618 !!$ type(fv_grid_type), target :: gridstruct
4619 !!$ type(domain2d), intent(INOUT) :: domain
4620 !!$ logical, intent(IN) :: bounded_domain
4621 !!$
4622 !!$ real :: L1_norm
4623 !!$ real :: L2_norm
4624 !!$ real :: Linf_norm
4625 !!$ real :: pmin, pmin1, uamin1, vamin1
4626 !!$ real :: pmax, pmax1, uamax1, vamax1
4627 !!$ real(kind=4) :: arr_r4(5)
4628 !!$ real :: tmass0, tvort0, tener0, tKE0
4629 !!$ real :: tmass, tvort, tener, tKE
4630 !!$ real :: temp(bd%is:bd%ie,bd%js:bd%je)
4631 !!$ integer :: i0, j0, k0, n0
4632 !!$ integer :: i, j, k, n, iq
4633 !!$
4634 !!$ real :: psmo, Vtx, p, w_p, p0
4635 !!$ real :: x1,y1,z1,x2,y2,z2,ang
4636 !!$
4637 !!$ real :: p1(2), p2(2), p3(2), r, r0, dist, heading
4638 !!$
4639 !!$ real :: uc0(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
4640 !!$ real :: vc0(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
4641 !!$
4642 !!$ real :: myDay
4643 !!$ integer :: myRec
4644 !!$
4645 !!$ real, save, allocatable, dimension(:,:,:) :: u0, v0
4646 !!$ real :: up(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
4647 !!$ real :: vp(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
4648 !!$
4649 !!$ real, dimension(:,:,:), pointer :: grid, agrid
4650 !!$ real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc
4651 !!$
4652 !!$ integer :: is, ie, js, je
4653 !!$ integer :: isd, ied, jsd, jed
4654 !!$
4655 !!$ is = bd%is
4656 !!$ ie = bd%ie
4657 !!$ js = bd%js
4658 !!$ je = bd%je
4659 !!$ isd = bd%isd
4660 !!$ ied = bd%ied
4661 !!$ jsd = bd%jsd
4662 !!$ jed = bd%jed
4663 !!$
4664 !!$ grid => gridstruct%grid
4665 !!$ agrid=> gridstruct%agrid
4666 !!$
4667 !!$ area => gridstruct%area
4668 !!$ f0 => gridstruct%f0
4669 !!$
4670 !!$ dx => gridstruct%dx
4671 !!$ dy => gridstruct%dy
4672 !!$ dxa => gridstruct%dxa
4673 !!$ dya => gridstruct%dya
4674 !!$ dxc => gridstruct%dxc
4675 !!$ dyc => gridstruct%dyc
4676 !!$
4677 !!$ !!! DEBUG CODE
4678 !!$ if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS'
4679 !!$ !!! END DEBUG CODE
4680 !!$
4681 !!$ myDay = ndays*((FLOAT(nt)/FLOAT(maxnt)))
4682 !!$
4683 !!$#if defined(SW_DYNAMICS)
4684 !!$ if (test_case==0) then
4685 !!$ phi0 = 0.0
4686 !!$ do j=js,je
4687 !!$ do i=is,ie
4688 !!$ x1 = agrid(i,j,1)
4689 !!$ y1 = agrid(i,j,2)
4690 !!$ z1 = radius
4691 !!$ p = p0_c0 * cos(y1)
4692 !!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
4693 !!$ w_p = 0.0
4694 !!$ if (p /= 0.0) w_p = Vtx/p
4695 !!$ ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4696 !!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4697 !!$ enddo
4698 !!$ enddo
4699 !!$ elseif (test_case==1) then
4700 !!$! Get Current Height Field "Truth"
4701 !!$ p1(1) = pi/2. + pi_shift
4702 !!$ p1(2) = 0.
4703 !!$ p2(1) = 3.*pi/2. + pi_shift
4704 !!$ p2(2) = 0.
4705 !!$ r0 = radius/3. !RADIUS 3.
4706 !!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
4707 !!$ heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha
4708 !!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3)
4709 !!$ phi0 = 0.0
4710 !!$ do j=js,je
4711 !!$ do i=is,ie
4712 !!$ p2(1) = agrid(i,j,1)
4713 !!$ p2(2) = agrid(i,j,2)
4714 !!$ r = great_circle_dist( p3, p2, radius )
4715 !!$ if (r < r0) then
4716 !!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
4717 !!$ else
4718 !!$ phi0(i,j,1) = phis(i,j)
4719 !!$ endif
4720 !!$ enddo
4721 !!$ enddo
4722 !!$ endif
4723 !!$
4724 !!$! Get Height Field Stats
4725 !!$ call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4726 !!$ pmin1=pmin1/Grav
4727 !!$ pmax1=pmax1/Grav
4728 !!$ if (test_case <= 2) then
4729 !!$ call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, &
4730 !!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd)
4731 !!$ pmin=pmin/Grav
4732 !!$ pmax=pmax/Grav
4733 !!$ arr_r4(1) = pmin1
4734 !!$ arr_r4(2) = pmax1
4735 !!$ arr_r4(3) = L1_norm
4736 !!$ arr_r4(4) = L2_norm
4737 !!$ arr_r4(5) = Linf_norm
4738 !!$ !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4
4739 !!$ else
4740 !!$ arr_r4(1) = pmin1
4741 !!$ arr_r4(2) = pmax1
4742 !!$ arr_r4(3:5) = 0.
4743 !!$ pmin = 0.
4744 !!$ pmax = 0.
4745 !!$ L1_norm = 0.
4746 !!$ L2_norm = 0.
4747 !!$ Linf_norm = 0.
4748 !!$ endif
4749 !!$
4750 !!$ 200 format(i6.6,A,i6.6,A,e21.14)
4751 !!$ 201 format(' ',A,e21.14,' ',e21.14)
4752 !!$ 202 format(' ',A,i4.4,'x',i4.4,'x',i4.4)
4753 !!$
4754 !!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0 ) then
4755 !!$ write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay
4756 !!$ write(*,201) 'Height MAX : ', pmax1
4757 !!$ write(*,201) 'Height MIN : ', pmin1
4758 !!$ write(*,202) 'HGT MAX location : ', i0, j0, n0
4759 !!$ if (test_case <= 2) then
4760 !!$ write(*,201) 'Height L1_norm : ', L1_norm
4761 !!$ write(*,201) 'Height L2_norm : ', L2_norm
4762 !!$ write(*,201) 'Height Linf_norm : ', Linf_norm
4763 !!$ endif
4764 !!$ endif
4765 !!$
4766 !!$! Get UV Stats
4767 !!$ call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
4768 !!$ call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4769 !!$ if (test_case <= 2) then
4770 !!$ call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, &
4771 !!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
4772 !!$ endif
4773 !!$ arr_r4(1) = pmin1
4774 !!$ arr_r4(2) = pmax1
4775 !!$ arr_r4(3) = L1_norm
4776 !!$ arr_r4(4) = L2_norm
4777 !!$ arr_r4(5) = Linf_norm
4778 !!$ !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4
4779 !!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then
4780 !!$ write(*,201) 'UV MAX : ', pmax1
4781 !!$ write(*,201) 'UV MIN : ', pmin1
4782 !!$ write(*,202) 'UV MAX location : ', i0, j0, n0
4783 !!$ if (test_case <= 2) then
4784 !!$ write(*,201) 'UV L1_norm : ', L1_norm
4785 !!$ write(*,201) 'UV L2_norm : ', L2_norm
4786 !!$ write(*,201) 'UV Linf_norm : ', Linf_norm
4787 !!$ endif
4788 !!$ endif
4789 !!$#else
4790 !!$
4791 !!$ 200 format(i6.6,A,i6.6,A,e10.4)
4792 !!$ 201 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4793 !!$ 202 format(' ',A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4)
4794 !!$ 203 format(' ',A,i3.3,A,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4795 !!$
4796 !!$ if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myDay
4797 !!$
4798 !!$! Surface Pressure
4799 !!$ psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4800 !!$ if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo
4801 !!$ call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4802 !!$ if (is_master()) then
4803 !!$ write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0
4804 !!$ endif
4805 !!$
4806 !!$! Get PT Stats
4807 !!$ pmax1 = -1.e25
4808 !!$ pmin1 = 1.e25
4809 !!$ i0=-999
4810 !!$ j0=-999
4811 !!$ k0=-999
4812 !!$ n0=-999
4813 !!$ do k=1,npz
4814 !!$ call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4815 !!$ pmin1 = min(pmin, pmin1)
4816 !!$ pmax1 = max(pmax, pmax1)
4817 !!$ if (pmax1 == pmax) k0 = k
4818 !!$ enddo
4819 !!$ if (is_master()) then
4820 !!$ write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4821 !!$ endif
4822 !!$
4823 !!$#if defined(DEBUG_TEST_CASES)
4824 !!$ if(is_master()) write(*,*) ' '
4825 !!$ do k=1,npz
4826 !!$ pmax1 = -1.e25
4827 !!$ pmin1 = 1.e25
4828 !!$ i0=-999
4829 !!$ j0=-999
4830 !!$ k0=-999
4831 !!$ n0=-999
4832 !!$ call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4833 !!$ pmin1 = min(pmin, pmin1)
4834 !!$ pmax1 = max(pmax, pmax1)
4835 !!$ if (is_master()) then
4836 !!$ 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) )
4837 !!$ endif
4838 !!$ enddo
4839 !!$ if(is_master()) write(*,*) ' '
4840 !!$#endif
4841 !!$
4842 !!$! Get DELP Stats
4843 !!$ pmax1 = -1.e25
4844 !!$ pmin1 = 1.e25
4845 !!$ i0=-999
4846 !!$ j0=-999
4847 !!$ k0=-999
4848 !!$ n0=-999
4849 !!$ do k=1,npz
4850 !!$ call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4851 !!$ pmin1 = min(pmin, pmin1)
4852 !!$ pmax1 = max(pmax, pmax1)
4853 !!$ if (pmax1 == pmax) k0 = k
4854 !!$ enddo
4855 !!$ if (is_master()) then
4856 !!$ write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4857 !!$ endif
4858 !!$
4859 !!$! Get UV Stats
4860 !!$ uamax1 = -1.e25
4861 !!$ uamin1 = 1.e25
4862 !!$ i0=-999
4863 !!$ j0=-999
4864 !!$ k0=-999
4865 !!$ n0=-999
4866 !!$ do k=1,npz
4867 !!$ 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, bd%ng)
4868 !!$ call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4869 !!$ uamin1 = min(pmin, uamin1)
4870 !!$ uamax1 = max(pmax, uamax1)
4871 !!$ if (uamax1 == pmax) k0 = k
4872 !!$ enddo
4873 !!$ if (is_master()) then
4874 !!$ write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0
4875 !!$ endif
4876 !!$
4877 !!$ vamax1 = -1.e25
4878 !!$ vamin1 = 1.e25
4879 !!$ i0=-999
4880 !!$ j0=-999
4881 !!$ k0=-999
4882 !!$ n0=-999
4883 !!$ do k=1,npz
4884 !!$ call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4885 !!$ vamin1 = min(pmin, vamin1)
4886 !!$ vamax1 = max(pmax, vamax1)
4887 !!$ if (vamax1 == pmax) k0 = k
4888 !!$ enddo
4889 !!$ if (is_master()) then
4890 !!$ write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0
4891 !!$ endif
4892 !!$
4893 !!$! Get Q Stats
4894 !!$ pmax1 = -1.e25
4895 !!$ pmin1 = 1.e25
4896 !!$ i0=-999
4897 !!$ j0=-999
4898 !!$ k0=-999
4899 !!$ n0=-999
4900 !!$ do k=1,npz
4901 !!$ call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4902 !!$ pmin1 = min(pmin, pmin1)
4903 !!$ pmax1 = max(pmax, pmax1)
4904 !!$ if (pmax1 == pmax) k0 = k
4905 !!$ enddo
4906 !!$ if (is_master()) then
4907 !!$ write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4908 !!$ endif
4909 !!$
4910 !!$! Get tracer Stats
4911 !!$ do iq=2,ncnst
4912 !!$ pmax1 = -1.e25
4913 !!$ pmin1 = 1.e25
4914 !!$ i0=-999
4915 !!$ j0=-999
4916 !!$ k0=-999
4917 !!$ n0=-999
4918 !!$ do k=1,npz
4919 !!$ call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4920 !!$ pmin1 = min(pmin, pmin1)
4921 !!$ pmax1 = max(pmax, pmax1)
4922 !!$ if (pmax1 == pmax) k0 = k
4923 !!$ enddo
4924 !!$ if (is_master()) then
4925 !!$ write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4926 !!$ endif
4927 !!$ enddo
4928 !!$
4929 !!$#endif
4930 !!$
4931 !!$ if (test_case == 12) then
4932 !!$! Get UV Stats
4933 !!$ call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, &
4934 !!$ pmin, pmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd)
4935 !!$ if (is_master()) then
4936 !!$ write(*,201) 'UV(850) L1_norm : ', L1_norm
4937 !!$ write(*,201) 'UV(850) L2_norm : ', L2_norm
4938 !!$ write(*,201) 'UV(850) Linf_norm : ', Linf_norm
4939 !!$ endif
4940 !!$ endif
4941 !!$
4942 !!$ tmass = 0.0
4943 !!$ tKE = 0.0
4944 !!$ tener = 0.0
4945 !!$ tvort = 0.0
4946 !!$#if defined(SW_DYNAMICS)
4947 !!$ do k=1,1
4948 !!$#else
4949 !!$ do k=1,npz
4950 !!$#endif
4951 !!$! Get conservation Stats
4952 !!$
4953 !!$! Conservation of Mass
4954 !!$ temp(:,:) = delp(is:ie,js:je,k)
4955 !!$ tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4956 !!$ tmass = tmass + tmass0
4957 !!$
4958 !!$ !if (.not. allocated(u0, v0)) then
4959 !!$ if (nt == 0) then
4960 !!$ allocate(u0(isd:ied,jsd:jed+1,npz))
4961 !!$ allocate(v0(isd:ied+1,jsd:jed,npz))
4962 !!$ u0 = u
4963 !!$ v0 = v
4964 !!$ endif
4965 !!$
4966 !!$ !! UA is the PERTURBATION now
4967 !!$ up = u - u0
4968 !!$ vp = v - v0
4969 !!$
4970 !!$ call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, bd%ng)
4971 !!$ call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,bd%ng,bounded_domain, domain, noComm=.true.)
4972 !!$! Conservation of Kinetic Energy
4973 !!$ do j=js,je
4974 !!$ do i=is,ie
4975 !!$ temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + &
4976 !!$ vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) )
4977 !!$ enddo
4978 !!$ enddo
4979 !!$ tKE0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4980 !!$ tKE = tKE + tKE0
4981 !!$
4982 !!$! Conservation of Energy
4983 !!$ do j=js,je
4984 !!$ do i=is,ie
4985 !!$ temp(i,j) = 0.5 * (delp(i,j,k)/Grav) * temp(i,j) ! Include Previously calcullated KE
4986 !!$ temp(i,j) = temp(i,j) + &
4987 !!$ Grav*((delp(i,j,k)/Grav + phis(i,j))*(delp(i,j,k)/Grav + phis(i,j))) - &
4988 !!$ phis(i,j)*phis(i,j)
4989 !!$ enddo
4990 !!$ enddo
4991 !!$ tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4992 !!$ tener = tener + tener0
4993 !!$
4994 !!$! Conservation of Potential Enstrophy
4995 !!$ if (test_case>1) then
4996 !!$ do j=js,je
4997 !!$ do i=is,ie
4998 !!$ 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)) - &
4999 !!$ (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
5000 !!$ temp(i,j) = ( Grav*(temp(i,j)*temp(i,j))/delp(i,j,k) )
5001 !!$ enddo
5002 !!$ enddo
5003 !!$ tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5004 !!$ tvort = tvort + tvort0
5005 !!$ else
5006 !!$ tvort=1.
5007 !!$ endif
5008 !!$ enddo
5009 !!$
5010 !!$ if (nt == 0) then
5011 !!$ tmass_orig = tmass
5012 !!$ tener_orig = tener
5013 !!$ tvort_orig = tvort
5014 !!$ endif
5015 !!$ arr_r4(1) = (tmass-tmass_orig)/tmass_orig
5016 !!$ arr_r4(2) = (tener-tener_orig)/tener_orig
5017 !!$ arr_r4(3) = (tvort-tvort_orig)/tvort_orig
5018 !!$ arr_r4(4) = tKE
5019 !!$ if (test_case==12) arr_r4(4) = L2_norm
5020 !!$#if defined(SW_DYNAMICS)
5021 !!$ myRec = nt+1
5022 !!$#else
5023 !!$ myRec = myDay*86400.0/dtout + 1
5024 !!$#endif
5025 !!$ if (is_master()) write(consv_lun,rec=myRec) arr_r4(1:4)
5026 !!$#if defined(SW_DYNAMICS)
5027 !!$ if ( (is_master()) .and. MOD(nt,monitorFreq)==0) then
5028 !!$#else
5029 !!$ if ( (is_master()) ) then
5030 !!$#endif
5031 !!$ write(*,201) 'MASS TOTAL : ', tmass
5032 !!$ write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig
5033 !!$ if (test_case >= 2) then
5034 !!$ write(*,201) 'Kinetic Energy KE : ', tKE
5035 !!$ write(*,201) 'ENERGY TOTAL : ', tener
5036 !!$ write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig
5037 !!$ write(*,201) 'ENSTR TOTAL : ', tvort
5038 !!$ write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig
5039 !!$ endif
5040 !!$ write(*,*) ' '
5041 !!$ endif
5042 !!$
5043 !!$ nullify(grid)
5044 !!$ nullify(agrid)
5045 !!$ nullify(area)
5046 !!$ nullify(f0)
5047 !!$ nullify(dx)
5048 !!$ nullify(dy)
5049 !!$
5050 !!$ end subroutine get_stats
5051 
5052 
5053 
5054  subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
5055 ! get_pt_on_great_circle :: Get the mid-point on a great circle given:
5056 ! -2 points (Lon/Lat) to define a great circle
5057 ! -Great Cirle distance between 2 defining points
5058 ! -Heading
5059 ! compute:
5060 ! Arrival Point (Lon/Lat)
5061 
5062  real , intent(IN) :: p1(2), p2(2)
5063  real , intent(IN) :: dist
5064  real , intent(IN) :: heading
5065  real , intent(OUT) :: p3(2)
5066 
5067  real pha, dp
5068 
5069  pha = dist/radius
5070 
5071  p3(2) = asin( (cos(heading)*cos(p1(2))*sin(pha)) + (sin(p1(2))*cos(pha)) )
5072  dp = atan2( sin(heading)*sin(pha)*cos(p1(2)) , cos(pha) - sin(p1(2))*sin(p3(2)) )
5073  p3(1) = mod( (p1(1)-pi)-dp+pi , 2.*pi ) !- pi Leave at 0 to 360
5074 
5075  end subroutine get_pt_on_great_circle
5076 
5077 
5078 !
5079 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5080 !-------------------------------------------------------------------------------
5081 
5082 !!$!-------------------------------------------------------------------------------
5083 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5084 !!$!
5085 !!$! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5086 !!$! in Williamson, 1994 (p.16)
5087 !!$! for any var
5088 !!$
5089 !!$ subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, &
5090 !!$ vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd)
5091 !!$ type(fv_grid_bounds_type), intent(IN) :: bd
5092 !!$ integer, intent(IN) :: npx, npy
5093 !!$ integer, intent(IN) :: ndims
5094 !!$ integer, intent(IN) :: nregions, tile
5095 !!$ real , intent(IN) :: var(bd%isd:bd%ied,bd%jsd:bd%jed)
5096 !!$ real , intent(IN) :: varT(bd%isd:bd%ied,bd%jsd:bd%jed)
5097 !!$ real , intent(OUT) :: vmin
5098 !!$ real , intent(OUT) :: vmax
5099 !!$ real , intent(OUT) :: L1_norm
5100 !!$ real , intent(OUT) :: L2_norm
5101 !!$ real , intent(OUT) :: Linf_norm
5102 !!$
5103 !!$ type(fv_grid_type), target :: gridstruct
5104 !!$
5105 !!$ real :: vmean
5106 !!$ real :: vvar
5107 !!$ real :: vmin1
5108 !!$ real :: vmax1
5109 !!$ real :: pdiffmn
5110 !!$ real :: pdiffmx
5111 !!$
5112 !!$ real :: varSUM, varSUM2, varMAX
5113 !!$ real :: gsum
5114 !!$ real :: vminT, vmaxT, vmeanT, vvarT
5115 !!$ integer :: i0, j0, n0
5116 !!$
5117 !!$ real, dimension(:,:,:), pointer :: grid, agrid
5118 !!$ real, dimension(:,:), pointer :: area
5119 !!$
5120 !!$ integer :: is, ie, js, je
5121 !!$ integer :: isd, ied, jsd, jed, ng
5122 !!$
5123 !!$ is = bd%is
5124 !!$ ie = bd%ie
5125 !!$ js = bd%js
5126 !!$ je = bd%je
5127 !!$ isd = bd%isd
5128 !!$ ied = bd%ied
5129 !!$ jsd = bd%jsd
5130 !!$ jed = bd%jed
5131 !!$ ng = bd%ng
5132 !!$
5133 !!$ grid => gridstruct%grid
5134 !!$ agrid=> gridstruct%agrid
5135 !!$
5136 !!$ area => gridstruct%area
5137 !!$
5138 !!$ varSUM = 0.
5139 !!$ varSUM2 = 0.
5140 !!$ varMAX = 0.
5141 !!$ L1_norm = 0.
5142 !!$ L2_norm = 0.
5143 !!$ Linf_norm = 0.
5144 !!$ vmean = 0.
5145 !!$ vvar = 0.
5146 !!$ vmax = 0.
5147 !!$ vmin = 0.
5148 !!$ pdiffmn= 0.
5149 !!$ pdiffmx= 0.
5150 !!$ vmeanT = 0.
5151 !!$ vvarT = 0.
5152 !!$ vmaxT = 0.
5153 !!$ vminT = 0.
5154 !!$
5155 !!$ vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5156 !!$ vmeanT = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5157 !!$ vmean = vmean / (4.0*pi)
5158 !!$ vmeanT = vmeanT / (4.0*pi)
5159 !!$
5160 !!$ call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0)
5161 !!$ call pmxn(varT, npx, npy, nregions, tile, gridstruct, vminT, vmaxT, i0, j0, n0)
5162 !!$ call pmxn(var-varT, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0)
5163 !!$
5164 !!$ vmax = (vmax - vmaxT) / (vmaxT-vminT)
5165 !!$ vmin = (vmin - vminT) / (vmaxT-vminT)
5166 !!$
5167 !!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5168 !!$ varSUM2 = globalsum(varT(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5169 !!$ 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)
5170 !!$ 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)
5171 !!$ L1_norm = L1_norm/varSUM
5172 !!$ L2_norm = SQRT(L2_norm)/SQRT(varSUM2)
5173 !!$
5174 !!$ call pmxn(ABS(varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5175 !!$ varMAX = vmax
5176 !!$ call pmxn(ABS(var-varT), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5177 !!$ Linf_norm = vmax/varMAX
5178 !!$
5179 !!$ end subroutine get_scalar_stats
5180 !!$!
5181 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5182 !!$!-------------------------------------------------------------------------------
5183 !!$
5184 !!$!-------------------------------------------------------------------------------
5185 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5186 !!$!
5187 !!$! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5188 !!$! in Williamson, 1994 (p.16)
5189 !!$! for any var
5190 !!$
5191 !!$ subroutine get_vector_stats(varU, varUT, varV, varVT, &
5192 !!$ npx, npy, ndims, nregions, &
5193 !!$ vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile, bd)
5194 !!$ type(fv_grid_bounds_type), intent(IN) :: bd
5195 !!$ integer, intent(IN) :: npx, npy
5196 !!$ integer, intent(IN) :: ndims
5197 !!$ integer, intent(IN) :: nregions, tile
5198 !!$ real , intent(IN) :: varU(bd%isd:bd%ied,bd%jsd:bd%jed)
5199 !!$ real , intent(IN) :: varUT(bd%isd:bd%ied,bd%jsd:bd%jed)
5200 !!$ real , intent(IN) :: varV(bd%isd:bd%ied,bd%jsd:bd%jed)
5201 !!$ real , intent(IN) :: varVT(bd%isd:bd%ied,bd%jsd:bd%jed)
5202 !!$ real , intent(OUT) :: vmin
5203 !!$ real , intent(OUT) :: vmax
5204 !!$ real , intent(OUT) :: L1_norm
5205 !!$ real , intent(OUT) :: L2_norm
5206 !!$ real , intent(OUT) :: Linf_norm
5207 !!$
5208 !!$ real :: var(bd%isd:bd%ied,bd%jsd:bd%jed)
5209 !!$ real :: varT(bd%isd:bd%ied,bd%jsd:bd%jed)
5210 !!$ real :: vmean
5211 !!$ real :: vvar
5212 !!$ real :: vmin1
5213 !!$ real :: vmax1
5214 !!$ real :: pdiffmn
5215 !!$ real :: pdiffmx
5216 !!$
5217 !!$ real :: varSUM, varSUM2, varMAX
5218 !!$ real :: gsum
5219 !!$ real :: vminT, vmaxT, vmeanT, vvarT
5220 !!$ integer :: i,j,n
5221 !!$ integer :: i0, j0, n0
5222 !!$
5223 !!$ type(fv_grid_type), target :: gridstruct
5224 !!$
5225 !!$ real, dimension(:,:,:), pointer :: grid, agrid
5226 !!$ real, dimension(:,:), pointer :: area
5227 !!$
5228 !!$ integer :: is, ie, js, je
5229 !!$ integer :: isd, ied, jsd, jed, ng
5230 !!$
5231 !!$ is = bd%is
5232 !!$ ie = bd%ie
5233 !!$ js = bd%js
5234 !!$ je = bd%je
5235 !!$ isd = bd%isd
5236 !!$ ied = bd%ied
5237 !!$ jsd = bd%jsd
5238 !!$ jed = bd%jed
5239 !!$ ng = bd%ng
5240 !!$
5241 !!$ grid => gridstruct%grid
5242 !!$ agrid=> gridstruct%agrid
5243 !!$
5244 !!$ area => gridstruct%area
5245 !!$
5246 !!$ varSUM = 0.
5247 !!$ varSUM2 = 0.
5248 !!$ varMAX = 0.
5249 !!$ L1_norm = 0.
5250 !!$ L2_norm = 0.
5251 !!$ Linf_norm = 0.
5252 !!$ vmean = 0.
5253 !!$ vvar = 0.
5254 !!$ vmax = 0.
5255 !!$ vmin = 0.
5256 !!$ pdiffmn= 0.
5257 !!$ pdiffmx= 0.
5258 !!$ vmeanT = 0.
5259 !!$ vvarT = 0.
5260 !!$ vmaxT = 0.
5261 !!$ vminT = 0.
5262 !!$
5263 !!$ do j=js,je
5264 !!$ do i=is,ie
5265 !!$ var(i,j) = SQRT( (varU(i,j)-varUT(i,j))**2. + &
5266 !!$ (varV(i,j)-varVT(i,j))**2. )
5267 !!$ varT(i,j) = SQRT( varUT(i,j)*varUT(i,j) + &
5268 !!$ varVT(i,j)*varVT(i,j) )
5269 !!$ enddo
5270 !!$ enddo
5271 !!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5272 !!$ L1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5273 !!$ L1_norm = L1_norm/varSUM
5274 !!$
5275 !!$ call pmxn(varT, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5276 !!$ varMAX = vmax
5277 !!$ call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5278 !!$ Linf_norm = vmax/varMAX
5279 !!$
5280 !!$ do j=js,je
5281 !!$ do i=is,ie
5282 !!$ var(i,j) = ( (varU(i,j)-varUT(i,j))**2. + &
5283 !!$ (varV(i,j)-varVT(i,j))**2. )
5284 !!$ varT(i,j) = ( varUT(i,j)*varUT(i,j) + &
5285 !!$ varVT(i,j)*varVT(i,j) )
5286 !!$ enddo
5287 !!$ enddo
5288 !!$ varSUM = globalsum(varT(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5289 !!$ L2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5290 !!$ L2_norm = SQRT(L2_norm)/SQRT(varSUM)
5291 !!$
5292 !!$ end subroutine get_vector_stats
5293 !!$!
5294 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5295 !!$!-------------------------------------------------------------------------------
5296 
5297 !!$!-------------------------------------------------------------------------------
5298 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5299 !!$!
5300 !!$! check_courant_numbers ::
5301 !!$!
5302 !!$ subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint)
5303 !!$
5304 !!$ real, intent(IN) :: ndt
5305 !!$ integer, intent(IN) :: n_split
5306 !!$ integer, intent(IN) :: npx, npy, npz, tile
5307 !!$ logical, OPTIONAL, intent(IN) :: noPrint
5308 !!$ real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz)
5309 !!$ real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz)
5310 !!$
5311 !!$ real :: ideal_c=0.06
5312 !!$ real :: tolerance= 1.e-3
5313 !!$ real :: dt_inc, dt_orig
5314 !!$ real :: meanCy, minCy, maxCy, meanCx, minCx, maxCx
5315 !!$
5316 !!$ real :: counter
5317 !!$ logical :: ideal
5318 !!$
5319 !!$ integer :: i,j,k
5320 !!$ real :: dt
5321 !!$
5322 !!$ type(fv_grid_type), intent(IN), target :: gridstruct
5323 !!$ real, dimension(:,:), pointer :: dxc, dyc
5324 !!$
5325 !!$ dxc => gridstruct%dxc
5326 !!$ dyc => gridstruct%dyc
5327 !!$
5328 !!$ dt = ndt/real(n_split)
5329 !!$
5330 !!$ 300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
5331 !!$
5332 !!$ dt_orig = dt
5333 !!$ dt_inc = 1
5334 !!$ ideal = .false.
5335 !!$
5336 !!$ do while(.not. ideal)
5337 !!$
5338 !!$ counter = 0
5339 !!$ minCy = missing
5340 !!$ maxCy = -1.*missing
5341 !!$ minCx = missing
5342 !!$ maxCx = -1.*missing
5343 !!$ meanCx = 0
5344 !!$ meanCy = 0
5345 !!$ do k=1,npz
5346 !!$ do j=js,je
5347 !!$ do i=is,ie+1
5348 !!$ minCx = MIN(minCx, ABS( (dt/dxc(i,j))*uc(i,j,k) ))
5349 !!$ maxCx = MAX(maxCx, ABS( (dt/dxc(i,j))*uc(i,j,k) ))
5350 !!$ meanCx = meanCx + ABS( (dt/dxc(i,j))*uc(i,j,k) )
5351 !!$
5352 !!$ if (ABS( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then
5353 !!$ counter = counter+1
5354 !!$ write(*,300) i,j,k,tile, ABS( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter
5355 !!$ call exit(1)
5356 !!$ endif
5357 !!$
5358 !!$ enddo
5359 !!$ enddo
5360 !!$ do j=js,je+1
5361 !!$ do i=is,ie
5362 !!$ minCy = MIN(minCy, ABS( (dt/dyc(i,j))*vc(i,j,k) ))
5363 !!$ maxCy = MAX(maxCy, ABS( (dt/dyc(i,j))*vc(i,j,k) ))
5364 !!$ meanCy = meanCy + ABS( (dt/dyc(i,j))*vc(i,j,k) )
5365 !!$
5366 !!$ if (ABS( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then
5367 !!$ counter = counter+1
5368 !!$ write(*,300) i,j,k,tile, ABS( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter
5369 !!$ call exit(1)
5370 !!$ endif
5371 !!$
5372 !!$ enddo
5373 !!$ enddo
5374 !!$ enddo
5375 !!$
5376 !!$ call mp_reduce_max(maxCx)
5377 !!$ call mp_reduce_max(maxCy)
5378 !!$ minCx = -minCx
5379 !!$ minCy = -minCy
5380 !!$ call mp_reduce_max(minCx)
5381 !!$ call mp_reduce_max(minCy)
5382 !!$ minCx = -minCx
5383 !!$ minCy = -minCy
5384 !!$ call mp_reduce_sum(meanCx)
5385 !!$ call mp_reduce_sum(meanCy)
5386 !!$ meanCx = meanCx/(6.0*DBLE(npx)*DBLE(npy-1))
5387 !!$ meanCy = meanCy/(6.0*DBLE(npx-1)*DBLE(npy))
5388 !!$
5389 !!$ !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then
5390 !!$ ideal = .true.
5391 !!$ !elseif (maxCy-ideal_c > 0) then
5392 !!$ ! dt = dt - dt_inc
5393 !!$ !else
5394 !!$ ! dt = dt + dt_inc
5395 !!$ !endif
5396 !!$
5397 !!$ enddo
5398 !!$
5399 !!$ if ( (.not. present(noPrint)) .and. (is_master()) ) then
5400 !!$ print*, ''
5401 !!$ print*, '--------------------------------------------'
5402 !!$ print*, 'Y-dir Courant number MIN : ', minCy
5403 !!$ print*, 'Y-dir Courant number MAX : ', maxCy
5404 !!$ print*, ''
5405 !!$ print*, 'X-dir Courant number MIN : ', minCx
5406 !!$ print*, 'X-dir Courant number MAX : ', maxCx
5407 !!$ print*, ''
5408 !!$ print*, 'X-dir Courant number MEAN : ', meanCx
5409 !!$ print*, 'Y-dir Courant number MEAN : ', meanCy
5410 !!$ print*, ''
5411 !!$ print*, 'NDT: ', ndt
5412 !!$ print*, 'n_split: ', n_split
5413 !!$ print*, 'DT: ', dt
5414 !!$ print*, ''
5415 !!$ print*, '--------------------------------------------'
5416 !!$ print*, ''
5417 !!$ endif
5418 !!$
5419 !!$ end subroutine check_courant_numbers
5420 !!$!
5421 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5422 !!$!-------------------------------------------------------------------------------
5423 
5424 !!$!-------------------------------------------------------------------------------
5425 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5426 !!$!
5427 !!$! pmxn :: find max and min of field p
5428 !!$!
5429 !!$ subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
5430 !!$ integer, intent(IN) :: npx
5431 !!$ integer, intent(IN) :: npy
5432 !!$ integer, intent(IN) :: nregions, tile
5433 !!$ real , intent(IN) :: p(isd:ied,jsd:jed)
5434 !!$ type(fv_grid_type), intent(IN), target :: gridstruct
5435 !!$ real , intent(OUT) :: pmin
5436 !!$ real , intent(OUT) :: pmax
5437 !!$ integer, intent(OUT) :: i0
5438 !!$ integer, intent(OUT) :: j0
5439 !!$ integer, intent(OUT) :: n0
5440 !!$
5441 !!$ real :: temp
5442 !!$ integer :: i,j,n
5443 !!$
5444 !!$
5445 !!$ real, pointer, dimension(:,:,:) :: agrid, grid
5446 !!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0
5447 !!$ real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
5448 !!$ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
5449 !!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5450 !!$
5451 !!$ logical, pointer :: cubed_sphere, latlon
5452 !!$
5453 !!$ logical, pointer :: have_south_pole, have_north_pole
5454 !!$
5455 !!$ integer, pointer :: ntiles_g
5456 !!$ real, pointer :: acapN, acapS, globalarea
5457 !!$
5458 !!$ grid => gridstruct%grid
5459 !!$ agrid=> gridstruct%agrid
5460 !!$
5461 !!$ area => gridstruct%area
5462 !!$ rarea => gridstruct%rarea
5463 !!$
5464 !!$ fC => gridstruct%fC
5465 !!$ f0 => gridstruct%f0
5466 !!$
5467 !!$ ee1 => gridstruct%ee1
5468 !!$ ee2 => gridstruct%ee2
5469 !!$ ew => gridstruct%ew
5470 !!$ es => gridstruct%es
5471 !!$ en1 => gridstruct%en1
5472 !!$ en2 => gridstruct%en2
5473 !!$
5474 !!$ dx => gridstruct%dx
5475 !!$ dy => gridstruct%dy
5476 !!$ dxa => gridstruct%dxa
5477 !!$ dya => gridstruct%dya
5478 !!$ rdxa => gridstruct%rdxa
5479 !!$ rdya => gridstruct%rdya
5480 !!$ dxc => gridstruct%dxc
5481 !!$ dyc => gridstruct%dyc
5482 !!$
5483 !!$ cubed_sphere => gridstruct%cubed_sphere
5484 !!$ latlon => gridstruct%latlon
5485 !!$
5486 !!$ have_south_pole => gridstruct%have_south_pole
5487 !!$ have_north_pole => gridstruct%have_north_pole
5488 !!$
5489 !!$ ntiles_g => gridstruct%ntiles_g
5490 !!$ acapN => gridstruct%acapN
5491 !!$ acapS => gridstruct%acapS
5492 !!$ globalarea => gridstruct%globalarea
5493 !!$
5494 !!$ pmax = -1.e25
5495 !!$ pmin = 1.e25
5496 !!$ i0 = -999
5497 !!$ j0 = -999
5498 !!$ n0 = tile
5499 !!$
5500 !!$ do j=js,je
5501 !!$ do i=is,ie
5502 !!$ temp = p(i,j)
5503 !!$ if (temp > pmax) then
5504 !!$ pmax = temp
5505 !!$ i0 = i
5506 !!$ j0 = j
5507 !!$ elseif (temp < pmin) then
5508 !!$ pmin = temp
5509 !!$ endif
5510 !!$ enddo
5511 !!$ enddo
5512 !!$
5513 !!$ temp = pmax
5514 !!$ call mp_reduce_max(temp)
5515 !!$ if (temp /= pmax) then
5516 !!$ i0 = -999
5517 !!$ j0 = -999
5518 !!$ n0 = -999
5519 !!$ endif
5520 !!$ pmax = temp
5521 !!$ call mp_reduce_max(i0)
5522 !!$ call mp_reduce_max(j0)
5523 !!$ call mp_reduce_max(n0)
5524 !!$
5525 !!$ pmin = -pmin
5526 !!$ call mp_reduce_max(pmin)
5527 !!$ pmin = -pmin
5528 !!$
5529 !!$ end subroutine pmxn
5530 !!$!
5531 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5532 !!$!-------------------------------------------------------------------------------
5533 !!$
5534 !!$!! These routines are no longer used
5535 !!$#ifdef NCDF_OUTPUT
5536 !!$
5537 !!$!-------------------------------------------------------------------------------
5538 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5539 !!$!
5540 !!$! output_ncdf :: write out NETCDF fields
5541 !!$!
5542 !!$ subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5543 !!$ omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, &
5544 !!$ npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, &
5545 !!$ phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, &
5546 !!$ lats_id, lons_id, gridstruct, flagstruct)
5547 !!$ real, intent(IN) :: dt
5548 !!$ integer, intent(IN) :: nt, maxnt
5549 !!$ integer, intent(INOUT) :: nout
5550 !!$
5551 !!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5552 !!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5553 !!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5554 !!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5555 !!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5556 !!$
5557 !!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5558 !!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5559 !!$
5560 !!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5561 !!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5562 !!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5563 !!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5564 !!$ real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz)
5565 !!$
5566 !!$ integer, intent(IN) :: npx, npy, npz
5567 !!$ integer, intent(IN) :: ng, ncnst
5568 !!$ integer, intent(IN) :: ndims
5569 !!$ integer, intent(IN) :: nregions
5570 !!$ integer, intent(IN) :: ncid
5571 !!$ integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id
5572 !!$ integer, intent(IN) :: ntiles_id, nt_id
5573 !!$ integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id
5574 !!$ integer, intent(IN) :: om_id ! omega (dp/dt)
5575 !!$ integer, intent(IN) :: tracers_ids(ncnst-1)
5576 !!$ integer, intent(IN) :: lats_id, lons_id
5577 !!$
5578 !!$ type(fv_grid_type), target :: gridstruct
5579 !!$ type(fv_flags_type), intent(IN) :: flagstruct
5580 !!$
5581 !!$ real, allocatable :: tmp(:,:,:)
5582 !!$ real, allocatable :: tmpA(:,:,:)
5583 !!$#if defined(SW_DYNAMICS)
5584 !!$ real, allocatable :: ut(:,:,:)
5585 !!$ real, allocatable :: vt(:,:,:)
5586 !!$#else
5587 !!$ real, allocatable :: ut(:,:,:,:)
5588 !!$ real, allocatable :: vt(:,:,:,:)
5589 !!$ real, allocatable :: tmpA_3d(:,:,:,:)
5590 !!$#endif
5591 !!$ real, allocatable :: vort(:,:)
5592 !!$
5593 !!$ real :: p1(2) ! Temporary Point
5594 !!$ real :: p2(2) ! Temporary Point
5595 !!$ real :: p3(2) ! Temporary Point
5596 !!$ real :: p4(2) ! Temporary Point
5597 !!$ real :: pa(2) ! Temporary Point
5598 !!$ real :: utmp, vtmp, r, r0, dist, heading
5599 !!$ integer :: i,j,k,n,iq,nreg
5600 !!$
5601 !!$ real :: Vtx, p, w_p
5602 !!$ real :: x1,y1,z1,x2,y2,z2,ang
5603 !!$
5604 !!$ real, pointer, dimension(:,:,:) :: agrid, grid
5605 !!$ real, pointer, dimension(:,:) :: area, rarea
5606 !!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5607 !!$
5608 !!$ grid => gridstruct%grid
5609 !!$ agrid => gridstruct%agrid
5610 !!$
5611 !!$ area => gridstruct%area
5612 !!$ rarea => gridstruct%rarea
5613 !!$
5614 !!$ dx => gridstruct%dx
5615 !!$ dy => gridstruct%dy
5616 !!$ dxa => gridstruct%dxa
5617 !!$ dya => gridstruct%dya
5618 !!$ rdxa => gridstruct%rdxa
5619 !!$ rdya => gridstruct%rdya
5620 !!$ dxc => gridstruct%dxc
5621 !!$ dyc => gridstruct%dyc
5622 !!$
5623 !!$ allocate( tmp(npx ,npy ,nregions) )
5624 !!$ allocate( tmpA(npx-1,npy-1,nregions) )
5625 !!$#if defined(SW_DYNAMICS)
5626 !!$ allocate( ut(npx-1,npy-1,nregions) )
5627 !!$ allocate( vt(npx-1,npy-1,nregions) )
5628 !!$#else
5629 !!$ allocate( ut(npx-1,npy-1,npz,nregions) )
5630 !!$ allocate( vt(npx-1,npy-1,npz,nregions) )
5631 !!$ allocate( tmpA_3d(npx-1,npy-1,npz,nregions) )
5632 !!$#endif
5633 !!$ allocate( vort(isd:ied,jsd:jed) )
5634 !!$
5635 !!$ nout = nout + 1
5636 !!$
5637 !!$ if (nt==0) then
5638 !!$ tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2)
5639 !!$ 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)
5640 !!$ tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1)
5641 !!$ 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)
5642 !!$ endif
5643 !!$
5644 !!$#if defined(SW_DYNAMICS)
5645 !!$ if (test_case > 1) then
5646 !!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav
5647 !!$
5648 !!$ if ((nt==0) .and. (test_case==2)) then
5649 !!$ Ubar = (2.0*pi*radius)/(12.0*86400.0)
5650 !!$ gh0 = 2.94e4
5651 !!$ phis = 0.0
5652 !!$ do j=js,je+1
5653 !!$ do i=is,ie+1
5654 !!$ tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
5655 !!$ ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5656 !!$ sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav
5657 !!$ enddo
5658 !!$ enddo
5659 !!$ endif
5660 !!$
5661 !!$ else
5662 !!$
5663 !!$ if (test_case==1) then
5664 !!$! Get Current Height Field "Truth"
5665 !!$ p1(1) = pi/2. + pi_shift
5666 !!$ p1(2) = 0.
5667 !!$ p2(1) = 3.*pi/2. + pi_shift
5668 !!$ p2(2) = 0.
5669 !!$ r0 = radius/3. !RADIUS /3.
5670 !!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
5671 !!$ heading = 5.0*pi/2.0 - alpha
5672 !!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5673 !!$ do j=jsd,jed
5674 !!$ do i=isd,ied
5675 !!$ p2(1) = agrid(i,j,1)
5676 !!$ p2(2) = agrid(i,j,2)
5677 !!$ r = great_circle_dist( p3, p2, radius )
5678 !!$ if (r < r0) then
5679 !!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
5680 !!$ else
5681 !!$ phi0(i,j,1) = phis(i,j)
5682 !!$ endif
5683 !!$ enddo
5684 !!$ enddo
5685 !!$ elseif (test_case == 0) then
5686 !!$ phi0 = 0.0
5687 !!$ do j=jsd,jed
5688 !!$ do i=isd,ied
5689 !!$ x1 = agrid(i,j,1)
5690 !!$ y1 = agrid(i,j,2)
5691 !!$ z1 = radius
5692 !!$ p = p0_c0 * cos(y1)
5693 !!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5694 !!$ w_p = 0.0
5695 !!$ if (p /= 0.0) w_p = Vtx/p
5696 !!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5697 !!$ enddo
5698 !!$ enddo
5699 !!$ endif
5700 !!$
5701 !!$ tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5702 !!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5703 !!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5704 !!$ endif
5705 !!$ call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5706 !!$
5707 !!$ if (test_case == 9) then
5708 !!$! Calc Vorticity
5709 !!$ do j=jsd,jed
5710 !!$ do i=isd,ied
5711 !!$ 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)) - &
5712 !!$ (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5713 !!$ vort(i,j) = Grav*vort(i,j)/delp(i,j,1)
5714 !!$ enddo
5715 !!$ enddo
5716 !!$ tmpA(is:ie,js:je,tile) = vort(is:ie,js:je)
5717 !!$ call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5718 !!$ endif
5719 !!$
5720 !!$ call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%bounded_domain, flagstruct%c2l_ord, bd)
5721 !!$ do j=js,je
5722 !!$ do i=is,ie
5723 !!$ ut(i,j,tile) = ua(i,j,1)
5724 !!$ vt(i,j,tile) = va(i,j,1)
5725 !!$ enddo
5726 !!$ enddo
5727 !!$
5728 !!$ 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)
5729 !!$ 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)
5730 !!$
5731 !!$ if ((test_case >= 2) .and. (nt==0) ) then
5732 !!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
5733 !!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA, 3)
5734 !!$ endif
5735 !!$#else
5736 !!$
5737 !!$! Write Moisture Data
5738 !!$ tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1)
5739 !!$ call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5740 !!$
5741 !!$! Write Tracer Data
5742 !!$ do iq=2,ncnst
5743 !!$ tmpA_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq)
5744 !!$ call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5745 !!$ enddo
5746 !!$
5747 !!$! Write Surface height data
5748 !!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
5749 !!$ call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3)
5750 !!$
5751 !!$! Write Pressure Data
5752 !!$ tmpA(is:ie,js:je,tile) = ps(is:ie,js:je)
5753 !!$ call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpA, 3)
5754 !!$ do k=1,npz
5755 !!$ tmpA_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/Grav
5756 !!$ enddo
5757 !!$ call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5758 !!$
5759 !!$! Write PT Data
5760 !!$ do k=1,npz
5761 !!$ tmpA_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k)
5762 !!$ enddo
5763 !!$ call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5764 !!$
5765 !!$! Write U,V Data
5766 !!$ call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%bounded_domain, flagstruct%c2l_ord)
5767 !!$ do k=1,npz
5768 !!$ do j=js,je
5769 !!$ do i=is,ie
5770 !!$ ut(i,j,k,tile) = ua(i,j,k)
5771 !!$ vt(i,j,k,tile) = va(i,j,k)
5772 !!$ enddo
5773 !!$ enddo
5774 !!$ enddo
5775 !!$ 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)
5776 !!$ 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)
5777 !!$
5778 !!$
5779 !!$! Calc Vorticity
5780 !!$ do k=1,npz
5781 !!$ do j=js,je
5782 !!$ do i=is,ie
5783 !!$ 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)) - &
5784 !!$ (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
5785 !!$ enddo
5786 !!$ enddo
5787 !!$ enddo
5788 !!$ call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5789 !!$!
5790 !!$! Output omega (dp/dt):
5791 !!$ do k=1,npz
5792 !!$ do j=js,je
5793 !!$ do i=is,ie
5794 !!$ tmpA_3d(i,j,k,tile) = omga(i,j,k)
5795 !!$ enddo
5796 !!$ enddo
5797 !!$ enddo
5798 !!$ call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpA_3d, 4)
5799 !!$
5800 !!$#endif
5801 !!$
5802 !!$ deallocate( tmp )
5803 !!$ deallocate( tmpA )
5804 !!$#if defined(SW_DYNAMICS)
5805 !!$ deallocate( ut )
5806 !!$ deallocate( vt )
5807 !!$#else
5808 !!$ deallocate( ut )
5809 !!$ deallocate( vt )
5810 !!$ deallocate( tmpA_3d )
5811 !!$#endif
5812 !!$ deallocate( vort )
5813 !!$
5814 !!$ nullify(grid)
5815 !!$ nullify(agrid)
5816 !!$
5817 !!$ nullify(area)
5818 !!$
5819 !!$ nullify(dx)
5820 !!$ nullify(dy)
5821 !!$ nullify(dxa)
5822 !!$ nullify(dya)
5823 !!$ nullify(rdxa)
5824 !!$ nullify(rdya)
5825 !!$ nullify(dxc)
5826 !!$ nullify(dyc)
5827 !!$
5828 !!$ end subroutine output_ncdf
5829 !!$
5830 !!$!
5831 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5832 !!$!-------------------------------------------------------------------------------
5833 !!$
5834 !!$!-------------------------------------------------------------------------------
5835 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5836 !!$!
5837 !!$! output :: write out fields
5838 !!$!
5839 !!$ subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5840 !!$ npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, &
5841 !!$ pt_lun, pv_lun, uv_lun, gridstruct)
5842 !!$
5843 !!$ real, intent(IN) :: dt
5844 !!$ integer, intent(IN) :: nt, maxnt
5845 !!$ integer, intent(INOUT) :: nout
5846 !!$
5847 !!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5848 !!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5849 !!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5850 !!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5851 !!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5852 !!$
5853 !!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5854 !!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5855 !!$
5856 !!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5857 !!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5858 !!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5859 !!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5860 !!$
5861 !!$ integer, intent(IN) :: npx, npy, npz
5862 !!$ integer, intent(IN) :: ng, ncnst
5863 !!$ integer, intent(IN) :: ndims
5864 !!$ integer, intent(IN) :: nregions
5865 !!$ integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun
5866 !!$
5867 !!$ type(fv_grid_type), target :: gridstruct
5868 !!$
5869 !!$ real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
5870 !!$ real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions)
5871 !!$ real :: p1(2) ! Temporary Point
5872 !!$ real :: p2(2) ! Temporary Point
5873 !!$ real :: p3(2) ! Temporary Point
5874 !!$ real :: p4(2) ! Temporary Point
5875 !!$ real :: pa(2) ! Temporary Point
5876 !!$ real :: ut(1:npx,1:npy,1:nregions)
5877 !!$ real :: vt(1:npx,1:npy,1:nregions)
5878 !!$ real :: utmp, vtmp, r, r0, dist, heading
5879 !!$ integer :: i,j,k,n,nreg
5880 !!$ real :: vort(isd:ied,jsd:jed)
5881 !!$
5882 !!$ real :: Vtx, p, w_p
5883 !!$ real :: x1,y1,z1,x2,y2,z2,ang
5884 !!$
5885 !!$ real, pointer, dimension(:,:,:) :: agrid, grid
5886 !!$ real, pointer, dimension(:,:) :: area, rarea
5887 !!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5888 !!$
5889 !!$ grid => gridstruct%grid
5890 !!$ agrid => gridstruct%agrid
5891 !!$
5892 !!$ area => gridstruct%area
5893 !!$
5894 !!$ dx => gridstruct%dx
5895 !!$ dy => gridstruct%dy
5896 !!$ dxa => gridstruct%dxa
5897 !!$ dya => gridstruct%dya
5898 !!$ rdxa => gridstruct%rdxa
5899 !!$ rdya => gridstruct%rdya
5900 !!$ dxc => gridstruct%dxc
5901 !!$ dyc => gridstruct%dyc
5902 !!$
5903 !!$ cubed_sphere => gridstruct%cubed_sphere
5904 !!$
5905 !!$ nout = nout + 1
5906 !!$
5907 !!$#if defined(SW_DYNAMICS)
5908 !!$ if (test_case > 1) then
5909 !!$ call atob_s(delp(:,:,1)/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1)
5910 !!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)/Grav
5911 !!$
5912 !!$ if ((nt==0) .and. (test_case==2)) then
5913 !!$ Ubar = (2.0*pi*radius)/(12.0*86400.0)
5914 !!$ gh0 = 2.94e4
5915 !!$ phis = 0.0
5916 !!$ do j=js,je+1
5917 !!$ do i=is,ie+1
5918 !!$ tmp(i,j,tile) = (gh0 - (radius*omega*Ubar + (Ubar*Ubar)/2.) * &
5919 !!$ ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5920 !!$ sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / Grav
5921 !!$ enddo
5922 !!$ enddo
5923 !!$ endif
5924 !!$
5925 !!$ else
5926 !!$
5927 !!$ if (test_case==1) then
5928 !!$! Get Current Height Field "Truth"
5929 !!$ p1(1) = pi/2. + pi_shift
5930 !!$ p1(2) = 0.
5931 !!$ p2(1) = 3.*pi/2. + pi_shift
5932 !!$ p2(2) = 0.
5933 !!$ r0 = radius/3. !RADIUS /3.
5934 !!$ dist = 2.0*pi*radius* ((FLOAT(nt)/FLOAT(maxnt)))
5935 !!$ heading = 5.0*pi/2.0 - alpha
5936 !!$ call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5937 !!$ do j=jsd,jed
5938 !!$ do i=isd,ied
5939 !!$ p2(1) = agrid(i,j,1)
5940 !!$ p2(2) = agrid(i,j,2)
5941 !!$ r = great_circle_dist( p3, p2, radius )
5942 !!$ if (r < r0) then
5943 !!$ phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(PI*r/r0))
5944 !!$ else
5945 !!$ phi0(i,j,1) = phis(i,j)
5946 !!$ endif
5947 !!$ enddo
5948 !!$ enddo
5949 !!$ elseif (test_case == 0) then
5950 !!$ phi0 = 0.0
5951 !!$ do j=jsd,jed
5952 !!$ do i=isd,ied
5953 !!$ x1 = agrid(i,j,1)
5954 !!$ y1 = agrid(i,j,2)
5955 !!$ z1 = radius
5956 !!$ p = p0_c0 * cos(y1)
5957 !!$ Vtx = ((3.0*SQRT(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5958 !!$ w_p = 0.0
5959 !!$ if (p /= 0.0) w_p = Vtx/p
5960 !!$ phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5961 !!$ enddo
5962 !!$ enddo
5963 !!$ endif
5964 !!$
5965 !!$ call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1)
5966 !!$ tmpA(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5967 !!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5968 !!$ call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1)
5969 !!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5970 !!$ endif
5971 !!$ ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5972 !!$ call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
5973 !!$
5974 !!$ if (test_case == 9) then
5975 !!$! Calc Vorticity
5976 !!$ do j=jsd,jed
5977 !!$ do i=isd,ied
5978 !!$ 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)) - &
5979 !!$ (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5980 !!$ vort(i,j) = Grav*vort(i,j)/delp(i,j,1)
5981 !!$ enddo
5982 !!$ enddo
5983 !!$ call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1)
5984 !!$ call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5985 !!$ endif
5986 !!$
5987 !!$ call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
5988 !!$! Rotate winds to standard Lat-Lon orientation
5989 !!$ if (cubed_sphere) then
5990 !!$ do j=js,je
5991 !!$ do i=is,ie
5992 !!$ call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5993 !!$ call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5994 !!$ call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5995 !!$ call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5996 !!$ utmp = ua(i,j,1)
5997 !!$ vtmp = va(i,j,1)
5998 !!$ if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5999 !!$ ut(i,j,tile) = utmp
6000 !!$ vt(i,j,tile) = vtmp
6001 !!$ enddo
6002 !!$ enddo
6003 !!$ endif
6004 !!$
6005 !!$ call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions))
6006 !!$ call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions))
6007 !!$
6008 !!$ if ((test_case >= 2) .and. (nt==0) ) then
6009 !!$ call atob_s(phis/Grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%bounded_domain) !, altInterp=1)
6010 !!$ ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
6011 !!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
6012 !!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
6013 !!$ endif
6014 !!$#else
6015 !!$
6016 !!$! Write Surface height data
6017 !!$ if (nt==0) then
6018 !!$ tmpA(is:ie,js:je,tile) = phis(is:ie,js:je)/Grav
6019 !!$ call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpA(1:npx-1,1:npy-1,1:nregions))
6020 !!$ endif
6021 !!$
6022 !!$! Write Pressure Data
6023 !!$
6024 !!$ !if (tile==2) then
6025 !!$ ! do i=is,ie
6026 !!$ ! print*, i, ps(i,35)
6027 !!$ ! enddo
6028 !!$ !endif
6029 !!$ tmpA(is:ie,js:je,tile) = ps(is:ie,js:je)
6030 !!$ 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))
6031 !!$ do k=1,npz
6032 !!$ tmpA(is:ie,js:je,tile) = delp(is:ie,js:je,k)/Grav
6033 !!$ 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))
6034 !!$ enddo
6035 !!$
6036 !!$! Write PT Data
6037 !!$ do k=1,npz
6038 !!$ tmpA(is:ie,js:je,tile) = pt(is:ie,js:je,k)
6039 !!$ 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))
6040 !!$ enddo
6041 !!$
6042 !!$! Write U,V Data
6043 !!$ do k=1,npz
6044 !!$ 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)
6045 !!$! Rotate winds to standard Lat-Lon orientation
6046 !!$ if (cubed_sphere) then
6047 !!$ do j=js,je
6048 !!$ do i=is,ie
6049 !!$ call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
6050 !!$ call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
6051 !!$ call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
6052 !!$ call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
6053 !!$ utmp = ua(i,j,k)
6054 !!$ vtmp = va(i,j,k)
6055 !!$ if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
6056 !!$ ut(i,j,tile) = utmp
6057 !!$ vt(i,j,tile) = vtmp
6058 !!$ enddo
6059 !!$ enddo
6060 !!$ endif
6061 !!$ 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))
6062 !!$ 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))
6063 !!$ enddo
6064 !!$#endif
6065 !!$
6066 !!$ nullify(grid)
6067 !!$ nullify(agrid)
6068 !!$
6069 !!$ nullify(area)
6070 !!$
6071 !!$ nullify(dx)
6072 !!$ nullify(dy)
6073 !!$ nullify(dxa)
6074 !!$ nullify(dya)
6075 !!$ nullify(rdxa)
6076 !!$ nullify(rdya)
6077 !!$ nullify(dxc)
6078 !!$ nullify(dyc)
6079 !!$
6080 !!$ nullify(cubed_sphere)
6081 !!$
6082 !!$ end subroutine output
6083 !!$!
6084 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6085 !!$!-------------------------------------------------------------------------------
6086 !!$
6087 !!$!-------------------------------------------------------------------------------
6088 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6089 !!$! wrt2d_ncdf :: write out a 2d field
6090 !!$!
6091 !!$ subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims)
6092 !!$#include <netcdf.inc>
6093 !!$ integer, intent(IN) :: ncid, varid
6094 !!$ integer, intent(IN) :: nrec
6095 !!$ integer, intent(IN) :: i1,i2,j1,j2
6096 !!$ integer, intent(IN) :: npx
6097 !!$ integer, intent(IN) :: npy
6098 !!$ integer, intent(IN) :: npz
6099 !!$ integer, intent(IN) :: ntiles
6100 !!$ real , intent(IN) :: p(npx-1,npy-1,npz,ntiles)
6101 !!$ integer, intent(IN) :: ndims
6102 !!$
6103 !!$ integer :: error
6104 !!$ real(kind=4), allocatable :: p_R4(:,:,:,:)
6105 !!$ integer :: i,j,k,n
6106 !!$ integer :: istart(ndims+1), icount(ndims+1)
6107 !!$
6108 !!$ allocate( p_R4(npx-1,npy-1,npz,ntiles) )
6109 !!$
6110 !!$ p_R4(:,:,:,:) = missing
6111 !!$ p_R4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile)
6112 !!$ call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles)
6113 !!$
6114 !!$ istart(:) = 1
6115 !!$ istart(ndims+1) = nrec
6116 !!$ icount(1) = npx-1
6117 !!$ icount(2) = npy-1
6118 !!$ icount(3) = npz
6119 !!$ if (ndims == 3) icount(3) = ntiles
6120 !!$ if (ndims == 4) icount(4) = ntiles
6121 !!$ icount(ndims+1) = 1
6122 !!$
6123 !!$ if (is_master()) then
6124 !!$ error = NF_PUT_VARA_REAL(ncid, varid, istart, icount, p_R4)
6125 !!$ endif ! masterproc
6126 !!$
6127 !!$ deallocate( p_R4 )
6128 !!$
6129 !!$ end subroutine wrtvar_ncdf
6130 !!$!
6131 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6132 !!$!-------------------------------------------------------------------------------
6133 !!$
6134 !!$!-------------------------------------------------------------------------------
6135 !!$! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6136 !!$! wrt2d :: write out a 2d field
6137 !!$!
6138 !!$ subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p)
6139 !!$ integer, intent(IN) :: iout
6140 !!$ integer, intent(IN) :: nrec
6141 !!$ integer, intent(IN) :: i1,i2,j1,j2
6142 !!$ integer, intent(IN) :: npx
6143 !!$ integer, intent(IN) :: npy
6144 !!$ integer, intent(IN) :: nregions
6145 !!$ real , intent(IN) :: p(npx-1,npy-1,nregions)
6146 !!$
6147 !!$ real(kind=4) :: p_R4(npx-1,npy-1,nregions)
6148 !!$ integer :: i,j,n
6149 !!$
6150 !!$ do n=tile,tile
6151 !!$ do j=j1,j2
6152 !!$ do i=i1,i2
6153 !!$ p_R4(i,j,n) = p(i,j,n)
6154 !!$ enddo
6155 !!$ enddo
6156 !!$ enddo
6157 !!$
6158 !!$ call mp_gather(p_R4, i1,i2, j1,j2, npx-1, npy-1, nregions)
6159 !!$
6160 !!$ if (is_master()) then
6161 !!$ write(iout,rec=nrec) p_R4(1:npx-1,1:npy-1,1:nregions)
6162 !!$ endif ! masterproc
6163 !!$
6164 !!$ end subroutine wrt2d
6165 !!$!
6166 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
6167 !!$!-------------------------------------------------------------------------------
6168 !!$#endif
6169 !-------------------------------------------------------------------------------
6170 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
6171 ! init_double_periodic
6172 !
6173  subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
6174  gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, &
6175  mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd)
6176 
6177 
6178  type(fv_grid_bounds_type), intent(IN) :: bd
6179  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6180  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6181  real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
6182  real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6183  real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6184  real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
6185 
6186  real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
6187 
6188  real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
6189  real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
6190  real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
6191  real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
6192  real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
6193  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6194  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6195  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6196  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6197  real , intent(inout) :: delz(bd%is:,bd%js:,1:)
6198  real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
6199 
6200  real , intent(inout) :: ak(npz+1)
6201  real , intent(inout) :: bk(npz+1)
6202 
6203  integer, intent(IN) :: npx, npy, npz
6204  integer, intent(IN) :: ng, ncnst, nwat
6205  integer, intent(IN) :: ndims
6206  integer, intent(IN) :: nregions
6207 
6208  real, intent(IN) :: dry_mass
6209  logical, intent(IN) :: mountain
6210  logical, intent(IN) :: moist_phys
6211  logical, intent(IN) :: hydrostatic, hybrid_z
6212  integer, intent(INOUT) :: ks
6213  integer, intent(INOUT), target :: tile_in
6214  real, intent(INOUT) :: ptop
6215 
6216  type(domain2d), intent(IN), target :: domain_in
6217 
6218  type(fv_grid_type), target :: gridstruct
6219  type(fv_flags_type), target :: flagstruct
6220 
6221  real, dimension(bd%is:bd%ie):: pm, qs
6222  real, dimension(1:npz):: pk1, ts1, qs1
6223  real :: us0 = 30.
6224  real :: dist, r0, f0_const, prf, rgrav
6225  real :: ptmp, ze, zc, zm, utmp, vtmp
6226  real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop
6227  real :: ze1(npz+1)
6228  real:: dz1(npz)
6229  real:: zvir
6230  integer :: i, j, k, m, icenter, jcenter
6231 
6232  real, pointer, dimension(:,:,:) :: agrid, grid
6233  real(kind=R_GRID), pointer, dimension(:,:) :: area
6234  real, pointer, dimension(:,:) :: rarea, fC, f0
6235  real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
6236  real, pointer, dimension(:,:,:,:) :: ew, es
6237  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
6238 
6239  logical, pointer :: cubed_sphere, latlon
6240 
6241  type(domain2d), pointer :: domain
6242  integer, pointer :: tile
6243 
6244  logical, pointer :: have_south_pole, have_north_pole
6245 
6246  integer, pointer :: ntiles_g
6247  real, pointer :: acapN, acapS, globalarea
6248 
6249  real(kind=R_GRID), pointer :: dx_const, dy_const
6250 
6251  integer :: is, ie, js, je
6252  integer :: isd, ied, jsd, jed
6253 
6254  is = bd%is
6255  ie = bd%ie
6256  js = bd%js
6257  je = bd%je
6258  isd = bd%isd
6259  ied = bd%ied
6260  jsd = bd%jsd
6261  jed = bd%jed
6262 
6263  agrid => gridstruct%agrid
6264  grid => gridstruct%grid
6265 
6266  area => gridstruct%area_64
6267 
6268  dx => gridstruct%dx
6269  dy => gridstruct%dy
6270  dxa => gridstruct%dxa
6271  dya => gridstruct%dya
6272  rdxa => gridstruct%rdxa
6273  rdya => gridstruct%rdya
6274  dxc => gridstruct%dxc
6275  dyc => gridstruct%dyc
6276 
6277  fc => gridstruct%fC
6278  f0 => gridstruct%f0
6279 
6280  !These are frequently used and so have pointers set up for them
6281  dx_const => flagstruct%dx_const
6282  dy_const => flagstruct%dy_const
6283 
6284  domain => domain_in
6285  tile => tile_in
6286 
6287  have_south_pole => gridstruct%have_south_pole
6288  have_north_pole => gridstruct%have_north_pole
6289 
6290  ntiles_g => gridstruct%ntiles_g
6291  acapn => gridstruct%acapN
6292  acaps => gridstruct%acapS
6293  globalarea => gridstruct%globalarea
6294 
6295  f0_const = 2.*omega*sin(flagstruct%deglat/180.*pi)
6296  f0(:,:) = f0_const
6297  fc(:,:) = f0_const
6298 
6299  q = 0.
6300 
6301  select case (test_case)
6302  case ( 1 )
6303 
6304  phis(:,:)=0.
6305 
6306  u(:,:,:)=10.
6307  v(:,:,:)=10.
6308  ua(:,:,:)=10.
6309  va(:,:,:)=10.
6310  uc(:,:,:)=10.
6311  vc(:,:,:)=10.
6312  pt(:,:,:)=1.
6313  delp(:,:,:)=0.
6314 
6315  do j=js,je
6316  if (j>0 .and. j<5) then
6317  do i=is,ie
6318  if (i>0 .and. i<5) then
6319  delp(i,j,:)=1.
6320  endif
6321  enddo
6322  endif
6323  enddo
6324  call mpp_update_domains( delp, domain )
6325 
6326  case ( 2 )
6327 
6328  phis(:,:) = 0.
6329 
6330 ! r0 = 5000.
6331  r0 = 5.*sqrt(dx_const**2 + dy_const**2)
6332  icenter = npx/2
6333  jcenter = npy/2
6334  do j=jsd,jed
6335  do i=isd,ied
6336  dist=(i-icenter)*dx_const*(i-icenter)*dx_const &
6337  +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6338  dist=min(r0,sqrt(dist))
6339  phis(i,j)=1500.*(1. - (dist/r0))
6340  enddo
6341  enddo
6342 
6343  u(:,:,:)=0.
6344  v(:,:,:)=0.
6345  ua(:,:,:)=0.
6346  va(:,:,:)=0.
6347  uc(:,:,:)=0.
6348  vc(:,:,:)=0.
6349  pt(:,:,:)=1.
6350  delp(:,:,:)=1500.
6351 
6352  case ( 14 )
6353 !---------------------------
6354 ! Doubly periodic Aqua-plane
6355 !---------------------------
6356  u(:,:,:) = 0.
6357  v(:,:,:) = 0.
6358  phis(:,:) = 0.
6359 
6360  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
6361  delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
6362 
6363  ! *** Add Initial perturbation ***
6364  if (bubble_do) then
6365  r0 = 100.*sqrt(dx_const**2 + dy_const**2)
6366  icenter = npx/2
6367  jcenter = npy/2
6368 
6369  do j=js,je
6370  do i=is,ie
6371  dist = (i-icenter)*dx_const*(i-icenter)*dx_const &
6372  +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6373  dist = min(r0, sqrt(dist))
6374  do k=1,npz
6375  prf = ak(k) + ps(i,j)*bk(k)
6376  if ( prf > 100.e2 ) then
6377  pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j)
6378  endif
6379  enddo
6380  enddo
6381  enddo
6382  endif
6383  if ( hydrostatic ) then
6384  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6385  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6386  moist_phys, .true., nwat , domain, flagstruct%adiabatic)
6387  else
6388  w(:,:,:) = 0.
6389  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6390  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6391  moist_phys, hydrostatic, nwat, domain, flagstruct%adiabatic, .true. )
6392  endif
6393 
6394  q = 0.
6395  do k=1,npz
6396  do j=js,je
6397  do i=is,ie
6398  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6399  enddo
6400 #ifdef MULTI_GASES
6401  call qsmith((ie-is+1)*(je-js+1), npz, &
6402  ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6403 #else
6404  call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6405 #endif
6406  do i=is,ie
6407  q(i,j,k,1) = max(2.e-6, 0.8*pm(i)/ps(i,j)*qs(i) )
6408  enddo
6409  enddo
6410  enddo
6411 
6412  case ( 15 )
6413 !---------------------------
6414 ! Doubly periodic bubble
6415 !---------------------------
6416  t00 = 250.
6417 
6418  u(:,:,:) = 0.
6419  v(:,:,:) = 0.
6420  pt(:,:,:) = t00
6421  q(:,:,:,:) = 1.e-6
6422 
6423  if ( .not. hydrostatic ) w(:,:,:) = 0.
6424 
6425  do j=jsd,jed
6426  do i=isd,ied
6427  phis(i,j) = 0.
6428  ps(i,j) = 1000.e2
6429  enddo
6430  enddo
6431 
6432  do k=1,npz
6433  do j=jsd,jed
6434  do i=isd,ied
6435  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6436  enddo
6437  enddo
6438  enddo
6439 
6440 
6441  do k=1,npz
6442  do j=jsd,jed
6443  do i=isd,ied
6444  ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6445 ! pt(i,j,k) = t00
6446  enddo
6447  enddo
6448  enddo
6449 
6450  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6451  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6452  moist_phys, .false., nwat, domain, flagstruct%adiabatic)
6453 
6454 ! *** Add Initial perturbation ***
6455  r0 = 5.*max(dx_const, dy_const)
6456  zc = 0.5e3 ! center of bubble from surface
6457  icenter = npx/2
6458  jcenter = npy/2
6459 
6460  do j=js,je
6461  do i=is,ie
6462  ze = 0.
6463  do k=npz,1,-1
6464  zm = ze - 0.5*delz(i,j,k) ! layer center
6465  ze = ze - delz(i,j,k)
6466  dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + &
6467  (zm-zc)**2
6468  dist = sqrt(dist)
6469  if ( dist <= r0 ) then
6470  pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
6471  endif
6472  enddo
6473  enddo
6474  enddo
6475 
6476  case ( 16 )
6477 !------------------------------------
6478 ! Non-hydrostatic 3D density current:
6479 !------------------------------------
6480  phis = 0.
6481  u = 0.
6482  v = 0.
6483  w = 0.
6484  t00 = 300.
6485  p00 = 1.e5
6486  pk0 = p00**kappa
6487 ! Set up vertical coordinare with constant del-z spacing:
6488 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
6489  ztop = 6.4e3
6490  ze1( 1) = ztop
6491  ze1(npz+1) = 0.
6492  do k=npz,2,-1
6493  ze1(k) = ze1(k+1) + ztop/real(npz)
6494  enddo
6495 
6496  do j=js,je
6497  do i=is,ie
6498  ps(i,j) = p00
6499  pe(i,npz+1,j) = p00
6500  pk(i,j,npz+1) = pk0
6501  enddo
6502  enddo
6503 
6504  do k=npz,1,-1
6505  do j=js,je
6506  do i=is,ie
6507  delz(i,j,k) = ze1(k+1) - ze1(k)
6508  pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
6509  pe(i,k,j) = pk(i,j,k)**(1./kappa)
6510  enddo
6511  enddo
6512  enddo
6513 
6514  ptop = pe(is,1,js)
6515  if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
6516 
6517  do k=1,npz+1
6518  do j=js,je
6519  do i=is,ie
6520  peln(i,k,j) = log(pe(i,k,j))
6521  ze0(i,j,k) = ze1(k)
6522  enddo
6523  enddo
6524  enddo
6525 
6526  do k=1,npz
6527  do j=js,je
6528  do i=is,ie
6529  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6530  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6531  pt(i,j,k) = t00/pk0 ! potential temp
6532  enddo
6533  enddo
6534  enddo
6535 
6536  pturb = 15.
6537  xmax = 51.2e3
6538  xc = xmax / 2.
6539 
6540  do k=1,npz
6541  zm = (0.5*(ze1(k)+ze1(k+1))-3.e3) / 2.e3
6542  do j=js,je
6543  do i=is,ie
6544 ! Impose perturbation in potential temperature: pturb
6545  xx = (dx_const * (0.5+real(i-1)) - xc) / 4.e3
6546  yy = (dy_const * (0.5+real(j-1)) - xc) / 4.e3
6547  dist = sqrt( xx**2 + yy**2 + zm**2 )
6548  if ( dist<=1. ) then
6549  pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
6550  endif
6551 ! Transform back to temperature:
6552  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
6553  enddo
6554  enddo
6555  enddo
6556 
6557  case ( 17 )
6558 !---------------------------
6559 ! Doubly periodic SuperCell, straight wind (v==0)
6560 !--------------------------
6561  zvir = rvgas/rdgas - 1.
6562  p00 = 1000.e2
6563  ps(:,:) = p00
6564  phis(:,:) = 0.
6565  do j=js,je
6566  do i=is,ie
6567  pk(i,j,1) = ptop**kappa
6568  pe(i,1,j) = ptop
6569  peln(i,1,j) = log(ptop)
6570  enddo
6571  enddo
6572 
6573  do k=1,npz
6574  do j=js,je
6575  do i=is,ie
6576  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6577  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6578  peln(i,k+1,j) = log(pe(i,k+1,j))
6579  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6580  enddo
6581  enddo
6582  enddo
6583 
6584  i = is
6585  j = js
6586  do k=1,npz
6587  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6588  enddo
6589 
6590 #ifndef GFS_PHYS
6591  call supercell_sounding(npz, p00, pk1, ts1, qs1)
6592 #endif
6593 
6594  v(:,:,:) = 0.
6595  w(:,:,:) = 0.
6596  q(:,:,:,:) = 0.
6597 
6598  do k=1,npz
6599  do j=js,je
6600  do i=is,ie
6601  pt(i,j,k) = ts1(k)
6602  q(i,j,k,1) = qs1(k)
6603  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6604  enddo
6605  enddo
6606  enddo
6607 
6608  ze1(npz+1) = 0.
6609  do k=npz,1,-1
6610  ze1(k) = ze1(k+1) - delz(is,js,k)
6611  enddo
6612 
6613  do k=1,npz
6614  zm = 0.5*(ze1(k)+ze1(k+1))
6615  utmp = us0*tanh(zm/3.e3)
6616  do j=js,je+1
6617  do i=is,ie
6618  u(i,j,k) = utmp
6619  enddo
6620  enddo
6621  enddo
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, flagstruct%adiabatic)
6626 
6627 ! *** Add Initial perturbation ***
6628  pturb = 2.
6629  r0 = 10.e3
6630  zc = 1.4e3 ! center of bubble from surface
6631  icenter = (npx-1)/3 + 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 
6648  case ( 18 )
6649 !---------------------------
6650 ! Doubly periodic SuperCell, quarter circle hodograph
6651 ! M. Toy, Apr 2013, MWR
6652  pturb = 2.5
6653  zvir = rvgas/rdgas - 1.
6654  p00 = 1000.e2
6655  ps(:,:) = p00
6656  phis(:,:) = 0.
6657  do j=js,je
6658  do i=is,ie
6659  pk(i,j,1) = ptop**kappa
6660  pe(i,1,j) = ptop
6661  peln(i,1,j) = log(ptop)
6662  enddo
6663  enddo
6664 
6665  do k=1,npz
6666  do j=js,je
6667  do i=is,ie
6668  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6669  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6670  peln(i,k+1,j) = log(pe(i,k+1,j))
6671  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6672  enddo
6673  enddo
6674  enddo
6675 
6676  i = is
6677  j = js
6678  do k=1,npz
6679  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6680  enddo
6681 #ifndef GFS_PHYS
6682 
6683  call supercell_sounding(npz, p00, pk1, ts1, qs1)
6684 #endif
6685  w(:,:,:) = 0.
6686  q(:,:,:,:) = 0.
6687 
6688  do k=1,npz
6689  do j=js,je
6690  do i=is,ie
6691  pt(i,j,k) = ts1(k)
6692  q(i,j,k,1) = qs1(k)
6693  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6694  enddo
6695  enddo
6696  enddo
6697 
6698  ze1(npz+1) = 0.
6699  do k=npz,1,-1
6700  ze1(k) = ze1(k+1) - delz(is,js,k)
6701  enddo
6702 
6703 ! Quarter-circle hodograph (Harris approximation)
6704  us0 = 30.
6705  do k=1,npz
6706  zm = 0.5*(ze1(k)+ze1(k+1))
6707  if ( zm .le. 2.e3 ) then
6708  utmp = 8.*(1.-cos(pi*zm/4.e3))
6709  vtmp = 8.*sin(pi*zm/4.e3)
6710  elseif (zm .le. 6.e3 ) then
6711  utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
6712  vtmp = 8.
6713  else
6714  utmp = us0
6715  vtmp = 8.
6716  endif
6717 ! u-wind
6718  do j=js,je+1
6719  do i=is,ie
6720  u(i,j,k) = utmp - 8.
6721  enddo
6722  enddo
6723 ! v-wind
6724  do j=js,je
6725  do i=is,ie+1
6726  v(i,j,k) = vtmp - 4.
6727  enddo
6728  enddo
6729  enddo
6730 
6731 
6732  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6733  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6734  .true., hydrostatic, nwat, domain, flagstruct%adiabatic)
6735 
6736 ! *** Add Initial perturbation ***
6737  if (bubble_do) then
6738  r0 = 10.e3
6739  zc = 1.4e3 ! center of bubble from surface
6740  icenter = (npx-1)/2 + 1
6741  jcenter = (npy-1)/2 + 1
6742  do k=1, npz
6743  zm = 0.5*(ze1(k)+ze1(k+1))
6744  ptmp = ( (zm-zc)/zc ) **2
6745  if ( ptmp < 1. ) then
6746  do j=js,je
6747  do i=is,ie
6748  dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6749  if ( dist < 1. ) then
6750  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6751  endif
6752  enddo
6753  enddo
6754  endif
6755  enddo
6756  endif
6757 
6758  case ( 101 )
6759 
6760 ! IC for LES
6761  t00 = 250. ! constant temp
6762  p00 = 1.e5
6763  pk0 = p00**kappa
6764 
6765  phis = 0.
6766  u = 0.
6767  v = 0.
6768  w = 0.
6769  pt(:,:,:) = t00
6770  q(:,:,:,1) = 0.
6771 
6772  if (.not.hybrid_z) call mpp_error(fatal, 'hybrid_z must be .TRUE.')
6773 
6774  rgrav = 1./ grav
6775 
6776  if ( npz/=101) then
6777  call mpp_error(fatal, 'npz must be == 101 ')
6778  else
6779  call compute_dz_l101( npz, ztop, dz1 )
6780  endif
6781 
6782  call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
6783  phis, ze0, delz)
6784 
6785  do j=js,je
6786  do i=is,ie
6787  ps(i,j) = p00
6788  pe(i,npz+1,j) = p00
6789  pk(i,j,npz+1) = pk0
6790  peln(i,npz+1,j) = log(p00)
6791  enddo
6792  enddo
6793 
6794  do k=npz,1,-1
6795  do j=js,je
6796  do i=is,ie
6797  peln(i,k,j) = peln(i,k+1,j) + grav*delz(i,j,k)/(rdgas*t00)
6798  pe(i,k,j) = exp(peln(i,k,j))
6799  pk(i,j,k) = pe(i,k,j)**kappa
6800  enddo
6801  enddo
6802  enddo
6803 
6804 
6805 ! Set up fake "sigma" coordinate
6806  call make_eta_level(npz, pe, area, ks, ak, bk, ptop, domain, bd)
6807 
6808  if ( is_master() ) write(*,*) 'LES testcase: computed model top (mb)=', ptop/100.
6809 
6810  do k=1,npz
6811  do j=js,je
6812  do i=is,ie
6813  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6814  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6815  enddo
6816  enddo
6817  enddo
6818 
6819  do k=1,npz
6820  do j=js,je
6821  do i=is,ie
6822  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6823  enddo
6824 #ifdef MULTI_GASES
6825  call qsmith((ie-is+1)*(je-js+1), npz, &
6826  ie-is+1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6827 #else
6828  call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6829 #endif
6830  do i=is,ie
6831  if ( pm(i) > 100.e2 ) then
6832  q(i,j,k,1) = 0.9*qs(i)
6833  else
6834  q(i,j,k,1) = 2.e-6
6835  endif
6836  enddo
6837  enddo
6838  enddo
6839 
6840 ! *** Add perturbation ***
6841  r0 = 1.0e3 ! radius (m)
6842  zc = 1.0e3 ! center of bubble
6843  icenter = npx/2
6844  jcenter = npy/2
6845 
6846  do k=1,npz
6847  do j=js,je
6848  do i=is,ie
6849  zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1))
6850  dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2
6851  dist = sqrt(dist)
6852  if ( dist <= r0 ) then
6853  pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0)
6854  endif
6855  enddo
6856  enddo
6857  enddo
6858 
6859  end select
6860 
6861  nullify(grid)
6862  nullify(agrid)
6863 
6864  nullify(area)
6865 
6866  nullify(fc)
6867  nullify(f0)
6868 
6869  nullify(ee1)
6870  nullify(ee2)
6871  nullify(ew)
6872  nullify(es)
6873  nullify(en1)
6874  nullify(en2)
6875 
6876  nullify(dx)
6877  nullify(dy)
6878  nullify(dxa)
6879  nullify(dya)
6880  nullify(rdxa)
6881  nullify(rdya)
6882  nullify(dxc)
6883  nullify(dyc)
6884 
6885  nullify(dx_const)
6886  nullify(dy_const)
6887 
6888  nullify(domain)
6889  nullify(tile)
6890 
6891  nullify(have_south_pole)
6892  nullify(have_north_pole)
6893 
6894  nullify(ntiles_g)
6895  nullify(acapn)
6896  nullify(acaps)
6897  nullify(globalarea)
6898 
6899  end subroutine init_double_periodic
6900 
6901  subroutine read_namelist_test_case_nml(nml_filename)
6902 
6903  character(*), intent(IN) :: nml_filename
6904  integer :: ierr, f_unit, unit, ios
6905 
6906 #include<file_version.h>
6907  namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons,soliton_umax, soliton_size
6908 
6909  unit = stdlog()
6910 
6911  ! Make alpha = 0 the default:
6912  alpha = 0.
6913  bubble_do = .false.
6914  test_case = 11 ! (USGS terrain)
6915 
6916 #ifdef INTERNAL_FILE_NML
6917  ! Read Test_Case namelist
6918  read (input_nml_file,test_case_nml,iostat=ios)
6919  ierr = check_nml_error(ios,'test_case_nml')
6920 #else
6921  f_unit = open_namelist_file(nml_filename)
6922 
6923  ! Read Test_Case namelist
6924  rewind(f_unit)
6925  read (f_unit,test_case_nml,iostat=ios)
6926  ierr = check_nml_error(ios,'test_case_nml')
6927  call close_file(f_unit)
6928 #endif
6929  write(unit, nml=test_case_nml)
6930 
6931 
6932  end subroutine read_namelist_test_case_nml
6933 
6934 
6935  subroutine superk_sounding(km, pe, p00, ze, pt, qz)
6936 ! This is the z-ccordinate version:
6937 ! Morris Weisman & J. Klemp 2002 sounding
6938  integer, intent(in):: km
6939  real, intent(in):: p00
6940  real, intent(inout), dimension(km+1):: pe
6941  real, intent(in), dimension(km+1):: ze
6942 ! pt: potential temperature / pk0
6943 ! qz: specific humidity (mixing ratio)
6944  real, intent(out), dimension(km):: pt, qz
6945 ! Local:
6946  integer, parameter:: nx = 5
6947  real, parameter:: qst = 1.0e-6
6948  real, parameter:: qv0 = 1.4e-2
6949  real, parameter:: ztr = 12.e3
6950  real, parameter:: ttr = 213.
6951  real, parameter:: ptr = 343.
6952  real, parameter:: pt0 = 300.
6953  real, dimension(km):: zs, rh, temp, dp, dp0
6954  real, dimension(km+1):: peln, pk
6955  real:: qs, zvir, fac_z, pk0, temp1, pm
6956  integer:: k, n, kk
6957 
6958  zvir = rvgas/rdgas - 1.
6959  pk0 = p00**kappa
6960  if ( (is_master()) ) then
6961  write(*,*) 'Computing sounding for HIWPP super-cell test using p00=', p00
6962  endif
6963 
6964  qz(:) = qst
6965  rh(:) = 0.25
6966 
6967  do k=1, km
6968  zs(k) = 0.5*(ze(k)+ze(k+1))
6969 ! Potential temperature
6970  if ( zs(k) .gt. ztr ) then
6971 ! Stratosphere:
6972  pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
6973  else
6974 ! Troposphere:
6975  fac_z = (zs(k)/ztr)**1.25
6976  pt(k) = pt0 + (ptr-pt0)* fac_z
6977  rh(k) = 1. - 0.75 * fac_z
6978 ! First guess on q:
6979  qz(k) = qv0 - (qv0-qst)*fac_z
6980  endif
6981  if ( is_master() ) write(*,*) zs(k), pt(k), qz(k)
6982 ! Convert to FV's definition of potential temperature
6983  pt(k) = pt(k) / pk0
6984  enddo
6985 
6986 #ifdef USE_MOIST_P00
6987 !--------------------------------------
6988 ! Iterate nx times with virtual effect:
6989 !--------------------------------------
6990 ! pt & height remain unchanged
6991  pk(km+1) = pk0
6992  pe(km+1) = p00 ! Dry
6993  peln(km+1) = log(p00)
6994 
6995  do n=1, nx
6996 ! Derive pressure fields from hydrostatic balance:
6997  do k=km,1,-1
6998  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6999  peln(k) = log(pk(k)) / kappa
7000  pe(k) = exp(peln(k))
7001  enddo
7002  do k=1, km
7003  pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
7004  temp(k) = pt(k)*pm**kappa
7005 ! NCAR form:
7006  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
7007  qz(k) = min( qv0, rh(k)*qs )
7008  if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
7009  enddo
7010  enddo
7011 #else
7012 ! pt & height remain unchanged
7013  pk(km+1) = pk0
7014  pe(km+1) = p00 ! Dry
7015  peln(km+1) = log(p00)
7016 
7017 ! Derive "dry" pressure fields from hydrostatic balance:
7018  do k=km,1,-1
7019  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k))
7020  peln(k) = log(pk(k)) / kappa
7021  pe(k) = exp(peln(k))
7022  enddo
7023  do k=1, km
7024  dp0(k) = pe(k+1) - pe(k)
7025  pm = dp0(k)/(peln(k+1)-peln(k))
7026  temp(k) = pt(k)*pm**kappa
7027 ! NCAR form:
7028  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
7029  qz(k) = min( qv0, rh(k)*qs )
7030  enddo
7031 
7032  do n=1, nx
7033 
7034  do k=1, km
7035  dp(k) = dp0(k)*(1. + qz(k)) ! moist air
7036  pe(k+1) = pe(k) + dp(k)
7037  enddo
7038 ! dry pressure, pt & height remain unchanged
7039  pk(km+1) = pe(km+1)**kappa
7040  peln(km+1) = log(pe(km+1))
7041 
7042 ! Derive pressure fields from hydrostatic balance:
7043  do k=km,1,-1
7044  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
7045  peln(k) = log(pk(k)) / kappa
7046  pe(k) = exp(peln(k))
7047  enddo
7048  do k=1, km
7049  pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
7050  temp(k) = pt(k)*pm**kappa
7051 ! NCAR form:
7052  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
7053  qz(k) = min( qv0, rh(k)*qs )
7054  if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
7055  enddo
7056  enddo
7057 #endif
7058 
7059  if ( is_master() ) then
7060  write(*,*) 'Super_K: computed ptop (mb)=', 0.01*pe(1), ' PS=', 0.01*pe(km+1)
7061  call prt_m1('1D Sounding T0', temp, 1, km, 1, 1, 0, 1, 1.)
7062  endif
7063 
7064  end subroutine superk_sounding
7065 
7066  subroutine balanced_k(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
7067  delz, zvir, ptop, ak, bk, agrid)
7068  integer, intent(in):: is, ie, js, je, ng, km
7069  real, intent(in), dimension(km ):: ts1, qs1, uz1, dudz
7070  real, intent(in), dimension(km+1):: ze1
7071  real, intent(in):: zvir, ps0
7072  real, intent(inout):: ptop
7073  real(kind=R_GRID), intent(in):: agrid(is-ng:ie+ng,js-ng:je+ng,2)
7074  real, intent(inout), dimension(km+1):: ak, bk
7075  real, intent(inout), dimension(is:ie,js:je,km):: pt
7076  real, intent(inout), dimension(is:,js:,1:) :: delz
7077  real, intent(out), dimension(is:ie,js:je,km+1):: pk
7078 ! pt is FV's cp*thelta_v
7079  real, intent(inout), dimension(is-1:ie+1,km+1,js-1:je+1):: pe
7080 ! Local
7081  integer, parameter:: nt=5
7082  integer, parameter:: nlat=1001
7083  real, dimension(nlat,km):: pt2, pky, dzc
7084  real, dimension(nlat,km+1):: pk2, pe2, peln2, pte
7085  real, dimension(km+1):: pe1
7086  real:: lat(nlat), latc(nlat-1)
7087  real:: fac_y, dlat, dz0, pk0, tmp1, tmp2, tmp3, pint
7088  integer::i,j,k,n, jj, k1
7089  real:: p00=1.e5
7090 
7091  pk0 = p00**kappa
7092  dz0 = ze1(km) - ze1(km+1)
7093 !!! dzc(:,:) =dz0
7094 
7095  dlat = 0.5*pi/real(nlat-1)
7096  do j=1,nlat
7097  lat(j) = dlat*real(j-1)
7098  do k=1,km
7099  dzc(j,k) = ze1(k) - ze1(k+1)
7100  enddo
7101  enddo
7102  do j=1,nlat-1
7103  latc(j) = 0.5*(lat(j)+lat(j+1))
7104  enddo
7105 
7106 ! Initialize pt2
7107  do k=1,km
7108  do j=1,nlat
7109  pt2(j,k) = ts1(k)
7110  enddo
7111  enddo
7112  if ( is_master() ) then
7113  tmp1 = pk0/cp_air
7114  call prt_m1('Super_K PT0', pt2, 1, nlat, 1, km, 0, 1, tmp1)
7115  endif
7116 
7117 ! pt2 defined from Eq to NP
7118 ! Check NP
7119  do n=1, nt
7120 ! Compute edge values
7121  call ppme(pt2, pte, dzc, nlat, km)
7122  do k=1,km
7123  do j=2,nlat
7124  tmp1 = 0.5*(pte(j-1,k ) + pte(j,k ))
7125  tmp3 = 0.5*(pte(j-1,k+1) + pte(j,k+1))
7126  pt2(j,k) = pt2(j-1,k) + dlat/(2.*grav)*sin(2.*latc(j-1))*uz1(k)* &
7127  ( uz1(k)*(tmp1-tmp3)/dzc(j,k) - (pt2(j-1,k)+pt2(j,k))*dudz(k) )
7128  enddo
7129  enddo
7130  if ( is_master() ) then
7131  call prt_m1('Super_K PT', pt2, 1, nlat, 1, km, 0, 1, pk0/cp_air)
7132  endif
7133  enddo
7134 !
7135 ! Compute surface pressure using gradient-wind balance:
7136 !!! pk2(1,km+1) = pk0
7137  pk2(1,km+1) = ps0**kappa ! fixed at equator
7138  do j=2,nlat
7139  pk2(j,km+1) = pk2(j-1,km+1) - dlat*uz1(km)*uz1(km)*sin(2.*latc(j-1)) &
7140  / (pt2(j-1,km) + pt2(j,km))
7141  enddo
7142 ! Compute pressure using hydrostatic balance:
7143  do j=1,nlat
7144  do k=km,1,-1
7145  pk2(j,k) = pk2(j,k+1) - grav*dzc(j,k)/pt2(j,k)
7146  enddo
7147  enddo
7148 
7149  do k=1,km+1
7150  do j=1,nlat
7151  peln2(j,k) = log(pk2(j,k)) / kappa
7152  pe2(j,k) = exp(peln2(j,k))
7153  enddo
7154  enddo
7155 ! Convert pt2 to temperature
7156  do k=1,km
7157  do j=1,nlat
7158  pky(j,k) = (pk2(j,k+1)-pk2(j,k))/(kappa*(peln2(j,k+1)-peln2(j,k)))
7159  pt2(j,k) = pt2(j,k)*pky(j,k)/(cp_air*(1.+zvir*qs1(k)))
7160  enddo
7161  enddo
7162 
7163  do k=1,km+1
7164  pe1(k) = pe2(1,k)
7165  enddo
7166 
7167  if ( is_master() ) then
7168  write(*,*) 'SuperK ptop at EQ=', 0.01*pe1(1), 'new ptop=', 0.01*ptop
7169  call prt_m1('Super_K pe', pe2, 1, nlat, 1, km+1, 0, 1, 0.01)
7170  call prt_m1('Super_K Temp', pt2, 1, nlat, 1, km, 0, 1, 1.)
7171  endif
7172 
7173 ! Interpolate (pt2, pk2) from lat-dir to cubed-sphere
7174  do j=js, je
7175  do i=is, ie
7176  do jj=1,nlat-1
7177  if (abs(agrid(i,j,2))>=lat(jj) .and. abs(agrid(i,j,2))<=lat(jj+1) ) then
7178 ! found it !
7179  fac_y = (abs(agrid(i,j,2))-lat(jj)) / dlat
7180  do k=1,km
7181  pt(i, j,k) = pt2(jj, k) + fac_y*(pt2(jj+1, k)-pt2(jj,k))
7182  enddo
7183  do k=1,km+1
7184  pe(i,k,j) = pe2(jj,k) + fac_y*(pe2(jj+1,k)-pe2(jj,k))
7185  enddo
7186 ! k = km+1
7187 ! pk(i,j,k) = pk2(jj,k) + fac_y*(pk2(jj+1,k)-pk2(jj,k))
7188  goto 123
7189  endif
7190  enddo
7191 123 continue
7192  enddo
7193  enddo
7194 
7195 ! Adjust pk
7196 ! ak & bk
7197 ! Adjusting model top to be a constant pressure surface, assuming isothermal atmosphere
7198 ! pe = ak + bk*ps
7199 ! One pressure layer
7200  pe1(1) = ptop
7201  ak(1) = ptop
7202  pint = pe1(2)
7203  bk(1) = 0.
7204  ak(2) = pint
7205  bk(2) = 0.
7206  do k=3,km+1
7207  bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma
7208  ak(k) = pe1(k) - bk(k) * pe1(km+1)
7209  if ( is_master() ) write(*,*) k, ak(k), bk(k)
7210  enddo
7211  ak(km+1) = 0.
7212  bk(km+1) = 1.
7213  do j=js, je
7214  do i=is, ie
7215  pe(i,1,j) = ptop
7216  enddo
7217  enddo
7218 
7219 
7220  end subroutine balanced_k
7221 
7222  subroutine superk_u(km, zz, um, dudz)
7223  integer, intent(in):: km
7224  real, intent(in):: zz(km)
7225  real, intent(out):: um(km), dudz(km)
7226 ! Local
7227  real, parameter:: zs = 5.e3
7228  real, parameter:: us = 30.
7229  real:: uc = 15.
7230  integer k
7231 
7232  do k=1, km
7233 #ifndef TEST_TANHP
7234 ! MPAS specification:
7235  if ( zz(k) .gt. zs+1.e3 ) then
7236  um(k) = us
7237  dudz(k) = 0.
7238  elseif ( abs(zz(k)-zs) .le. 1.e3 ) then
7239  um(k) = us*(-4./5. + 3.*zz(k)/zs - 5./4.*(zz(k)/zs)**2)
7240  dudz(k) = us/zs*(3. - 5./2.*zz(k)/zs)
7241  else
7242  um(k) = us*zz(k)/zs
7243  dudz(k) = us/zs
7244  endif
7245 ! constant wind so as to make the storm relatively stationary
7246  um(k) = um(k) - uc
7247 #else
7248  uc = 12. ! this gives near stationary (in longitude) storms
7249  um(k) = us*tanh( zz(k)/zs ) - uc
7250  dudz(k) = (us/zs)/cosh(zz(k)/zs)**2
7251 #endif
7252  enddo
7253 
7254  end subroutine superk_u
7255 
7256 #ifndef GFS_PHYS
7257  subroutine supercell_sounding(km, ps, pk1, tp, qp)
7258  use gfdl_cloud_microphys_mod, only: wqsat_moist, qsmith_init, qs_blend
7259 ! Morris Weisman & J. Klemp 2002 sounding
7260 ! Output sounding on pressure levels:
7261  integer, intent(in):: km
7262  real, intent(in):: ps ! surface pressure (Pa)
7263  real, intent(in), dimension(km):: pk1
7264  real, intent(out), dimension(km):: tp, qp
7265 ! Local:
7266  integer, parameter:: ns = 401
7267  integer, parameter:: nx = 3
7268  real, dimension(ns):: zs, pt, qs, us, rh, pp, pk, dpk, dqdt
7269  real, parameter:: Tmin = 175.
7270  real, parameter:: p00 = 1.0e5
7271  real, parameter:: qst = 3.0e-6
7272  real, parameter:: qv0 = 1.4e-2
7273  real, parameter:: ztr = 12.e3
7274  real, parameter:: ttr = 213.
7275  real, parameter:: ptr = 343. ! Tropopause potential temp.
7276  real, parameter:: pt0 = 300. ! surface potential temperature
7277  real:: dz0, zvir, fac_z, pk0, temp1, p2
7278  integer:: k, n, kk
7279 
7280 !#ifdef GFS_PHYS
7281 
7282 ! call mpp_error(FATAL, 'SuperCell sounding cannot perform with GFS Physics.')
7283 
7284 !#else
7285 
7286  zvir = rvgas/rdgas - 1.
7287  pk0 = p00**kappa
7288  pp(ns) = ps
7289  pk(ns) = ps**kappa
7290  if ( (is_master()) ) then
7291  write(*,*) 'Computing sounding for super-cell test'
7292  endif
7293 
7294  call qsmith_init
7295 
7296  dz0 = 50.
7297  zs(ns) = 0.
7298  qs(:) = qst
7299  rh(:) = 0.25
7300 
7301  do k=ns-1, 1, -1
7302  zs(k) = zs(k+1) + dz0
7303  enddo
7304 
7305  do k=1,ns
7306 ! Potential temperature
7307  if ( zs(k) .gt. ztr ) then
7308 ! Stratosphere:
7309  pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
7310  else
7311 ! Troposphere:
7312  fac_z = (zs(k)/ztr)**1.25
7313  pt(k) = pt0 + (ptr-pt0)* fac_z
7314  rh(k) = 1. - 0.75 * fac_z
7315 ! First guess on q:
7316  qs(k) = qv0 - (qv0-qst)*fac_z
7317  endif
7318  pt(k) = pt(k) / pk0
7319  enddo
7320 
7321 !--------------------------------------
7322 ! Iterate nx times with virtual effect:
7323 !--------------------------------------
7324  do n=1, nx
7325  do k=1,ns-1
7326  temp1 = 0.5*(pt(k)*(1.+zvir*qs(k)) + pt(k+1)*(1.+zvir*qs(k+1)))
7327  dpk(k) = grav*(zs(k)-zs(k+1))/(cp_air*temp1) ! DPK > 0
7328  enddo
7329 
7330  do k=ns-1,1,-1
7331  pk(k) = pk(k+1) - dpk(k)
7332  enddo
7333 
7334  do k=1, ns
7335  temp1 = pt(k)*pk(k)
7336 ! if ( (is_master()) ) write(*,*) k, temp1, rh(k)
7337  if ( pk(k) > 0. ) then
7338  pp(k) = exp(log(pk(k))/kappa)
7339 #ifdef SUPER_K
7340  qs(k) = 380./pp(k)*exp(17.27*(temp1-273.)/(temp1-36.))
7341  qs(k) = min( qv0, rh(k)*qs(k) )
7342  if ( (is_master()) ) write(*,*) 0.01*pp(k), qs(k)
7343 #else
7344 
7345 #ifdef USE_MIXED_TABLE
7346  qs(k) = min(qv0, rh(k)*qs_blend(temp1, pp(k), qs(k)))
7347 #else
7348  qs(k) = min(qv0, rh(k)*wqsat_moist(temp1, qs(k), pp(k)))
7349 #endif
7350 
7351 #endif
7352  else
7353  if ( (is_master()) ) write(*,*) n, k, pk(k)
7354  call mpp_error(fatal, 'Super-Cell case: pk < 0')
7355  endif
7356  enddo
7357  enddo
7358 
7359 ! Interpolate to p levels using pk1: p**kappa
7360  do 555 k=1, km
7361  if ( pk1(k) .le. pk(1) ) then
7362  tp(k) = pt(1)*pk(1)/pk1(k) ! isothermal above
7363  qp(k) = qst ! set to stratosphere value
7364  elseif ( pk1(k) .ge. pk(ns) ) then
7365  tp(k) = pt(ns)
7366  qp(k) = qs(ns)
7367  else
7368  do kk=1,ns-1
7369  if( (pk1(k).le.pk(kk+1)) .and. (pk1(k).ge.pk(kk)) ) then
7370  fac_z = (pk1(k)-pk(kk))/(pk(kk+1)-pk(kk))
7371  tp(k) = pt(kk) + (pt(kk+1)-pt(kk))*fac_z
7372  qp(k) = qs(kk) + (qs(kk+1)-qs(kk))*fac_z
7373  goto 555
7374  endif
7375  enddo
7376  endif
7377 555 continue
7378 
7379  do k=1,km
7380  tp(k) = tp(k)*pk1(k) ! temperature
7381  tp(k) = max(tmin, tp(k))
7382  enddo
7383 
7384 !#endif
7385 
7386  end subroutine supercell_sounding
7387 #endif
7388 
7389  subroutine dcmip16_bc(delp,pt,u,v,q,w,delz,&
7390  is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7391  pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7392  hydrostatic, nwat, adiabatic, do_pert, domain, bd)
7393 
7394  type(fv_grid_bounds_type), intent(IN) :: bd
7395 
7396  integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7397  real, intent(IN) :: ptop
7398  real, intent(IN), dimension(npz+1) :: ak, bk
7399  real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7400  real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w
7401  real, intent(OUT), dimension(is:,js:,1:) :: delz
7402  real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7403  real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7404  real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7405  real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7406  real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7407  real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7408  real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7409  real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7410  real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7411  real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7412  logical, intent(IN) :: hydrostatic,adiabatic,do_pert
7413  type(domain2d), intent(INOUT) :: domain
7414 
7415  real, parameter :: p0 = 1.e5
7416  real, parameter :: u0 = 35.
7417  real, parameter :: b = 2.
7418  real, parameter :: KK = 3.
7419  real, parameter :: Te = 310.
7420  real, parameter :: Tp = 240.
7421  real, parameter :: T0 = 0.5*(te + tp) !!WRONG in document
7422  real, parameter :: up = 1.
7423  real, parameter :: zp = 1.5e4
7424  real(kind=R_GRID), parameter :: lamp = pi/9.
7425  real(kind=R_GRID), parameter :: phip = 2.*lamp
7426  real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7427  real, parameter :: Rp = radius/10.
7428  real, parameter :: lapse = 5.e-3
7429  real, parameter :: dT = 4.8e5
7430  real, parameter :: phiW = 2.*pi/9.
7431  real, parameter :: pW = 34000.
7432  real, parameter :: q0 = .018
7433  real, parameter :: qt = 1.e-12
7434  real, parameter :: ptrop = 1.e4
7435 
7436  real, parameter :: zconv = 1.e-6
7437  real, parameter :: rdgrav = rdgas/grav
7438  !real, parameter :: zvir = rvgas/rdgas - 1.
7439  real :: zvir
7440  real, parameter :: rrdgrav = grav/rdgas
7441 
7442  integer :: i,j,k,iter, sphum, cl, cl2, n
7443  real :: p,z,z0,ziter,piter,titer,uu,vv,pl,pt_u,pt_v
7444  real(kind=R_GRID), dimension(2) :: pa
7445  real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7446  real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2
7447  real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7448  real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2
7449  real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7450 
7451  !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7452  ! (with or without perturbation), moisture, Terminator tracer, w, delz
7453 
7454  !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7455  ! and meridional winds on both grids, and rotate as needed
7456  zvir = rvgas/rdgas - 1.
7457 
7458  !PS
7459  do j=js,je
7460  do i=is,ie
7461  ps(i,j) = p0
7462  enddo
7463  enddo
7464 
7465  !delp
7466  do k=1,npz
7467  do j=js,je
7468  do i=is,ie
7469  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7470  enddo
7471  enddo
7472  enddo
7473 
7474  !Pressure variables
7475  do j=js,je
7476  do i=is,ie
7477  pe(i,1,j) = ptop
7478  enddo
7479  do i=is,ie
7480  peln(i,1,j) = log(ptop)
7481  pk(i,j,1) = ptop**kappa
7482  enddo
7483  do k=2,npz+1
7484  do i=is,ie
7485  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
7486  enddo
7487  do i=is,ie
7488  pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7489  peln(i,k,j) = log(pe(i,k,j))
7490  enddo
7491  enddo
7492  enddo
7493 
7494  do k=1,npz
7495  do j=js,je
7496  do i=is,ie
7497  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7498  enddo
7499  enddo
7500  enddo
7501 
7502  !Height: Use Newton's method
7503  !Cell centered
7504  do j=js,je
7505  do i=is,ie
7506  phis(i,j) = 0.
7507  gz(i,j,npz+1) = 0.
7508  enddo
7509  enddo
7510  do k=npz,1,-1
7511  do j=js,je
7512  do i=is,ie
7513  p = pe(i,k,j)
7514  z = gz(i,j,k+1)
7515  do iter=1,30
7516  ziter = z
7517  piter = dcmip16_bc_pressure(ziter,agrid(i,j,2))
7518  titer = dcmip16_bc_temperature(ziter,agrid(i,j,2))
7519  z = ziter + (piter - p)*rdgrav*titer/piter
7520 !!$ !!! DEBUG CODE
7521 !!$ if (is_master() .and. i == is .and. j == js) then
7522 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7523 !!$ endif
7524 !!$ !!! END DEBUG CODE
7525  if (abs(z - ziter) < zconv) exit
7526  enddo
7527  gz(i,j,k) = z
7528  enddo
7529  enddo
7530  enddo
7531 
7532  !(Virtual) Temperature: Compute from hydro balance
7533  do k=1,npz
7534  do j=js,je
7535  do i=is,ie
7536  pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7537  enddo
7538  enddo
7539  enddo
7540 
7541  call mpp_update_domains(pt, domain)
7542  call mpp_update_domains(gz, domain)
7543  !Compute height and temperature for u and v points also, to be able to compute the local winds
7544  !Use temporary 2d arrays for this purpose
7545  do j=js,je+1
7546  do i=is,ie
7547  gz_u(i,j) = 0.
7548  p_u(i,j) = p0
7549  peln_u(i,j) = log(p0)
7550  ps_u(i,j) = p0
7551  call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7552  lat_u(i,j) = pa(2)
7553  lon_u(i,j) = pa(1)
7554  call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7555  call get_latlon_vector(pa,ex,ey)
7556  u1(i,j) = inner_prod(e1,ex) !u components
7557  u2(i,j) = inner_prod(e1,ey)
7558  enddo
7559  enddo
7560  do k=npz,1,-1
7561  do j=js,je+1
7562  do i=is,ie
7563  !Pressure (Top of interface)
7564  p = ak(k) + ps_u(i,j)*bk(k)
7565  pl = log(p)
7566  !Height (top of interface); use newton's method
7567  z = gz_u(i,j) !first guess, height of lower level
7568  z0 = z
7569  do iter=1,30
7570  ziter = z
7571  piter = dcmip16_bc_pressure(ziter,lat_u(i,j))
7572  titer = dcmip16_bc_temperature(ziter,lat_u(i,j))
7573  z = ziter + (piter - p)*rdgrav*titer/piter
7574  if (abs(z - ziter) < zconv) exit
7575  enddo
7576  !Temperature, compute from hydro balance
7577  pt_u = rrdgrav * ( z - gz_u(i,j) ) / (peln_u(i,j) - pl)
7578  !Now compute winds. Note no meridional winds
7579  !!!NOTE: do we need to use LAYER-mean z?
7580  uu = dcmip16_bc_uwind(0.5*(z+z0),pt_u,lat_u(i,j))
7581  if (do_pert) then
7582  uu = uu + dcmip16_bc_uwind_pert(0.5*(z+z0),lat_u(i,j),lon_u(i,j))
7583  endif
7584  u(i,j,k) = u1(i,j)*uu
7585 
7586  gz_u(i,j) = z
7587  p_u(i,j) = p
7588  peln_u(i,j) = pl
7589  enddo
7590  enddo
7591  enddo
7592 
7593  do j=js,je
7594  do i=is,ie+1
7595  gz_v(i,j) = 0.
7596  p_v(i,j) = p0
7597  peln_v(i,j) = log(p0)
7598  ps_v(i,j) = p0
7599  call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7600  lat_v(i,j) = pa(2)
7601  lon_v(i,j) = pa(1)
7602  call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7603  call get_latlon_vector(pa,ex,ey)
7604  v1(i,j) = inner_prod(e2,ex) !v components
7605  v2(i,j) = inner_prod(e2,ey)
7606  enddo
7607  enddo
7608  do k=npz,1,-1
7609  do j=js,je
7610  do i=is,ie+1
7611  !Pressure (Top of interface)
7612  p = ak(k) + ps_v(i,j)*bk(k)
7613  pl = log(p)
7614  !Height (top of interface); use newton's method
7615  z = gz_v(i,j) !first guess, height of lower level
7616  z0 = z
7617  do iter=1,30
7618  ziter = z
7619  piter = dcmip16_bc_pressure(ziter,lat_v(i,j))
7620  titer = dcmip16_bc_temperature(ziter,lat_v(i,j))
7621  z = ziter + (piter - p)*rdgrav*titer/piter
7622  if (abs(z - ziter) < zconv) exit
7623  enddo
7624  !Temperature, compute from hydro balance
7625  pt_v = rrdgrav * ( z - gz_v(i,j) ) / (peln_v(i,j) - pl)
7626  !Now compute winds
7627  uu = dcmip16_bc_uwind(0.5*(z+z0),pt_v,lat_v(i,j))
7628  if (do_pert) then
7629  uu = uu + dcmip16_bc_uwind_pert(0.5*(z+z0),lat_v(i,j),lon_v(i,j))
7630  endif
7631  v(i,j,k) = v1(i,j)*uu
7632  gz_v(i,j) = z
7633  p_v(i,j) = p
7634  peln_v(i,j) = pl
7635  enddo
7636  enddo
7637  enddo
7638 
7639  !Compute nonhydrostatic variables, if needed
7640  if (.not. hydrostatic) then
7641  do k=1,npz
7642  do j=js,je
7643  do i=is,ie
7644  w(i,j,k) = 0.
7645  !Re-compute from hydro balance
7646  delz(i,j,k) = rdgrav * (peln(i,k+1,j) - peln(i,k,j)) * pt(i,j,k)
7647  !delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7648  enddo
7649  enddo
7650  enddo
7651  endif
7652  !Compute moisture and other tracer fields, as desired
7653  do n=1,nq
7654  do k=1,npz
7655  do j=jsd,jed
7656  do i=isd,ied
7657  q(i,j,k,n) = 0.
7658  enddo
7659  enddo
7660  enddo
7661  enddo
7662  sphum = get_tracer_index(model_atmos, 'sphum')
7663  do k=1,npz
7664  do j=js,je
7665  do i=is,ie
7666  p = delp(i,j,k)/(peln(i,k+1,j) - peln(i,k,j))
7667  q(i,j,k,sphum) = dcmip16_bc_sphum(p,ps(i,j),agrid(i,j,2),agrid(i,j,1))
7668  enddo
7669  enddo
7670  enddo
7671 
7672  cl = get_tracer_index(model_atmos, 'cl')
7673  cl2 = get_tracer_index(model_atmos, 'cl2')
7674  if (cl > 0 .and. cl2 > 0) then
7675  call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
7676  q, delp,nq,agrid(isd,jsd,1),agrid(isd,jsd,2),bd)
7677  call mpp_update_domains(q,domain)
7678  endif
7679 
7680  if (.not. adiabatic) then
7681  do k=1,npz
7682  do j=js,je
7683  do i=is,ie
7684  !Convert pt to non-virtual temperature
7685  pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum))
7686  enddo
7687  enddo
7688  enddo
7689  endif
7690 
7691  contains
7692 
7693 
7694  real function dcmip16_bc_temperature(z, lat)
7695 
7696  real, intent(IN) :: z
7697  real(kind=R_GRID), intent(IN) :: lat
7698  real :: IT, T1, T2, Tr, zsc
7699 
7700  it = exp(kk * log(cos(lat))) - kk/(kk+2.)*exp((kk+2.)*log(cos(lat)))
7701  zsc = z*grav/(b*rdgas*t0)
7702  tr = ( 1. - 2.*zsc**2.) * exp(-zsc**2. )
7703 
7704  t1 = (1./t0)*exp(lapse*z/t0) + (t0 - tp)/(t0*tp) * tr
7705  t2 = 0.5* ( kk + 2.) * (te - tp)/(te*tp) * tr
7706 
7707  dcmip16_bc_temperature = 1./(t1 - t2*it)
7708 
7709  end function dcmip16_bc_temperature
7710 
7711  real function dcmip16_bc_pressure(z,lat)
7712 
7713  real, intent(IN) :: z
7714  real(kind=R_GRID), intent(IN) :: lat
7715  real :: IT, Ti1, Ti2, Tir
7716 
7717  it = exp(kk * log(cos(lat))) - kk/(kk+2.)*exp((kk+2.)*log(cos(lat)))
7718  tir = z*exp(-(z*grav/(b*rdgas*t0))*(z*grav/(b*rdgas*t0)) )
7719 
7720  ti1 = 1./lapse* (exp(lapse*z/t0) - 1.) + tir*(t0-tp)/(t0*tp)
7721  ti2 = 0.5*(kk+2.)*(te-tp)/(te*tp) * tir
7722 
7723  dcmip16_bc_pressure = p0*exp(-grav/rdgas * ( ti1 - ti2*it))
7724 
7725  end function dcmip16_bc_pressure
7726 
7727  real function dcmip16_bc_uwind(z,T,lat)
7728 
7729  real, intent(IN) :: z, T
7730  real(kind=R_GRID), intent(IN) :: lat
7731  real :: Tir, Ti2, UU, ur
7732 
7733  tir = z*exp(-(z*grav/(b*rdgas*t0))*(z*grav/(b*rdgas*t0)) )
7734  ti2 = 0.5*(kk+2.)*(te-tp)/(te*tp) * tir
7735 
7736  uu = grav*kk/radius * ti2 * ( cos(lat)**(int(kk)-1) - cos(lat)**(int(kk)+1) ) * t
7737  ur = - omega * radius * cos(lat) + sqrt( (omega*radius*cos(lat))**2 + radius*cos(lat)*uu)
7738 
7739  dcmip16_bc_uwind = ur
7740 
7741  end function dcmip16_bc_uwind
7742 
7743  real function dcmip16_bc_uwind_pert(z,lat,lon)
7744 
7745  real, intent(IN) :: z
7746  real(kind=R_GRID), intent(IN) :: lat, lon
7747  real :: ZZ, zrat
7748  real(kind=R_GRID) :: dst, pphere(2)
7749 
7750  zrat = z/zp
7751  zz = max(1. - 3.*zrat*zrat + 2.*zrat*zrat*zrat, 0.)
7752 
7753  pphere = (/ lon, lat /)
7754  dst = great_circle_dist(pphere, ppcenter, radius)
7755 
7756  dcmip16_bc_uwind_pert = max(0., up*zz*exp(-(dst/rp)**2) )
7757 
7758  end function dcmip16_bc_uwind_pert
7759 
7760  real function dcmip16_bc_sphum(p,ps,lat, lon)
7761 
7762  real, intent(IN) :: p, ps
7763  real(kind=R_GRID), intent(IN) :: lat, lon
7764  real :: eta
7765 
7766  eta = p/ps
7767 
7768  dcmip16_bc_sphum = qt
7769  if (p > ptrop) then
7770  dcmip16_bc_sphum = q0 * exp(-(lat/phiw)**4) * exp(-( (eta-1.)*p0/pw)**2)
7771  endif
7772 
7773  end function dcmip16_bc_sphum
7774 
7775  end subroutine dcmip16_bc
7776 
7777  subroutine dcmip16_tc(delp,pt,u,v,q,w,delz,&
7778  is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7779  pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7780  hydrostatic, nwat, adiabatic)
7781 
7782  integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7783  real, intent(IN) :: ptop
7784  real, intent(IN), dimension(npz+1) :: ak, bk
7785  real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7786  real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w
7787  real, intent(OUT), dimension(is:,js:,1:) :: delz
7788  real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7789  real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7790  real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7791  real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7792  real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7793  real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7794  real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7795  real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7796  real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7797  real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7798  logical, intent(IN) :: hydrostatic,adiabatic
7799 
7800  real, parameter :: zt = 15000
7801  real, parameter :: q0 = 0.021
7802  real, parameter :: qt = 1.e-11
7803  real, parameter :: T0 = 302.15
7804  real, parameter :: Tv0 = 302.15*(1.+0.608*q0)
7805  real, parameter :: Ts = 302.15
7806  real, parameter :: zq1 = 3000.
7807  real, parameter :: zq2 = 8000.
7808  real, parameter :: lapse = 7.e-3
7809  real, parameter :: Tvt = tv0 - lapse*zt
7810  real, parameter :: pb = 101500.
7811  real, parameter :: ptt = pb*(tvt/tv0)**(grav/rdgas/lapse)
7812  real(kind=R_GRID), parameter :: lamp = pi
7813  real(kind=R_GRID), parameter :: phip = pi/18.
7814  real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7815  real, parameter :: dp = 1115.
7816  real, parameter :: rp = 282000.
7817  real, parameter :: zp = 7000.
7818  real, parameter :: fc = 2.*omega*sin(phip)
7819 
7820  real, parameter :: zconv = 1.e-6
7821  real, parameter :: rdgrav = rdgas/grav
7822  real, parameter :: rrdgrav = grav/rdgas
7823  real, parameter :: zvir = rvgas/rdgas - 1.
7824 
7825  integer :: i,j,k,iter, sphum, cl, cl2, n
7826  real :: p,z,z0,ziter,piter,titer,uu,vv,pl, r
7827  real(kind=R_GRID), dimension(2) :: pa
7828  real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7829  real, dimension(is:ie,js:je) :: rc
7830  real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2, rc_u
7831  real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7832  real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v
7833  real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7834 
7835  !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7836  ! (with or without perturbation), moisture, w, delz
7837 
7838  !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7839  ! and meridional winds on both grids, and rotate as needed
7840 
7841  !Save r for easy use
7842  do j=js,je
7843  do i=is,ie
7844  rc(i,j) = great_circle_dist(agrid(i,j,:), ppcenter, radius)
7845  enddo
7846  enddo
7847 
7848  !PS
7849  do j=js,je
7850  do i=is,ie
7851  ps(i,j) = pb - dp*exp( -sqrt((rc(i,j)/rp)**3) )
7852  enddo
7853  enddo
7854 
7855  !delp
7856  do k=1,npz
7857  do j=js,je
7858  do i=is,ie
7859  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7860  enddo
7861  enddo
7862  enddo
7863 
7864  !Pressure variables
7865  do j=js,je
7866  do i=is,ie
7867  pe(i,1,j) = ptop
7868  enddo
7869  do i=is,ie
7870  peln(i,1,j) = log(ptop)
7871  pk(i,j,1) = ptop**kappa
7872  enddo
7873  do k=2,npz+1
7874  do i=is,ie
7875  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
7876  enddo
7877  do i=is,ie
7878  pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7879  peln(i,k,j) = log(pe(i,k,j))
7880  enddo
7881  enddo
7882  enddo
7883 
7884  do k=1,npz
7885  do j=js,je
7886  do i=is,ie
7887  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7888  enddo
7889  enddo
7890  enddo
7891 
7892  !Height: Use Newton's method
7893  !Cell centered
7894  do j=js,je
7895  do i=is,ie
7896  phis(i,j) = 0.
7897  gz(i,j,npz+1) = 0.
7898  enddo
7899  enddo
7900  do k=npz,1,-1
7901  do j=js,je
7902  do i=is,ie
7903  p = pe(i,k,j)
7904  z = gz(i,j,k+1)
7905  do iter=1,30
7906  ziter = z
7907  piter = dcmip16_tc_pressure(ziter,rc(i,j))
7908  titer = dcmip16_tc_temperature(ziter,rc(i,j))
7909  z = ziter + (piter - p)*rdgrav*titer/piter
7910 !!$ !!! DEBUG CODE
7911 !!$ if (is_master() .and. i == is .and. j == js) then
7912 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7913 !!$ endif
7914 !!$ !!! END DEBUG CODE
7915  if (abs(z - ziter) < zconv) exit
7916  enddo
7917  gz(i,j,k) = z
7918  enddo
7919  enddo
7920  enddo
7921 
7922  !Temperature: Compute from hydro balance
7923  do k=1,npz
7924  do j=js,je
7925  do i=is,ie
7926  pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7927  enddo
7928  enddo
7929  enddo
7930 
7931  !Compute height and temperature for u and v points also, to be able to compute the local winds
7932  !Use temporary 2d arrays for this purpose
7933  do j=js,je+1
7934  do i=is,ie
7935  call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7936  lat_u(i,j) = pa(2)
7937  lon_u(i,j) = pa(1)
7938  call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7939  call get_latlon_vector(pa,ex,ey)
7940  u1(i,j) = inner_prod(e1,ex) !u components
7941  u2(i,j) = inner_prod(e1,ey)
7942  rc_u(i,j) = great_circle_dist(pa, ppcenter, radius)
7943  gz_u(i,j) = 0.
7944  p_u(i,j) = pb - dp*exp( -sqrt((rc_u(i,j)/rp)**3) )
7945  peln_u(i,j) = log(p_u(i,j))
7946  ps_u(i,j) = p_u(i,j)
7947  enddo
7948  enddo
7949  do k=npz,1,-1
7950  do j=js,je+1
7951  do i=is,ie
7952  !Pressure (Top of interface)
7953  p = ak(k) + ps_u(i,j)*bk(k)
7954  pl = log(p)
7955  !Height (top of interface); use newton's method
7956  z = gz_u(i,j) !first guess, height of lower level
7957  z0 = z
7958  do iter=1,30
7959  ziter = z
7960  piter = dcmip16_tc_pressure(ziter,rc_u(i,j))
7961  titer = dcmip16_tc_temperature(ziter,rc_u(i,j))
7962  z = ziter + (piter - p)*rdgrav*titer/piter
7963  if (abs(z - ziter) < zconv) exit
7964  enddo
7965  !Now compute winds
7966  call dcmip16_tc_uwind_pert(0.5*(z+z0),rc_u(i,j),lon_u(i,j),lat_u(i,j), uu, vv)
7967  u(i,j,k) = u1(i,j)*uu + u2(i,j)*vv
7968 
7969  gz_u(i,j) = z
7970  p_u(i,j) = p
7971  peln_u(i,j) = pl
7972  enddo
7973  enddo
7974  enddo
7975 
7976  do j=js,je
7977  do i=is,ie+1
7978  call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7979  lat_v(i,j) = pa(2)
7980  lon_v(i,j) = pa(1)
7981  call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7982  call get_latlon_vector(pa,ex,ey)
7983  v1(i,j) = inner_prod(e2,ex) !v components
7984  v2(i,j) = inner_prod(e2,ey)
7985  rc_v(i,j) = great_circle_dist(pa, ppcenter, radius)
7986  gz_v(i,j) = 0.
7987  p_v(i,j) = pb - dp*exp( - sqrt((rc_v(i,j)/rp)**3) )
7988  peln_v(i,j) = log(p_v(i,j))
7989  ps_v(i,j) = p_v(i,j)
7990  enddo
7991  enddo
7992  do k=npz,1,-1
7993  do j=js,je
7994  do i=is,ie+1
7995  !Pressure (Top of interface)
7996  p = ak(k) + ps_v(i,j)*bk(k)
7997  pl = log(p)
7998  !Height (top of interface); use newton's method
7999  z = gz_v(i,j) !first guess, height of lower level
8000  z0 = z
8001  do iter=1,30
8002  ziter = z
8003  piter = dcmip16_tc_pressure(ziter,rc_v(i,j))
8004  titer = dcmip16_tc_temperature(ziter,rc_v(i,j))
8005  z = ziter + (piter - p)*rdgrav*titer/piter
8006  if (abs(z - ziter) < zconv) exit
8007  enddo
8008  !Now compute winds
8009  call dcmip16_tc_uwind_pert(0.5*(z+z0),rc_v(i,j),lon_v(i,j),lat_v(i,j), uu, vv)
8010  v(i,j,k) = v1(i,j)*uu + v2(i,j)*vv
8011  gz_v(i,j) = z
8012  p_v(i,j) = p
8013  peln_v(i,j) = pl
8014  enddo
8015  enddo
8016  enddo
8017 
8018  !Compute moisture and other tracer fields, as desired
8019  do n=1,nq
8020  do k=1,npz
8021  do j=jsd,jed
8022  do i=isd,ied
8023  q(i,j,k,n) = 0.
8024  enddo
8025  enddo
8026  enddo
8027  enddo
8028  if (.not. adiabatic) then
8029  sphum = get_tracer_index(model_atmos, 'sphum')
8030  do k=1,npz
8031  do j=js,je
8032  do i=is,ie
8033  z = 0.5*(gz(i,j,k) + gz(i,j,k+1))
8034  q(i,j,k,sphum) = dcmip16_tc_sphum(z)
8035  !Convert pt to non-virtual temperature
8036  pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum))
8037  enddo
8038  enddo
8039  enddo
8040  endif
8041 
8042  !Compute nonhydrostatic variables, if needed
8043  if (.not. hydrostatic) then
8044  do k=1,npz
8045  do j=js,je
8046  do i=is,ie
8047  w(i,j,k) = 0.
8048  delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
8049  enddo
8050  enddo
8051  enddo
8052  endif
8053 
8054  contains
8055 
8056  !Initialize with virtual temperature
8057  real function dcmip16_tc_temperature(z, r)
8058 
8059  real, intent(IN) :: z, r
8060  real :: Tv, term1, term2
8061 
8062  if (z > zt) then
8063  dcmip16_tc_temperature = tvt
8064  return
8065  endif
8066 
8067  tv = tv0 - lapse*z
8068  term1 = grav*zp*zp* ( 1. - pb/dp * exp( sqrt(r/rp)**3 + (z/zp)**2 ) )
8069  term2 = 2*rdgas*tv*z
8070  dcmip16_tc_temperature = tv + tv*( 1./(1 + term2/term1) - 1.)
8071 
8072  end function dcmip16_tc_temperature
8073 
8074  !Initialize with moist air mass
8075  real function dcmip16_tc_pressure(z, r)
8076 
8077  real, intent(IN) :: z, r
8078 
8079  if (z <= zt) then
8080  dcmip16_tc_pressure = pb*exp(grav/(rdgas*lapse) * log( (tv0-lapse*z)/tv0) ) -dp* exp(-sqrt((r/rp)**3) - (z/zp)**2) * &
8081  exp( grav/(rdgas*lapse) * log( (tv0-lapse*z)/tv0) )
8082  else
8083  dcmip16_tc_pressure = ptt*exp(grav*(zt-z)/(rdgas*tvt))
8084  endif
8085 
8086  end function dcmip16_tc_pressure
8087 
8088  subroutine dcmip16_tc_uwind_pert(z,r,lon,lat,uu,vv)
8089 
8090  real, intent(IN) :: z, r
8091  real(kind=R_GRID), intent(IN) :: lon, lat
8092  real, intent(OUT) :: uu, vv
8093  real :: rfac, Tvrd, vt, fr5, d1, d2, d
8094  real(kind=R_GRID) :: dst, pphere(2)
8095 
8096  if (z > zt) then
8097  uu = 0.
8098  vv = 0.
8099  return
8100  endif
8101 
8102  rfac = sqrt(r/rp)**3
8103 
8104  fr5 = 0.5*fc*r
8105  tvrd = (tv0 - lapse*z)*rdgas
8106 
8107  vt = -fr5 + sqrt( fr5**2 - (1.5 * rfac * tvrd) / &
8108  ( 1. + 2*tvrd*z/(grav*zp**2) - pb/dp*exp( rfac + (z/zp)**2) ) )
8109 
8110  d1 = sin(phip)*cos(lat) - cos(phip)*sin(lat)*cos(lon - lamp)
8111  d2 = cos(phip)*sin(lon - lamp)
8112  d = max(1.e-25,sqrt(d1*d1 + d2*d2))
8113 
8114  uu = vt * d1/d
8115  vv = vt * d2/d
8116 
8117  end subroutine dcmip16_tc_uwind_pert
8118 
8119  real function dcmip16_tc_sphum(z)
8120 
8121  real, intent(IN) :: z
8122 
8123  dcmip16_tc_sphum = qt
8124  if (z < zt) then
8125  dcmip16_tc_sphum = q0 * exp(-z/zq1) * exp(-(z/zq2 )**2)
8126  endif
8127 
8128  end function dcmip16_tc_sphum
8129 
8130  end subroutine dcmip16_tc
8131 
8132 !!$ subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
8133 !!$ gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, &
8134 !!$ mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in, bd)
8135 !!$
8136 !!$ real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
8137 !!$ real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
8138 !!$ real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
8139 !!$ real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
8140 !!$ real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
8141 !!$
8142 !!$ real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
8143 !!$
8144 !!$ real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
8145 !!$ real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1)
8146 !!$ real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1)
8147 !!$ real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je)
8148 !!$ real , intent(INOUT) :: pkz(is:ie ,js:je ,npz )
8149 !!$ real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
8150 !!$ real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
8151 !!$ real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
8152 !!$ real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
8153 !!$ real , intent(inout) :: delz(is:,js:,1:)
8154 !!$ real , intent(inout) :: ze0(is:,js:,1:)
8155 !!$
8156 !!$ real , intent(IN) :: ak(npz+1)
8157 !!$ real , intent(IN) :: bk(npz+1)
8158 !!$
8159 !!$ integer, intent(IN) :: npx, npy, npz
8160 !!$ integer, intent(IN) :: ng, ncnst
8161 !!$ integer, intent(IN) :: ndims
8162 !!$ integer, intent(IN) :: nregions
8163 !!$ integer,target,intent(IN):: tile_in
8164 !!$
8165 !!$ real, intent(IN) :: dry_mass
8166 !!$ logical, intent(IN) :: mountain
8167 !!$ logical, intent(IN) :: moist_phys
8168 !!$ logical, intent(IN) :: hybrid_z
8169 !!$
8170 !!$ type(fv_grid_type), intent(IN), target :: gridstruct
8171 !!$ type(domain2d), intent(IN), target :: domain_in
8172 !!$
8173 !!$ real, pointer, dimension(:,:,:) :: agrid, grid
8174 !!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0
8175 !!$ real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
8176 !!$ real, pointer, dimension(:,:,:,:) :: ew, es
8177 !!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8178 !!$
8179 !!$ logical, pointer :: cubed_sphere, latlon
8180 !!$
8181 !!$ type(domain2d), pointer :: domain
8182 !!$ integer, pointer :: tile
8183 !!$
8184 !!$ logical, pointer :: have_south_pole, have_north_pole
8185 !!$
8186 !!$ integer, pointer :: ntiles_g
8187 !!$ real, pointer :: acapN, acapS, globalarea
8188 !!$
8189 !!$ real(kind=R_GRID) :: p1(2), p2(2)
8190 !!$ real :: r, r0
8191 !!$ integer :: i,j
8192 !!$
8193 !!$ agrid => gridstruct%agrid
8194 !!$ grid => gridstruct%grid
8195 !!$
8196 !!$ area => gridstruct%area
8197 !!$
8198 !!$ dx => gridstruct%dx
8199 !!$ dy => gridstruct%dy
8200 !!$ dxa => gridstruct%dxa
8201 !!$ dya => gridstruct%dya
8202 !!$ rdxa => gridstruct%rdxa
8203 !!$ rdya => gridstruct%rdya
8204 !!$ dxc => gridstruct%dxc
8205 !!$ dyc => gridstruct%dyc
8206 !!$
8207 !!$ fC => gridstruct%fC
8208 !!$ f0 => gridstruct%f0
8209 !!$
8210 !!$ ntiles_g => gridstruct%ntiles_g
8211 !!$ acapN => gridstruct%acapN
8212 !!$ acapS => gridstruct%acapS
8213 !!$ globalarea => gridstruct%globalarea
8214 !!$
8215 !!$ domain => domain_in
8216 !!$ tile => tile_in
8217 !!$
8218 !!$ have_south_pole => gridstruct%have_south_pole
8219 !!$ have_north_pole => gridstruct%have_north_pole
8220 !!$
8221 !!$ do j=jsd,jed+1
8222 !!$ do i=isd,ied+1
8223 !!$ fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) &
8224 !!$ +sin(grid(i,j,2))*cos(alpha) )
8225 !!$ enddo
8226 !!$ enddo
8227 !!$ do j=jsd,jed
8228 !!$ do i=isd,ied
8229 !!$ f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) &
8230 !!$ +sin(agrid(i,j,2))*cos(alpha) )
8231 !!$ enddo
8232 !!$ enddo
8233 !!$
8234 !!$ select case (test_case)
8235 !!$ case ( 1 )
8236 !!$
8237 !!$ Ubar = (2.0*pi*radius)/(12.0*86400.0)
8238 !!$ phis = 0.0
8239 !!$ r0 = radius/3. !RADIUS radius/3.
8240 !!$ p1(1) = 0.
8241 !!$ p1(1) = pi/2. + pi_shift
8242 !!$ p1(2) = 0.
8243 !!$ do j=jsd,jed
8244 !!$ do i=isd,ied
8245 !!$ p2(1) = agrid(i,j,1)
8246 !!$ p2(2) = agrid(i,j,2)
8247 !!$ r = great_circle_dist( p1, p2, radius )
8248 !!$ if (r < r0) then
8249 !!$ delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(PI*r/r0))
8250 !!$ else
8251 !!$ delp(i,j,1) = phis(i,j)
8252 !!$ endif
8253 !!$ enddo
8254 !!$ enddo
8255 !!$ call init_latlon_winds(UBar, u, v, ua, va, uc, vc, 1, gridstruct)
8256 !!$
8257 !!$
8258 !!$
8259 !!$ end select
8260 !!$
8261 !!$ nullify(grid)
8262 !!$ nullify(agrid)
8263 !!$
8264 !!$ nullify(area)
8265 !!$
8266 !!$ nullify(fC)
8267 !!$ nullify(f0)
8268 !!$
8269 !!$ nullify(dx)
8270 !!$ nullify(dy)
8271 !!$ nullify(dxa)
8272 !!$ nullify(dya)
8273 !!$ nullify(rdxa)
8274 !!$ nullify(rdya)
8275 !!$ nullify(dxc)
8276 !!$ nullify(dyc)
8277 !!$
8278 !!$ nullify(domain)
8279 !!$ nullify(tile)
8280 !!$
8281 !!$ nullify(have_south_pole)
8282 !!$ nullify(have_north_pole)
8283 !!$
8284 !!$ nullify(ntiles_g)
8285 !!$ nullify(acapN)
8286 !!$ nullify(acapS)
8287 !!$ nullify(globalarea)
8288 !!$
8289 !!$ end subroutine init_latlon
8290 !!$
8291 !!$ subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct)
8292 !!$
8293 !!$ ! 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
8294 !!$
8295 !!$ real, intent(INOUT) :: UBar
8296 !!$ real, intent(INOUT) :: u(isd:ied ,jsd:jed+1)
8297 !!$ real, intent(INOUT) :: v(isd:ied+1,jsd:jed )
8298 !!$ real, intent(INOUT) :: uc(isd:ied+1,jsd:jed )
8299 !!$ real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
8300 !!$ real, intent(INOUT) :: ua(isd:ied ,jsd:jed )
8301 !!$ real, intent(INOUT) :: va(isd:ied ,jsd:jed )
8302 !!$ integer, intent(IN) :: defOnGrid
8303 !!$ type(fv_grid_type), intent(IN), target :: gridstruct
8304 !!$
8305 !!$ real :: p1(2),p2(2),p3(2),p4(2), pt(2)
8306 !!$ real :: e1(3), e2(3), ex(3), ey(3)
8307 !!$
8308 !!$ real :: dist, r, r0
8309 !!$ integer :: i,j,k,n
8310 !!$ real :: utmp, vtmp
8311 !!$
8312 !!$ real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
8313 !!$
8314 !!$ real, dimension(:,:,:), pointer :: grid, agrid
8315 !!$ real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc
8316 !!$
8317 !!$ grid => gridstruct%grid
8318 !!$ agrid=> gridstruct%agrid
8319 !!$
8320 !!$ area => gridstruct%area
8321 !!$ dx => gridstruct%dx
8322 !!$ dy => gridstruct%dy
8323 !!$ dxc => gridstruct%dxc
8324 !!$ dyc => gridstruct%dyc
8325 !!$
8326 !!$ psi(:,:) = 1.e25
8327 !!$ psi_b(:,:) = 1.e25
8328 !!$ do j=jsd,jed
8329 !!$ do i=isd,ied
8330 !!$ psi(i,j) = (-1.0 * Ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
8331 !!$ cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
8332 !!$ enddo
8333 !!$ enddo
8334 !!$ do j=jsd,jed+1
8335 !!$ do i=isd,ied+1
8336 !!$ psi_b(i,j) = (-1.0 * Ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
8337 !!$ cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
8338 !!$ enddo
8339 !!$ enddo
8340 !!$
8341 !!$ if ( defOnGrid == 1 ) then
8342 !!$ do j=jsd,jed+1
8343 !!$ do i=isd,ied
8344 !!$ dist = dx(i,j)
8345 !!$ vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
8346 !!$ if (dist==0) vc(i,j) = 0.
8347 !!$ enddo
8348 !!$ enddo
8349 !!$ do j=jsd,jed
8350 !!$ do i=isd,ied+1
8351 !!$ dist = dy(i,j)
8352 !!$ uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
8353 !!$ if (dist==0) uc(i,j) = 0.
8354 !!$ enddo
8355 !!$ enddo
8356 !!$
8357 !!$
8358 !!$ do j=js,je
8359 !!$ do i=is,ie+1
8360 !!$ dist = dxc(i,j)
8361 !!$ v(i,j) = (psi(i,j)-psi(i-1,j))/dist
8362 !!$ if (dist==0) v(i,j) = 0.
8363 !!$ enddo
8364 !!$ enddo
8365 !!$ do j=js,je+1
8366 !!$ do i=is,ie
8367 !!$ dist = dyc(i,j)
8368 !!$ u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
8369 !!$ if (dist==0) u(i,j) = 0.
8370 !!$ enddo
8371 !!$ enddo
8372 !!$ endif
8373 !!$
8374 !!$ end subroutine init_latlon_winds
8375 
8376 !!$ subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, bounded_domain, &
8377 !!$ u,v, ua,va, uc,vc, gridstruct, domain, bd)
8378 !!$
8379 !!$! Input
8380 !!$ integer, intent(IN) :: im,jm,km
8381 !!$ integer, intent(IN) :: ifirst,ilast
8382 !!$ integer, intent(IN) :: jfirst,jlast
8383 !!$ integer, intent(IN) :: ng
8384 !!$ logical, intent(IN) :: bounded_domain
8385 !!$ type(fv_grid_type), intent(IN), target :: gridstruct
8386 !!$ type(domain2d), intent(INOUT) :: domain
8387 !!$
8388 !!$ !real , intent(in) :: sinlon(im,jm)
8389 !!$ !real , intent(in) :: coslon(im,jm)
8390 !!$ !real , intent(in) :: sinl5(im,jm)
8391 !!$ !real , intent(in) :: cosl5(im,jm)
8392 !!$
8393 !!$! Output
8394 !!$ ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8395 !!$ ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8396 !!$ ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8397 !!$ ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8398 !!$ ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8399 !!$ ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8400 !!$
8401 !!$ real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8402 !!$ real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8403 !!$ real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8404 !!$ real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8405 !!$ real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8406 !!$ real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8407 !!$
8408 !!$!--------------------------------------------------------------
8409 !!$! Local
8410 !!$
8411 !!$ real :: sinlon(im,jm)
8412 !!$ real :: coslon(im,jm)
8413 !!$ real :: sinl5(im,jm)
8414 !!$ real :: cosl5(im,jm)
8415 !!$
8416 !!$ real :: tmp1(jsd:jed+1)
8417 !!$ real :: tmp2(jsd:jed)
8418 !!$ real :: tmp3(jsd:jed)
8419 !!$
8420 !!$ real mag,mag1,mag2, ang,ang1,ang2
8421 !!$ real us, vs, un, vn
8422 !!$ integer i, j, k, im2
8423 !!$ integer js1g1
8424 !!$ integer js2g1
8425 !!$ integer js2g2
8426 !!$ integer js2gc
8427 !!$ integer js2gc1
8428 !!$ integer js2gcp1
8429 !!$ integer js2gd
8430 !!$ integer jn2gc
8431 !!$ integer jn1g1
8432 !!$ integer jn1g2
8433 !!$ integer jn2gd
8434 !!$ integer jn2gsp1
8435 !!$
8436 !!$ real, pointer, dimension(:,:,:) :: agrid, grid
8437 !!$ real, pointer, dimension(:,:) :: area, rarea, fC, f0
8438 !!$ real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
8439 !!$ real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
8440 !!$ real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8441 !!$
8442 !!$ logical, pointer :: cubed_sphere, latlon
8443 !!$
8444 !!$ logical, pointer :: have_south_pole, have_north_pole
8445 !!$
8446 !!$ integer, pointer :: ntiles_g
8447 !!$ real, pointer :: acapN, acapS, globalarea
8448 !!$
8449 !!$ grid => gridstruct%grid
8450 !!$ agrid=> gridstruct%agrid
8451 !!$
8452 !!$ area => gridstruct%area
8453 !!$ rarea => gridstruct%rarea
8454 !!$
8455 !!$ fC => gridstruct%fC
8456 !!$ f0 => gridstruct%f0
8457 !!$
8458 !!$ ee1 => gridstruct%ee1
8459 !!$ ee2 => gridstruct%ee2
8460 !!$ ew => gridstruct%ew
8461 !!$ es => gridstruct%es
8462 !!$ en1 => gridstruct%en1
8463 !!$ en2 => gridstruct%en2
8464 !!$
8465 !!$ dx => gridstruct%dx
8466 !!$ dy => gridstruct%dy
8467 !!$ dxa => gridstruct%dxa
8468 !!$ dya => gridstruct%dya
8469 !!$ rdxa => gridstruct%rdxa
8470 !!$ rdya => gridstruct%rdya
8471 !!$ dxc => gridstruct%dxc
8472 !!$ dyc => gridstruct%dyc
8473 !!$
8474 !!$ cubed_sphere => gridstruct%cubed_sphere
8475 !!$ latlon => gridstruct%latlon
8476 !!$
8477 !!$ have_south_pole => gridstruct%have_south_pole
8478 !!$ have_north_pole => gridstruct%have_north_pole
8479 !!$
8480 !!$ ntiles_g => gridstruct%ntiles_g
8481 !!$ acapN => gridstruct%acapN
8482 !!$ acapS => gridstruct%acapS
8483 !!$ globalarea => gridstruct%globalarea
8484 !!$
8485 !!$ if (cubed_sphere) then
8486 !!$
8487 !!$ call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng)
8488 !!$ if (.not. bounded_domain) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.)
8489 !!$ call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, bounded_domain, domain, noComm=.true.)
8490 !!$ if (.not. bounded_domain) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.)
8491 !!$
8492 !!$ else ! Lat-Lon
8493 !!$
8494 !!$ im2 = im/2
8495 !!$
8496 !!$! Set loop limits
8497 !!$
8498 !!$ js1g1 = jfirst-1
8499 !!$ js2g1 = jfirst-1
8500 !!$ js2g2 = jfirst-2
8501 !!$ js2gc = jfirst-ng
8502 !!$ js2gcp1 = jfirst-ng-1
8503 !!$ js2gd = jfirst-ng
8504 !!$ jn1g1 = jlast+1
8505 !!$ jn1g2 = jlast+2
8506 !!$ jn2gc = jlast+ng
8507 !!$ jn2gd = jlast+ng-1
8508 !!$ jn2gsp1 = jlast+ng-1
8509 !!$
8510 !!$ if (have_south_pole) then
8511 !!$ js1g1 = 1
8512 !!$ js2g1 = 2
8513 !!$ js2g2 = 2
8514 !!$ js2gc = 2
8515 !!$ js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2)
8516 !!$ js2gd = 2
8517 !!$ endif
8518 !!$ if (have_north_pole) then
8519 !!$ jn1g1 = jm
8520 !!$ jn1g2 = jm
8521 !!$ jn2gc = jm-1 ! NG latitudes on N (ending at jm-1)
8522 !!$ jn2gd = jm-1
8523 !!$ jn2gsp1 = jm-1
8524 !!$ endif
8525 !!$!
8526 !!$! Treat the special case of ng = 1
8527 !!$!
8528 !!$ if ( ng == 1 .AND. ng > 1 ) THEN
8529 !!$ js2gc1 = js2gc
8530 !!$ else
8531 !!$ js2gc1 = jfirst-ng+1
8532 !!$ if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2)
8533 !!$ endif
8534 !!$
8535 !!$ do k=1,km
8536 !!$
8537 !!$ if ((have_south_pole) .or. (have_north_pole)) then
8538 !!$! Get D-grid V-wind at the poles.
8539 !!$ call vpol5(u(1:im,:), v(1:im,:), im, jm, &
8540 !!$ coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast )
8541 !!$ call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:))
8542 !!$ endif
8543 !!$
8544 !!$ call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng)
8545 !!$ if (.not. bounded_domain) call fill_corners(ua, va, im, jm, VECTOR=.true., AGRID=.true.)
8546 !!$
8547 !!$ if ( have_south_pole ) then
8548 !!$! Projection at SP
8549 !!$ us = 0.
8550 !!$ vs = 0.
8551 !!$ do i=1,im2
8552 !!$ us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) &
8553 !!$ + (va(i,2)-va(i+im2,2))*coslon(i,2)
8554 !!$ vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) &
8555 !!$ + (va(i+im2,2)-va(i,2))*sinlon(i,2)
8556 !!$ enddo
8557 !!$ us = us/im
8558 !!$ vs = vs/im
8559 !!$! SP
8560 !!$ do i=1,im2
8561 !!$ ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1)
8562 !!$ va(i,1) = us*coslon(i,1) - vs*sinlon(i,1)
8563 !!$ ua(i+im2,1) = -ua(i,1)
8564 !!$ va(i+im2,1) = -va(i,1)
8565 !!$ enddo
8566 !!$ ua(0 ,1) = ua(im,1)
8567 !!$ ua(im+1,1) = ua(1 ,1)
8568 !!$ va(im+1,1) = va(1 ,1)
8569 !!$ endif
8570 !!$
8571 !!$ if ( have_north_pole ) then
8572 !!$! Projection at NP
8573 !!$ un = 0.
8574 !!$ vn = 0.
8575 !!$ j = jm-1
8576 !!$ do i=1,im2
8577 !!$ un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) &
8578 !!$ + (va(i+im2,j)-va(i,j))*coslon(i,j)
8579 !!$ vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) &
8580 !!$ + (va(i+im2,j)-va(i,j))*sinlon(i,j)
8581 !!$ enddo
8582 !!$ un = un/im
8583 !!$ vn = vn/im
8584 !!$! NP
8585 !!$ do i=1,im2
8586 !!$ ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm)
8587 !!$ va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm)
8588 !!$ ua(i+im2,jm) = -ua(i,jm)
8589 !!$ va(i+im2,jm) = -va(i,jm)
8590 !!$ enddo
8591 !!$ ua(0 ,jm) = ua(im,jm)
8592 !!$ ua(im+1,jm) = ua(1 ,jm)
8593 !!$ va(im+1,jm) = va(1 ,jm)
8594 !!$ endif
8595 !!$
8596 !!$ if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:))
8597 !!$ if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:))
8598 !!$
8599 !!$! A -> C
8600 !!$ call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, bounded_domain, domain, noComm=.true.)
8601 !!$
8602 !!$ enddo ! km loop
8603 !!$
8604 !!$ if (.not. bounded_domain) call fill_corners(uc, vc, im, jm, VECTOR=.true., CGRID=.true.)
8605 !!$ endif
8606 !!$
8607 !!$
8608 !!$ end subroutine d2a2c
8609 !!$
8610 
8611 !!$ subroutine atob_s(qin, qout, npx, npy, dxa, dya, bounded_domain, cubed_sphere, altInterp)
8612 !!$
8613 !!$! atob_s :: interpolate scalar from the A-Grid to the B-grid
8614 !!$!
8615 !!$ integer, intent(IN) :: npx, npy
8616 !!$ real , intent(IN) :: qin(isd:ied ,jsd:jed ) ! A-grid field
8617 !!$ real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1) ! Output B-grid field
8618 !!$ integer, OPTIONAL, intent(IN) :: altInterp
8619 !!$ logical, intent(IN) :: bounded_domain, cubed_sphere
8620 !!$ real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8621 !!$
8622 !!$ integer :: i,j,n
8623 !!$
8624 !!$ real :: tmp1j(jsd:jed+1)
8625 !!$ real :: tmp2j(jsd:jed+1)
8626 !!$ real :: tmp3j(jsd:jed+1)
8627 !!$ real :: tmp1i(isd:ied+1)
8628 !!$ real :: tmp2i(isd:ied+1)
8629 !!$ real :: tmp3i(isd:ied+1)
8630 !!$ real :: tmpq(isd:ied ,jsd:jed )
8631 !!$ real :: tmpq1(isd:ied+1,jsd:jed+1)
8632 !!$ real :: tmpq2(isd:ied+1,jsd:jed+1)
8633 !!$
8634 !!$ if (present(altInterp)) then
8635 !!$
8636 !!$ tmpq(:,:) = qin(:,:)
8637 !!$
8638 !!$ if (.not. bounded_domain) call fill_corners(tmpq , npx, npy, FILL=XDir, AGRID=.true.)
8639 !!$! ATOC
8640 !!$ do j=jsd,jed
8641 !!$ call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altInterp)
8642 !!$ enddo
8643 !!$
8644 !!$ if (.not. bounded_domain) call fill_corners(tmpq , npx, npy, FILL=YDir, AGRID=.true.)
8645 !!$! ATOD
8646 !!$ do i=isd,ied
8647 !!$ tmp1j(jsd:jed) = 0.0
8648 !!$ tmp2j(jsd:jed) = tmpq(i,jsd:jed)
8649 !!$ tmp3j(jsd:jed) = dya(i,jsd:jed)
8650 !!$ call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altInterp)
8651 !!$ tmpq2(i,jsd:jed) = tmp1j(jsd:jed)
8652 !!$ enddo
8653 !!$
8654 !!$! CTOB
8655 !!$ do i=isd,ied
8656 !!$ tmp1j(:) = tmpq1(i,:)
8657 !!$ tmp2j(:) = tmpq1(i,:)
8658 !!$ tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8659 !!$ call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altInterp)
8660 !!$ tmpq1(i,:) = tmp1j(:)
8661 !!$ enddo
8662 !!$
8663 !!$! DTOB
8664 !!$ do j=jsd,jed
8665 !!$ tmp1i(:) = tmpq2(:,j)
8666 !!$ tmp2i(:) = tmpq2(:,j)
8667 !!$ tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8668 !!$ call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altInterp)
8669 !!$ tmpq2(:,j) = tmp1i(:)
8670 !!$ enddo
8671 !!$
8672 !!$! Average
8673 !!$ do j=jsd,jed+1
8674 !!$ do i=isd,ied+1
8675 !!$ qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j))
8676 !!$ enddo
8677 !!$ enddo
8678 !!$
8679 !!$! Fix Corners
8680 !!$ if (cubed_sphere .and. .not. bounded_domain) then
8681 !!$ i=1
8682 !!$ j=1
8683 !!$ if ( (is==i) .and. (js==j) ) then
8684 !!$ qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8685 !!$ endif
8686 !!$
8687 !!$ i=npx
8688 !!$ j=1
8689 !!$ if ( (ie+1==i) .and. (js==j) ) then
8690 !!$ qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8691 !!$ endif
8692 !!$
8693 !!$ i=1
8694 !!$ j=npy
8695 !!$ if ( (is==i) .and. (je+1==j) ) then
8696 !!$ qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8697 !!$ endif
8698 !!$
8699 !!$ i=npx
8700 !!$ j=npy
8701 !!$ if ( (ie+1==i) .and. (je+1==j) ) then
8702 !!$ qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8703 !!$ endif
8704 !!$ endif
8705 !!$
8706 !!$ else ! altInterp
8707 !!$
8708 !!$ do j=js,je+1
8709 !!$ do i=is,ie+1
8710 !!$ qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + &
8711 !!$ qin(i ,j) + qin(i ,j-1))
8712 !!$ enddo
8713 !!$ enddo
8714 !!$
8715 !!$ if (.not. bounded_domain) then
8716 !!$ i=1
8717 !!$ j=1
8718 !!$ if ( (is==i) .and. (js==j) ) then
8719 !!$ qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8720 !!$ endif
8721 !!$
8722 !!$ i=npx
8723 !!$ j=1
8724 !!$ if ( (ie+1==i) .and. (js==j) ) then
8725 !!$ qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8726 !!$ endif
8727 !!$
8728 !!$ i=1
8729 !!$ j=npy
8730 !!$ if ( (is==i) .and. (je+1==j) ) then
8731 !!$ qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8732 !!$ endif
8733 !!$
8734 !!$ i=npx
8735 !!$ j=npy
8736 !!$ if ( (ie+1==i) .and. (je+1==j) ) then
8737 !!$ qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8738 !!$ endif
8739 !!$ endif !not bounded_domain
8740 !!$
8741 !!$ endif ! altInterp
8742 !!$
8743 !!$ end subroutine atob_s
8744 !!$!
8745 !!$! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8746 !!$!-------------------------------------------------------------------------------
8747 
8748 !-------------------------------------------------------------------------------
8749 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8750 !
8751 ! atod :: interpolate from the A-Grid to the D-grid
8752 !
8753  subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, bounded_domain, domain, bd)
8754 
8755  type(fv_grid_bounds_type), intent(IN) :: bd
8756  integer, intent(IN) :: npx, npy, ng
8757  real , intent(IN) :: uin(bd%isd:bd%ied ,bd%jsd:bd%jed )
8758  real , intent(IN) :: vin(bd%isd:bd%ied ,bd%jsd:bd%jed )
8759  real , intent(OUT) :: uout(bd%isd:bd%ied ,bd%jsd:bd%jed+1)
8760  real , intent(OUT) :: vout(bd%isd:bd%ied+1,bd%jsd:bd%jed )
8761  logical, intent(IN) :: bounded_domain
8762  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya
8763  real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dxc
8764  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dyc
8765  type(domain2d), intent(INOUT) :: domain
8766 
8767 
8768  integer :: i,j
8769  real :: tmp1i(bd%isd:bd%ied+1)
8770  real :: tmp2i(bd%isd:bd%ied)
8771  real :: tmp3i(bd%isd:bd%ied)
8772  real :: tmp1j(bd%jsd:bd%jed+1)
8773  real :: tmp2j(bd%jsd:bd%jed)
8774  real :: tmp3j(bd%jsd:bd%jed)
8775 
8776  integer :: jsd, jed, isd, ied
8777  isd = bd%isd
8778  ied = bd%ied
8779  jsd = bd%jsd
8780  jed = bd%jed
8781 
8782  do j=jsd+1,jed
8783  tmp1i(:) = 0.0
8784  tmp2i(:) = vin(:,j)*dxa(:,j)
8785  tmp3i(:) = dxa(:,j)
8786  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interporder)
8787  vout(:,j) = tmp1i(:)/dxc(:,j)
8788  enddo
8789  do i=isd+1,ied
8790  tmp1j(:) = 0.0
8791  tmp2j(:) = uin(i,:)*dya(i,:)
8792  tmp3j(:) = dya(i,:)
8793  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8794  uout(i,:) = tmp1j(:)/dyc(i,:)
8795  enddo
8796  call mp_update_dwinds(uout, vout, npx, npy, domain, bd)
8797  if (.not. bounded_domain) call fill_corners(uout, vout, npx, npy, vector=.true., dgrid=.true.)
8798  end subroutine atod
8799 !
8800 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8801 !-------------------------------------------------------------------------------
8802 
8803 !-------------------------------------------------------------------------------
8804 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8805 !
8806 ! dtoa :: interpolate from the D-Grid to the A-grid
8807 !
8808  subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng, bd)
8809 
8810  type(fv_grid_bounds_type), intent(IN) :: bd
8811  integer, intent(IN) :: npx, npy, ng
8812  real , intent(IN) :: uin(bd%isd:bd%ied ,bd%jsd:bd%jed+1)
8813  real , intent(IN) :: vin(bd%isd:bd%ied+1,bd%jsd:bd%jed )
8814  real , intent(OUT) :: uout(bd%isd:bd%ied ,bd%jsd:bd%jed )
8815  real , intent(OUT) :: vout(bd%isd:bd%ied ,bd%jsd:bd%jed )
8816  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dx, dyc
8817  real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dy, dxc
8818  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya
8819 
8820  integer :: i,j,n
8821 
8822  real :: tmp1i(bd%isd:bd%ied+1)
8823  real :: tmp2i(bd%isd:bd%ied+1)
8824  real :: tmp3i(bd%isd:bd%ied+1)
8825  real :: tmp1j(bd%jsd:bd%jed+1)
8826  real :: tmp2j(bd%jsd:bd%jed+1)
8827  real :: tmp3j(bd%jsd:bd%jed+1)
8828 
8829  integer :: is, ie, js, je
8830  integer :: isd, ied, jsd, jed
8831 
8832  is = bd%is
8833  ie = bd%ie
8834  js = bd%js
8835  je = bd%je
8836  isd = bd%isd
8837  ied = bd%ied
8838  jsd = bd%jsd
8839  jed = bd%jed
8840 
8841 !CLEANUP: replace dxa with rdxa, and dya with rdya; may change numbers.
8842 #ifdef VORT_ON
8843 ! circulation (therefore, vort) conserving:
8844  do j=jsd,jed
8845  do i=isd,ied
8846  uout(i,j) = 0.5*(uin(i,j)*dx(i,j)+uin(i,j+1)*dx(i,j+1))/dxa(i,j)
8847  vout(i,j) = 0.5*(vin(i,j)*dy(i,j)+vin(i+1,j)*dy(i+1,j))/dya(i,j)
8848  enddo
8849  enddo
8850 #else
8851  do i=isd,ied
8852  tmp1j(:) = 0.0
8853  tmp2j(:) = uin(i,:)*dyc(i,:)
8854  tmp3j(:) = dyc(i,:)
8855  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interporder)
8856  uout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dya(i,jsd:jed)
8857  enddo
8858  do j=jsd,jed
8859  tmp1i(:) = 0.0
8860  tmp2i(:) = vin(:,j)*dxc(:,j)
8861  tmp3i(:) = dxc(:,j)
8862  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interporder)
8863  vout(isd:ied,j) = tmp1i(isd+1:ied+1)/dxa(isd:ied,j)
8864  enddo
8865 #endif
8866 
8867  end subroutine dtoa
8868 !
8869 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8870 !-------------------------------------------------------------------------------
8871 
8872 !-------------------------------------------------------------------------------
8873 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8874 !
8875 ! atoc :: interpolate from the A-Grid to the C-grid
8876 !
8877  subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, bounded_domain, domain, bd, noComm)
8878 
8879  type(fv_grid_bounds_type), intent(IN) :: bd
8880  integer, intent(IN) :: npx, npy, ng
8881  real , intent(IN) :: uin(bd%isd:bd%ied ,bd%jsd:bd%jed ) ! A-grid u-wind field
8882  real , intent(IN) :: vin(bd%isd:bd%ied ,bd%jsd:bd%jed ) ! A-grid v-wind field
8883  real , intent(OUT) :: uout(bd%isd:bd%ied+1,bd%jsd:bd%jed ) ! C-grid u-wind field
8884  real , intent(OUT) :: vout(bd%isd:bd%ied ,bd%jsd:bd%jed+1) ! C-grid v-wind field
8885  logical, intent(IN) :: bounded_domain
8886  logical, OPTIONAL, intent(IN) :: noComm
8887  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dx
8888  real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dy
8889  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya
8890  type(domain2d), intent(INOUT) :: domain
8891 
8892  real :: ang1
8893  integer :: i,j,n
8894 
8895  real :: tmp1i(bd%isd:bd%ied+1)
8896  real :: tmp2i(bd%isd:bd%ied)
8897  real :: tmp3i(bd%isd:bd%ied)
8898  real :: tmp1j(bd%jsd:bd%jed+1)
8899  real :: tmp2j(bd%jsd:bd%jed)
8900  real :: tmp3j(bd%jsd:bd%jed)
8901 
8902  integer :: is, ie, js, je
8903  integer :: isd, ied, jsd, jed
8904 
8905  is = bd%is
8906  ie = bd%ie
8907  js = bd%js
8908  je = bd%je
8909  isd = bd%isd
8910  ied = bd%ied
8911  jsd = bd%jsd
8912  jed = bd%jed
8913 
8914 
8915 #if !defined(ALT_INTERP)
8916 #ifdef VORT_ON
8917 ! Circulation conserving
8918  do j=jsd,jed
8919  do i=isd+1,ied
8920  uout(i,j) = ( uin(i,j)*dxa(i,j) + uin(i-1,j)*dxa(i-1,j) ) &
8921  / ( dxa(i,j) + dxa(i-1,j) )
8922  enddo
8923  enddo
8924  do j=jsd+1,jed
8925  do i=isd,ied
8926  vout(i,j) = ( vin(i,j)*dya(i,j) + vin(i,j-1)*dya(i,j-1) ) &
8927  / ( dya(i,j) + dya(i,j-1) )
8928  enddo
8929  enddo
8930 #else
8931  do j=jsd,jed
8932  call interp_left_edge_1d(uout(:,j), uin(:,j), dxa(:,j), isd, ied, interporder)
8933  enddo
8934  do i=isd,ied
8935 !!$ tmp1j(:) = vout(i,:)
8936  tmp2j(:) = vin(i,:)
8937  tmp3j(:) = dya(i,:)
8938  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8939  vout(i,:) = tmp1j(:)
8940  enddo
8941 #endif
8942 #else
8943 
8944  do j=jsd,jed
8945 !!$ tmp1i(:) = uout(:,j)
8946  tmp2i(:) = uin(:,j)*dya(:,j)
8947  tmp3i(:) = dxa(:,j)
8948  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interporder)
8949  uout(:,j) = tmp1i(:)/dy(:,j)
8950  enddo
8951  do i=isd,ied
8952 !!$ tmp1j(:) = vout(i,:)
8953  tmp2j(:) = vin(i,:)*dxa(i,:)
8954  tmp3j(:) = dya(i,:)
8955  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8956  vout(i,:) = tmp1j(:)/dx(i,:)
8957  enddo
8958 
8959  if (cubed_sphere .and. .not. bounded_domain) then
8960  csfac = cos(30.0*pi/180.0)
8961  ! apply Corner scale factor for interp on Cubed-Sphere
8962  if ( (is==1) .and. (js==1) ) then
8963  i=1
8964  j=1
8965  uout(i,j)=uout(i,j)*csfac
8966  uout(i,j-1)=uout(i,j-1)*csfac
8967  vout(i,j)=vout(i,j)*csfac
8968  vout(i-1,j)=vout(i-1,j)*csfac
8969  endif
8970  if ( (is==1) .and. (je==npy-1) ) then
8971  i=1
8972  j=npy-1
8973  uout(i,j)=uout(i,j)*csfac
8974  uout(i,j+1)=uout(i,j+1)*csfac
8975  vout(i,j+1)=vout(i,j+1)*csfac
8976  vout(i-1,j+1)=vout(i-1,j+1)*csfac
8977  endif
8978  if ( (ie==npx-1) .and. (je==npy-1) ) then
8979  i=npx-1
8980  j=npy-1
8981  uout(i+1,j)=uout(i+1,j)*csfac
8982  uout(i+1,j+1)=uout(i+1,j+1)*csfac
8983  vout(i,j+1)=vout(i,j+1)*csfac
8984  vout(i+1,j+1)=vout(i+1,j+1)*csfac
8985  endif
8986  if ( (ie==npx-1) .and. (js==1) ) then
8987  i=npx-1
8988  j=1
8989  uout(i+1,j)=uout(i+1,j)*csfac
8990  uout(i+1,j-1)=uout(i+1,j-1)*csfac
8991  vout(i,j)=vout(i,j)*csfac
8992  vout(i+1,j)=vout(i+1,j)*csfac
8993  endif
8994  endif
8995 
8996 #endif
8997 
8998  if (present(nocomm)) then
8999  if (.not. nocomm) call mpp_update_domains( uout,vout, domain, gridtype=cgrid_ne_param, complete=.true.)
9000  else
9001  call mpp_update_domains( uout,vout, domain, gridtype=cgrid_ne_param, complete=.true.)
9002  endif
9003  if (.not. bounded_domain) call fill_corners(uout, vout, npx, npy, vector=.true., cgrid=.true.)
9004 
9005  end subroutine atoc
9006 !
9007 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
9008 !-------------------------------------------------------------------------------
9009 
9010 !-------------------------------------------------------------------------------
9011 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9012 !
9013 ! ctoa :: interpolate from the C-Grid to the A-grid
9014 !
9015  subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng, bd)
9016 
9017 
9018  type(fv_grid_bounds_type), intent(IN) :: bd
9019  integer, intent(IN) :: npx, npy, ng
9020  real , intent(IN) :: uin(bd%isd:bd%ied+1,bd%jsd:bd%jed )
9021  real , intent(IN) :: vin(bd%isd:bd%ied ,bd%jsd:bd%jed+1)
9022  real , intent(OUT) :: uout(bd%isd:bd%ied ,bd%jsd:bd%jed )
9023  real , intent(OUT) :: vout(bd%isd:bd%ied ,bd%jsd:bd%jed )
9024  real , intent(IN), dimension(bd%isd:bd%ied+1,bd%jsd:bd%jed) :: dxc, dy
9025  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed+1) :: dyc, dx
9026  real , intent(IN), dimension(bd%isd:bd%ied,bd%jsd:bd%jed) :: dxa, dya
9027 
9028  integer :: i,j
9029 
9030  real :: tmp1i(bd%isd:bd%ied+1)
9031  real :: tmp2i(bd%isd:bd%ied+1)
9032  real :: tmp3i(bd%isd:bd%ied+1)
9033  real :: tmp1j(bd%jsd:bd%jed+1)
9034  real :: tmp2j(bd%jsd:bd%jed+1)
9035  real :: tmp3j(bd%jsd:bd%jed+1)
9036 
9037  integer :: is, ie, js, je
9038  integer :: isd, ied, jsd, jed
9039 
9040  is = bd%is
9041  ie = bd%ie
9042  js = bd%js
9043  je = bd%je
9044  isd = bd%isd
9045  ied = bd%ied
9046  jsd = bd%jsd
9047  jed = bd%jed
9048 
9049  ! do j=jsd,jed
9050  ! do i=isd,ied
9051  ! uout(i,j) = 0.5 * (uin(i,j)*dy(i,j) + uin(i+1,j)*dy(i+1,j))/dya(i,j)
9052  ! enddo
9053  ! enddo
9054  ! do j=jsd,jed
9055  ! do i=isd,ied
9056  ! vout(i,j) = 0.5 * (vin(i,j)*dx(i,j) + vin(i,j+1)*dx(i,j+1))/dxa(i,j)
9057  ! enddo
9058  ! enddo
9059  do i=isd,ied
9060  tmp1j(:) = 0.0
9061  tmp2j(:) = vin(i,:)*dx(i,:)
9062  tmp3j(:) = dyc(i,:)
9063  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interporder)
9064  vout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dxa(i,jsd:jed)
9065  enddo
9066  do j=jsd,jed
9067  tmp1i(:) = 0.0
9068  tmp2i(:) = uin(:,j)*dy(:,j)
9069  tmp3i(:) = dxc(:,j)
9070  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interporder)
9071  uout(isd:ied,j) = tmp1i(isd+1:ied+1)/dya(isd:ied,j)
9072  enddo
9073 
9074  end subroutine ctoa
9075 !
9076 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
9077 !-------------------------------------------------------------------------------
9078 
9079 !-------------------------------------------------------------------------------
9080 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9081 !
9082 ! rotate_winds :: rotate winds from the sphere-to-cube || cube-to-sphere
9083 !
9084  subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
9085 
9086 
9087  integer, intent(IN) :: ndims
9088  real , intent(INOUT) :: myU
9089  real , intent(INOUT) :: myV
9090  real(kind=R_GRID) , intent(IN) :: p1(ndims) ! p4
9091  real(kind=R_GRID) , intent(IN) :: p2(ndims) !
9092  real(kind=R_GRID) , intent(IN) :: p3(ndims) ! p1 t1 p3
9093  real(kind=R_GRID) , intent(IN) :: p4(ndims) !
9094  real(kind=R_GRID) , intent(IN) :: t1(ndims) ! p2
9095  integer, intent(IN) :: dir
9096 
9097  real(kind=R_GRID) :: ee1(3), ee2(3), ee3(3), elon(3), elat(3)
9098 
9099  real :: g11, g12, g21, g22
9100 
9101  real :: newu, newv
9102 
9103  call get_unit_vector(p3, t1, p1, ee1)
9104  call get_unit_vector(p4, t1, p2, ee2)
9105  elon(1) = -sin(t1(1) - pi)
9106  elon(2) = cos(t1(1) - pi)
9107  elon(3) = 0.0
9108  elat(1) = -sin(t1(2))*cos(t1(1) - pi)
9109  elat(2) = -sin(t1(2))*sin(t1(1) - pi)
9110  elat(3) = cos(t1(2))
9111 
9112  g11 = inner_prod(ee1,elon)
9113  g12 = inner_prod(ee1,elat)
9114  g21 = inner_prod(ee2,elon)
9115  g22 = inner_prod(ee2,elat)
9116 
9117  if (dir == 1) then ! Sphere to Cube Rotation
9118  newu = myu*g11 + myv*g12
9119  newv = myu*g21 + myv*g22
9120  else
9121  newu = ( myu*g22 - myv*g12)/(g11*g22 - g21*g12)
9122  newv = (-myu*g21 + myv*g11)/(g11*g22 - g21*g12)
9123  endif
9124  myu = newu
9125  myv = newv
9126 
9127  end subroutine rotate_winds
9128 
9129  subroutine mp_update_dwinds_2d(u, v, npx, npy, domain, bd)
9130  use mpp_parameter_mod, only: dgrid_ne
9131  type(fv_grid_bounds_type), intent(IN) :: bd
9132  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1)
9133  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed )
9134  integer, intent(IN) :: npx, npy
9135  type(domain2d), intent(INOUT) :: domain
9136 
9137  call mpp_update_domains( u, v, domain, gridtype=dgrid_ne, complete=.true.)
9138 ! if (.not. bounded_domain) call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.)
9139 
9140  end subroutine mp_update_dwinds_2d
9141 !
9142 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
9143 !-------------------------------------------------------------------------------
9144 
9145 !-------------------------------------------------------------------------------
9146 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9147 !
9148  subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain, bd)
9149  use mpp_parameter_mod, only: dgrid_ne
9150  type(fv_grid_bounds_type), intent(IN) :: bd
9151  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
9152  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
9153  integer, intent(IN) :: npx, npy, npz
9154  type(domain2d), intent(INOUT) :: domain
9155  integer k
9156 
9157  call mpp_update_domains( u, v, domain, gridtype=dgrid_ne, complete=.true.)
9158 ! do k=1,npz
9159 ! if (.not. bounded_domain) call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.)
9160 ! enddo
9161 
9162  end subroutine mp_update_dwinds_3d
9163 
9164 !-------------------------------------------------------------------------------
9165 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9166 !
9167 ! gsum :: get global sum
9168 !
9169  real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile) result (gsum)
9170 
9171  integer, intent(IN) :: npx, npy
9172  integer, intent(IN) :: ifirst, ilast
9173  integer, intent(IN) :: jfirst, jlast
9174  integer, intent(IN) :: isd, ied
9175  integer, intent(IN) :: jsd, jed, tile
9176  real , intent(IN) :: p(ifirst:ilast,jfirst:jlast)
9177  type(fv_grid_type), intent(IN), target :: gridstruct
9178 
9179  integer :: i,j,k,n
9180  integer :: j1, j2
9181  real :: gsum0
9182  real, allocatable :: p_R8(:,:,:)
9183 
9184  real, pointer, dimension(:,:,:) :: agrid, grid
9185  real, pointer, dimension(:,:) :: area, rarea, fC, f0
9186  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
9187 
9188  logical, pointer :: cubed_sphere, latlon
9189 
9190  logical, pointer :: have_south_pole, have_north_pole
9191 
9192  integer, pointer :: ntiles_g
9193  real, pointer :: acapN, acapS, globalarea
9194 
9195  grid => gridstruct%grid
9196  agrid=> gridstruct%agrid
9197 
9198  area => gridstruct%area
9199  rarea => gridstruct%rarea
9200 
9201  fc => gridstruct%fC
9202  f0 => gridstruct%f0
9203 
9204  dx => gridstruct%dx
9205  dy => gridstruct%dy
9206  dxa => gridstruct%dxa
9207  dya => gridstruct%dya
9208  rdxa => gridstruct%rdxa
9209  rdya => gridstruct%rdya
9210  dxc => gridstruct%dxc
9211  dyc => gridstruct%dyc
9212 
9213  cubed_sphere => gridstruct%cubed_sphere
9214  latlon => gridstruct%latlon
9215 
9216  have_south_pole => gridstruct%have_south_pole
9217  have_north_pole => gridstruct%have_north_pole
9218 
9219  ntiles_g => gridstruct%ntiles_g
9220  acapn => gridstruct%acapN
9221  acaps => gridstruct%acapS
9222  globalarea => gridstruct%globalarea
9223 
9224  allocate(p_r8(npx-1,npy-1,ntiles_g))
9225  gsum = 0.
9226 
9227  if (latlon) then
9228  j1 = 2
9229  j2 = npy-2
9230  !!! WARNING: acapS and acapN have NOT been initialized.
9231  gsum = gsum + p(1,1)*acaps
9232  gsum = gsum + p(1,npy-1)*acapn
9233  do j=j1,j2
9234  do i=1,npx-1
9235  gsum = gsum + p(i,j)*cos(agrid(i,j,2))
9236  enddo
9237  enddo
9238  else
9239 
9240  do n=tile,tile
9241  do j=jfirst,jlast
9242  do i=ifirst,ilast
9243  p_r8(i,j,n) = p(i,j)*area(i,j)
9244  enddo
9245  enddo
9246  enddo
9247  call mp_gather(p_r8, ifirst,ilast, jfirst,jlast, npx-1, npy-1, ntiles_g)
9248  if (is_master()) then
9249  do n=1,ntiles_g
9250  do j=1,npy-1
9251  do i=1,npx-1
9252  gsum = gsum + p_r8(i,j,n)
9253  enddo
9254  enddo
9255  enddo
9256  gsum = gsum/globalarea
9257  endif
9258  call mpp_broadcast(gsum, mpp_root_pe())
9259 
9260  endif
9261 
9262  deallocate(p_r8)
9263 
9264  end function globalsum
9265 
9266 
9267  subroutine get_unit_vector( p1, p2, p3, uvect )
9268  real(kind=R_GRID), intent(in):: p1(2), p2(2), p3(2) ! input position unit vectors (spherical coordinates)
9269  real(kind=R_GRID), intent(out):: uvect(3) ! output unit spherical cartesian
9270 ! local
9271  integer :: n
9272  real(kind=R_GRID) :: xyz1(3), xyz2(3), xyz3(3)
9273  real :: dp(3)
9274 
9275  call spherical_to_cartesian(p1(1), p1(2), one, xyz1(1), xyz1(2), xyz1(3))
9276  call spherical_to_cartesian(p2(1), p2(2), one, xyz2(1), xyz2(2), xyz2(3))
9277  call spherical_to_cartesian(p3(1), p3(2), one, xyz3(1), xyz3(2), xyz3(3))
9278  do n=1,3
9279  uvect(n) = xyz3(n)-xyz1(n)
9280  enddo
9281  call project_sphere_v(1, uvect,xyz2)
9282  call normalize_vect(1, uvect)
9283 
9284  end subroutine get_unit_vector
9285 
9286 
9287  subroutine normalize_vect(np, e)
9288 !
9289 ! Make e an unit vector
9290 !
9291  implicit none
9292  integer, intent(in):: np
9293  real(kind=R_GRID), intent(inout):: e(3,np)
9294 ! local:
9295  integer k, n
9296  real pdot
9297 
9298  do n=1,np
9299  pdot = sqrt(e(1,n)**2+e(2,n)**2+e(3,n)**2)
9300  do k=1,3
9301  e(k,n) = e(k,n) / pdot
9302  enddo
9303  enddo
9304 
9305  end subroutine normalize_vect
9306 !------------------------------------------------------------------------------
9307 !BOP
9308 ! !ROUTINE: mp_ghost_ew --- Ghost 4d east/west "lat/lon periodic
9309 !
9310 ! !INTERFACE:
9311  subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
9312  kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
9313 !
9314 ! !INPUT PARAMETERS:
9315  integer, intent(in):: im, jm, km, nq
9316  integer, intent(in):: ifirst, ilast
9317  integer, intent(in):: jfirst, jlast
9318  integer, intent(in):: kfirst, klast
9319  integer, intent(in):: ng_e ! eastern zones to ghost
9320  integer, intent(in):: ng_w ! western zones to ghost
9321  integer, intent(in):: ng_s ! southern zones to ghost
9322  integer, intent(in):: ng_n ! northern zones to ghost
9323  real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
9324  real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq)
9325 !
9326 ! !DESCRIPTION:
9327 !
9328 ! Ghost 4d east/west
9329 !
9330 ! !REVISION HISTORY:
9331 ! 2005.08.22 Putman
9332 !
9333 !EOP
9334 !------------------------------------------------------------------------------
9335 !BOC
9336  integer :: i,j,k,n
9337 
9338  if (present(q)) then
9339  q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = &
9340  q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq)
9341  endif
9342 
9343 ! Assume Periodicity in X-dir and not overlapping
9344  do n=1,nq
9345  do k=kfirst,klast
9346  do j=jfirst-ng_s,jlast+ng_n
9347  do i=1, ng_w
9348  q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n)
9349  enddo
9350  do i=1, ng_e
9351  q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n)
9352  enddo
9353  enddo
9354  enddo
9355  enddo
9356 
9357 !EOC
9358  end subroutine mp_ghost_ew
9359 
9360 
9361 
9362 
9363 
9364 
9365 !-------------------------------------------------------------------------------
9366 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
9367 !
9368 ! interp_left_edge_1d :: interpolate to left edge of a cell either
9369 ! order = 1 -> Linear average
9370 ! order = 2 -> Uniform PPM
9371 ! order = 3 -> Non-Uniform PPM
9372 !
9373  subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
9374  integer, intent(in):: ifirst,ilast
9375  real, intent(out) :: qout(ifirst:)
9376  real, intent(in) :: qin(ifirst:)
9377  real, intent(in) :: dx(ifirst:)
9378  integer, intent(in):: order
9379  integer :: i
9380 
9381  real :: dm(ifirst:ilast),qmax,qmin
9382  real :: r3, da1, da2, a6da, a6, al, ar
9383  real :: qLa, qLb1, qLb2
9384  real :: x
9385 
9386  r3 = 1./3.
9387 
9388  qout(:) = 0.0
9389  if (order==1) then
9390 ! 1st order Uniform linear averaging
9391  do i=ifirst+1,ilast
9392  qout(i) = 0.5 * (qin(i-1) + qin(i))
9393  enddo
9394  elseif (order==2) then
9395 ! Non-Uniform 1st order average
9396  do i=ifirst+1,ilast
9397  qout(i) = (dx(i-1)*qin(i-1) + dx(i)*qin(i))/(dx(i-1)+dx(i))
9398  enddo
9399  elseif (order==3) then
9400 
9401 ! PPM - Uniform
9402  do i=ifirst+1,ilast-1
9403  dm(i) = 0.25*(qin(i+1) - qin(i-1))
9404  enddo
9405 !
9406 ! Applies monotonic slope constraint
9407 !
9408  do i=ifirst+1,ilast-1
9409  qmax = max(qin(i-1),qin(i),qin(i+1)) - qin(i)
9410  qmin = qin(i) - min(qin(i-1),qin(i),qin(i+1))
9411  dm(i) = sign(min(abs(dm(i)),qmin,qmax),dm(i))
9412  enddo
9413 
9414  do i=ifirst+1,ilast-1
9415  qout(i) = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9416  ! al = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9417  ! da1 = dm(i) + dm(i)
9418  ! qout(i) = qin(i) - sign(min(abs(da1),abs(al-qin(i))), da1)
9419  enddo
9420 
9421 ! First order average to fill in end points
9422  qout(ifirst+1) = 0.5 * (qin(ifirst) + qin(ifirst+1))
9423  qout(ilast) = 0.5 * (qin(ilast-1) + qin(ilast))
9424 
9425  elseif (order==4) then
9426 
9427  ! Non-Uniform PPM
9428  do i=ifirst+1,ilast-1
9429  dm(i) = ( (2.*dx(i-1) + dx(i) ) / &
9430  ( dx(i+1) + dx(i) ) ) * ( qin(i+1) - qin(i) ) + &
9431  ( (dx(i) + 2.*dx(i+1)) / &
9432  (dx(i-1) + dx(i) ) ) * ( qin(i) - qin(i-1) )
9433  dm(i) = ( dx(i) / ( dx(i-1) + dx(i) + dx(i+1) ) ) * dm(i)
9434  if ( (qin(i+1)-qin(i))*(qin(i)-qin(i-1)) > 0.) then
9435  dm(i) = sign( min( abs(dm(i)), 2.*abs(qin(i)-qin(i-1)), 2.*abs(qin(i+1)-qin(i)) ) , dm(i) )
9436  else
9437  dm(i) = 0.
9438  endif
9439  enddo
9440 
9441  do i=ifirst+2,ilast-1
9442  qla = ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) - &
9443  ( (dx(i+1) + dx(i)) / (2.*dx(i) + dx(i-1)) )
9444  qla = ( (2.*dx(i) * dx(i-1)) / (dx(i-1) + dx(i)) ) * qla * &
9445  (qin(i) - qin(i-1))
9446  qlb1 = dx(i-1) * ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) * &
9447  dm(i)
9448  qlb2 = dx(i) * ( (dx(i) + dx(i+1)) / (dx(i-1) + 2.*dx(i)) ) * &
9449  dm(i-1)
9450 
9451  qout(i) = 1. / ( dx(i-2) + dx(i-1) + dx(i) + dx(i+1) )
9452  qout(i) = qout(i) * ( qla - qlb1 + qlb2 )
9453  qout(i) = qin(i-1) + ( dx(i-1) / ( dx(i-1) + dx(i) ) ) * (qin(i) - qin(i-1)) + qout(i)
9454  enddo
9455 
9456  elseif (order==5) then
9457 
9458  ! Linear Spline
9459  do i=ifirst+1,ilast-1
9460  x = float(i-(ifirst+1))*float(ilast-ifirst+1-1)/float(ilast-ifirst-1)
9461  qout(i) = qin(ifirst+nint(x)) + (x - nint(x)) * (qin(ifirst+nint(x+1)) - qin(ifirst+nint(x)))
9462  ! if (tile==1) print*, ifirst+NINT(x+1), ifirst+NINT(x), (x - NINT(x))
9463  ! if (tile==1) print*, 0.5*(qin(i-1)+qin(i)), qout(i)
9464  enddo
9465 
9466 !!$ if (tile==1) print*,'x=fltarr(28)'
9467 !!$ do i=ifirst,ilast
9468 !!$ if (tile==1) print*, 'x(',i-ifirst,')=',qin(i)
9469 !!$ enddo
9470 
9471 
9472  call mp_stop
9473  stop
9474 
9475  endif
9476 
9477  end subroutine interp_left_edge_1d
9478 !------------------------------------------------------------------------------
9479 !-----------------------------------------------------------------------
9480 !BOP
9481 !
9482  subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, &
9483  ng_d, ng_s, jfirst, jlast)
9484 
9485 ! !INPUT PARAMETERS:
9486  integer im
9487  integer jm
9488  integer jfirst
9489  integer jlast
9490  integer, intent(in):: ng_s, ng_d
9491  real, intent(in):: coslon(im,jm), sinlon(im,jm)
9492  real, intent(in):: cosl5(im,jm),sinl5(im,jm)
9493  real, intent(in):: u(im,jfirst-ng_d:jlast+ng_s)
9494 
9495 ! !INPUT/OUTPUT PARAMETERS:
9496  real, intent(inout):: v(im,jfirst-ng_d:jlast+ng_d)
9497 
9498 ! !DESCRIPTION:
9499 !
9500 ! Treat the V winds at the poles. This requires an average
9501 ! of the U- and V-winds, weighted by their angles of incidence
9502 ! at the pole points.
9503 !
9504 ! !REVISION HISTORY:
9505 !
9506 !EOP
9507 !-----------------------------------------------------------------------
9508 !BOC
9509 !
9510 ! !LOCAL VARIABLES:
9511 
9512  integer i, imh
9513  real uanp(im), uasp(im), vanp(im), vasp(im)
9514  real un, vn, us, vs, r2im
9515 
9516 ! WS 99.05.25 : Replaced conversions of IMR with IM
9517  r2im = 0.5d0/dble(im)
9518  imh = im / 2
9519 
9520 ! WS 990726 : Added condition to decide if poles are on this processor
9521 
9522  if ( jfirst-ng_d <= 1 ) then
9523  do i=1,im
9524  uasp(i) = u(i, 2) + u(i,3)
9525  enddo
9526 
9527  do i=1,im-1
9528  vasp(i) = v(i, 2) + v(i+1,2)
9529  enddo
9530  vasp(im) = v(im,2) + v(1,2)
9531 
9532 ! Projection at SP
9533  us = 0.; vs = 0.
9534 
9535  do i=1,imh
9536  us = us + (uasp(i+imh)-uasp(i))*sinlon(i,1) &
9537  + (vasp(i)-vasp(i+imh))*coslon(i,1)
9538  vs = vs + (uasp(i+imh)-uasp(i))*coslon(i,1) &
9539  + (vasp(i+imh)-vasp(i))*sinlon(i,1)
9540  enddo
9541  us = us*r2im
9542  vs = vs*r2im
9543 
9544 ! get V-wind at SP
9545 
9546  do i=1,imh
9547  v(i, 1) = us*cosl5(i,1) - vs*sinl5(i,1)
9548  v(i+imh,1) = -v(i,1)
9549  enddo
9550 
9551  endif
9552 
9553  if ( jlast+ng_d >= jm ) then
9554 
9555  do i=1,im
9556  uanp(i) = u(i,jm-1) + u(i,jm)
9557  enddo
9558 
9559  do i=1,im-1
9560  vanp(i) = v(i,jm-1) + v(i+1,jm-1)
9561  enddo
9562  vanp(im) = v(im,jm-1) + v(1,jm-1)
9563 
9564 ! Projection at NP
9565 
9566  un = 0.
9567  vn = 0.
9568  do i=1,imh
9569  un = un + (uanp(i+imh)-uanp(i))*sinlon(i,jm) &
9570  + (vanp(i+imh)-vanp(i))*coslon(i,jm)
9571  vn = vn + (uanp(i)-uanp(i+imh))*coslon(i,jm) &
9572  + (vanp(i+imh)-vanp(i))*sinlon(i,jm)
9573  enddo
9574  un = un*r2im
9575  vn = vn*r2im
9576 
9577 ! get V-wind at NP
9578 
9579  do i=1,imh
9580  v(i, jm) = -un*cosl5(i,jm) - vn*sinl5(i,jm)
9581  v(i+imh,jm) = -v(i,jm)
9582  enddo
9583 
9584  endif
9585 
9586  end subroutine vpol5
9587 
9588  subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
9589 ! Single PE version
9590  character(len=*), intent(in):: qname
9591  integer, intent(in):: is, ie, js, je
9592  integer, intent(in):: n_g, km
9593  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
9594  real, intent(in):: fac
9595 
9596  real qmin, qmax
9597  integer i,j,k
9598 
9599  qmin = q(is,js,1)
9600  qmax = qmin
9601 
9602  do k=1,km
9603  do j=js,je
9604  do i=is,ie
9605  if( q(i,j,k) < qmin ) then
9606  qmin = q(i,j,k)
9607  elseif( q(i,j,k) > qmax ) then
9608  qmax = q(i,j,k)
9609  endif
9610  enddo
9611  enddo
9612  enddo
9613 
9614  write(*,*) qname, ' max = ', qmax*fac, ' min = ', qmin*fac
9615 
9616  end subroutine prt_m1
9617 
9618  subroutine var_dz(km, ztop, ze)
9619  integer, intent(in):: km
9620  real, intent(in):: ztop
9621  real, intent(out), dimension(km+1):: ze
9622 ! Local
9623  real, dimension(km):: dz, s_fac
9624  real dz0, sum1
9625  integer k
9626 
9627  s_fac(km ) = 0.25
9628  s_fac(km-1) = 0.30
9629  s_fac(km-2) = 0.50
9630  s_fac(km-3) = 0.70
9631  s_fac(km-4) = 0.90
9632  s_fac(km-5) = 1.
9633  do k=km-6, 5, -1
9634  s_fac(k) = 1.05 * s_fac(k+1)
9635  enddo
9636  s_fac(4) = 1.1*s_fac(5)
9637  s_fac(3) = 1.2*s_fac(4)
9638  s_fac(2) = 1.3*s_fac(3)
9639  s_fac(1) = 1.5*s_fac(2)
9640 
9641  sum1 = 0.
9642  do k=1,km
9643  sum1 = sum1 + s_fac(k)
9644  enddo
9645 
9646  dz0 = ztop / sum1
9647 
9648  do k=1,km
9649  dz(k) = s_fac(k) * dz0
9650  enddo
9651 
9652  ze(km+1) = 0.
9653  do k=km,1,-1
9654  ze(k) = ze(k+1) + dz(k)
9655  enddo
9656 
9657 ! Re-scale dz with the stretched ztop
9658  do k=1,km
9659  dz(k) = dz(k) * (ztop/ze(1))
9660  enddo
9661 
9662  do k=km,1,-1
9663  ze(k) = ze(k+1) + dz(k)
9664  enddo
9665  ze(1) = ztop
9666 
9667  call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 1)
9668 
9669  if ( is_master() ) then
9670  write(*,*) 'var_dz: model top (km)=', ztop*0.001
9671  do k=km,1,-1
9672  dz(k) = ze(k) - ze(k+1)
9673  write(*,*) k, 0.5*(ze(k)+ze(k+1)), 'dz=', dz(k)
9674  enddo
9675  endif
9676 
9677  end subroutine var_dz
9678 
9679  subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
9680  integer, intent(in):: is, ie, js, je, km
9681  integer, intent(in):: ntimes, i, j
9682  real, intent(inout):: ze(is:ie,js:je,km+1)
9683 ! local:
9684  real, parameter:: df = 0.25
9685  real dz(km)
9686  real flux(km+1)
9687  integer k, n, k1, k2
9688 
9689  k2 = km-1
9690  do k=1,km
9691  dz(k) = ze(i,j,k+1) - ze(i,j,k)
9692  enddo
9693 
9694  do n=1,ntimes
9695  k1 = 2 + (ntimes-n)
9696 
9697  flux(k1 ) = 0.
9698  flux(k2+1) = 0.
9699  do k=k1+1,k2
9700  flux(k) = df*(dz(k) - dz(k-1))
9701  enddo
9702 
9703  do k=k1,k2
9704  dz(k) = dz(k) - flux(k) + flux(k+1)
9705  enddo
9706  enddo
9707 
9708  do k=km,1,-1
9709  ze(i,j,k) = ze(i,j,k+1) - dz(k)
9710  enddo
9711 
9712  end subroutine sm1_edge
9713 
9714 
9715 
9716 end module test_cases_mod
test_cases_mod::case9_b
real, dimension(:,:), allocatable case9_b
Definition: test_cases.F90:213
fv_grid_utils_mod::cart_to_latlon
subroutine, public cart_to_latlon(np, q, xs, ys)
Definition: fv_grid_utils.F90:1782
test_cases_mod::gh0
real gh0
Definition: test_cases.F90:210
fv_grid_utils_mod::mid_pt_sphere
subroutine, public mid_pt_sphere(p1, p2, pm)
Definition: fv_grid_utils.F90:2020
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:7781
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:9313
test_cases_mod::interp_left_edge_1d
subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
Definition: test_cases.F90:9374
test_cases_mod::dtoa
subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng, bd)
Definition: test_cases.F90:8809
fv_diagnostics_mod::qcly0
real, public qcly0
Definition: fv_diagnostics.F90:193
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:6176
test_cases_mod::ubar
real ubar
Definition: test_cases.F90:208
test_cases_mod::ctoa
subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng, bd)
Definition: test_cases.F90:9016
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:565
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:230
test_cases_mod::theta_d
integer theta_d
Definition: test_cases.F90:177
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:3850
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:123
test_cases_mod::radius
real(kind=r_grid), parameter radius
Definition: test_cases.F90:178
fv_eta_mod::hybrid_z_dz
subroutine, public hybrid_z_dz(km, dz, ztop, s_rate)
Definition: fv_eta.F90:1768
test_cases_mod::tvort_orig
real tvort_orig
enstrophy (integral of total vorticity)
Definition: test_cases.F90:227
fv_arrays_mod::fv_grid_bounds_type
Definition: fv_arrays.F90:1187
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:162
test_cases_mod::nsolitons
integer nsolitons
Definition: test_cases.F90:183
test_cases_mod::test_case
integer test_case
Definition: test_cases.F90:180
test_cases_mod::sm1_edge
subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
Definition: test_cases.F90:9680
test_cases_mod::wind_field
integer wind_field
Definition: test_cases.F90:205
test_cases_mod::p0_c0
real p0_c0
Definition: test_cases.F90:187
test_cases_mod::init_winds
subroutine init_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, npx, npy, ng, ndims, nregions, bounded_domain, gridstruct, domain, tile, bd)
Definition: test_cases.F90:255
test_cases_mod::lats_table
real, dimension(:), allocatable lats_table
Definition: test_cases.F90:222
test_cases_mod::pi_shift
real, parameter pi_shift
3.0*pi/4.
Definition: test_cases.F90:193
test_cases_mod::mp_update_dwinds
Definition: test_cases.F90:242
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:5172
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:2085
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, bd)
Definition: test_cases.F90:4262
test_cases_mod::superk_u
subroutine superk_u(km, zz, um, dudz)
Definition: test_cases.F90:7223
dcmip16_bc_uwind
real function dcmip16_bc_uwind(z, T, lat)
Definition: test_cases.F90:7728
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, adiabatic, make_nh)
the subroutine &#39;p_var&#39; computes auxiliary pressure variables for a hydrostatic state.
Definition: init_hydro.F90:86
test_cases_mod::normalize_vect
subroutine normalize_vect(np, e)
Definition: test_cases.F90:9288
dcmip16_tc_uwind_pert
subroutine dcmip16_tc_uwind_pert(z, r, lon, lat, uu, vv)
Definition: test_cases.F90:8089
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, bd)
Definition: test_cases.F90:7393
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:2968
test_cases_mod::var_dz
subroutine var_dz(km, ztop, ze)
Definition: test_cases.F90:9619
fv_grid_utils_mod::inner_prod
real function, public inner_prod(v1, v2)
Definition: fv_grid_utils.F90:1039
fv_grid_utils_mod::get_latlon_vector
subroutine, public get_latlon_vector(pp, elon, elat)
Definition: fv_grid_utils.F90:3341
fv_grid_utils_mod::get_unit_vect2
subroutine, public get_unit_vect2(e1, e2, uc)
Definition: fv_grid_utils.F90:1887
test_cases_mod::lon0
real lon0
pi-0.8
Definition: test_cases.F90:190
fv_grid_tools_mod::todeg
real(kind=r_grid), parameter, public todeg
convert to degrees
Definition: fv_grid_tools.F90:160
fv_arrays_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays.F90:34
fv_eta_mod::gw_1d
subroutine, public gw_1d(km, p0, ak, bk, ptop, ztop, pt1)
Definition: fv_eta.F90:2260
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:198
test_cases_mod::u_jet
real function u_jet(lat)
Definition: test_cases.F90:4161
test_cases_mod::terminator_tracers
subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, km, q, delp, ncnst, lon, lat, bd)
Definition: test_cases.F90:3953
test_cases_mod::supercell_sounding
subroutine supercell_sounding(km, ps, pk1, tp, qp)
Definition: test_cases.F90:7258
test_cases_mod::gh_jet
real function gh_jet(npy, lat_in)
Definition: test_cases.F90:4114
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, bounded_domain, npx_global, domain, grid_number, bd)
Definition: fv_surf_map.F90:134
test_cases_mod::tracer_test
integer tracer_test
Definition: test_cases.F90:205
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:3171
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:334
test_cases_mod::initwindscase6
integer, parameter initwindscase6
Definition: test_cases.F90:200
test_cases_mod::rankine_vortex
subroutine rankine_vortex(ubar, r0, p1, u, v, grid, bd)
Definition: test_cases.F90:4023
test_cases_mod::alpha
real, public alpha
Definition: test_cases.F90:182
test_cases_mod::lat0
real lat0
pi/4.8
Definition: test_cases.F90:189
test_cases_mod::atod
subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, bounded_domain, domain, bd)
Definition: test_cases.F90:8754
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:4905
fv_eta_mod::compute_dz_l32
subroutine, public compute_dz_l32(km, ztop, dz)
Definition: fv_eta.F90:1974
test_cases_mod::get_pt_on_great_circle
subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
Definition: test_cases.F90:5055
test_cases_mod::bubble_do
logical bubble_do
Definition: test_cases.F90:181
test_cases_mod::globalsum
real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile)
Definition: test_cases.F90:9170
dcmip16_tc_temperature
real function dcmip16_tc_temperature(z, r)
Definition: test_cases.F90:8058
fv_sg_mod::qsmith
subroutine, public qsmith(im, km, k1, t, p, q, qs, dqdt)
Definition: fv_sg.F90:1392
test_cases_mod::case9_forcing1
subroutine, public case9_forcing1(phis, time_since_start, isd, ied, jsd, jed)
Definition: test_cases.F90:4207
test_cases_mod::initwindscase9
integer, parameter initwindscase9
Definition: test_cases.F90:201
test_cases_mod::rgamma
real rgamma
Definition: test_cases.F90:188
test_cases_mod::vbar
real vbar
Definition: test_cases.F90:208
test_cases_mod::soliton_size
real soliton_size
Definition: test_cases.F90:184
test_cases_mod::tmass_orig
real tmass_orig
total mass
Definition: test_cases.F90:226
fv_grid_utils_mod::cubed_to_latlon
subroutine, public cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, mode, grid_type, domain, bounded_domain, c2l_ord, bd)
Definition: fv_grid_utils.F90:2412
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:2079
test_cases_mod::sphum
integer sphum
Definition: test_cases.F90:177
test_cases_mod::aoft
real, dimension(2) aoft
Definition: test_cases.F90:214
fv_surf_map_mod
Definition: fv_surf_map.F90:22
test_cases_mod::initwindscase0
integer, parameter initwindscase0
Definition: test_cases.F90:196
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:7761
test_cases_mod::read_namelist_test_case_nml
subroutine, public read_namelist_test_case_nml(nml_filename)
Definition: test_cases.F90:6902
test_cases_mod::pz0
real, dimension(:), allocatable, public pz0
Definition: test_cases.F90:203
test_cases_mod::get_case9_b
subroutine get_case9_b(B, agrid, isd, ied, jsd, jed)
Definition: test_cases.F90:4177
test_cases_mod::case9_forcing2
subroutine, public case9_forcing2(phis, isd, ied, jsd, jed)
Definition: test_cases.F90:4243
test_cases_mod::mp_update_dwinds_2d
subroutine mp_update_dwinds_2d(u, v, npx, npy, domain, bd)
Definition: test_cases.F90:9130
dcmip16_tc_sphum
real function dcmip16_tc_sphum(z)
Definition: test_cases.F90:8120
fv_grid_utils_mod::project_sphere_v
subroutine, public project_sphere_v(np, f, e)
Definition: fv_grid_utils.F90:3360
test_cases_mod::ua0
real, dimension(:,:,:), allocatable ua0
Validating U-Wind.
Definition: test_cases.F90:219
init_hydro_mod
Definition: init_hydro.F90:22
test_cases_mod::soliton_umax
real soliton_umax
Definition: test_cases.F90:184
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:248
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:7068
fv_grid_tools_mod::spherical_to_cartesian
subroutine, public spherical_to_cartesian(lon, lat, r, x, y, z)
Definition: fv_grid_tools.F90:1990
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:9268
test_cases_mod::mp_update_dwinds_3d
subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain, bd)
Definition: test_cases.F90:9149
fv_diagnostics_mod::prt_maxmin
subroutine, public prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac)
Definition: fv_diagnostics.F90:3786
test_cases_mod::rotate_winds
subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
Definition: test_cases.F90:9085
test_cases_mod::zz0
real, dimension(:), allocatable, public zz0
Definition: test_cases.F90:203
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:3884
dcmip16_bc_uwind_pert
real function dcmip16_bc_uwind_pert(z, lat, lon)
Definition: test_cases.F90:7744
test_cases_mod::prt_m1
subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
Definition: test_cases.F90:9589
fv_grid_tools_mod
Definition: fv_grid_tools.F90:21
test_cases_mod::va0
real, dimension(:,:,:), allocatable va0
Validating V-Windfms_io_exit, get_tile_string, &.
Definition: test_cases.F90:220
dcmip16_bc_temperature
real function dcmip16_bc_temperature(z, lat)
Definition: test_cases.F90:7695
test_cases_mod::phi0
real, dimension(:,:,:), allocatable phi0
Validating Field.
Definition: test_cases.F90:218
dcmip16_tc_pressure
real function dcmip16_tc_pressure(z, r)
Definition: test_cases.F90:8076
test_cases_mod::one
real(kind=r_grid), parameter one
Definition: test_cases.F90:179
test_cases_mod::gh_initialized
logical gh_initialized
Definition: test_cases.F90:223
dcmip16_bc_pressure
real function dcmip16_bc_pressure(z, lat)
Definition: test_cases.F90:7712
test_cases_mod::tener_orig
real tener_orig
energy
Definition: test_cases.F90:228
test_cases_mod::superk_sounding
subroutine superk_sounding(km, pe, p00, ze, pt, qz)
Definition: test_cases.F90:6936
test_cases_mod::vpol5
subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, ng_d, ng_s, jfirst, jlast)
Definition: test_cases.F90:9484
test_cases_mod::initwindscase1
integer, parameter initwindscase1
Definition: test_cases.F90:197
test_cases_mod::gh_table
real, dimension(:), allocatable gh_table
Definition: test_cases.F90:222
test_cases_mod::atoc
subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, bounded_domain, domain, bd, noComm)
Definition: test_cases.F90:8878
test_cases_mod::initwindscase5
integer, parameter initwindscase5
Definition: test_cases.F90:199
fv_eta_mod::compute_dz_l101
subroutine, public compute_dz_l101(km, ztop, dz)
Definition: fv_eta.F90:2043
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:1688