FV3 Bundle
test_cases_nlm.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU General Public License *
3 !* This file is a part of fvGFS. *
4 !* *
5 !* fvGFS is free software; you can redistribute it and/or modify it *
6 !* and are expected to follow the terms of the GNU General Public *
7 !* License as published by the Free Software Foundation; either *
8 !* version 2 of the License, or (at your option) any later version. *
9 !* *
10 !* fvGFS is distributed in the hope that it will be useful, but *
11 !* WITHOUT ANY WARRANTY; without even the implied warranty of *
12 !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
13 !* General Public License for more details. *
14 !* *
15 !* For the full text of the GNU General Public License, *
16 !* write to: Free Software Foundation, Inc., *
17 !* 675 Mass Ave, Cambridge, MA 02139, USA. *
18 !* or see: http://www.gnu.org/licenses/gpl.html *
19 !***********************************************************************
20 
21  module test_cases_nlm_mod
22 
23  use constants_mod, only: cnst_radius=>radius, pi=>pi_8, omega, grav, kappa, rdgas, cp_air, rvgas
24  use init_hydro_nlm_mod, only: p_var, hydro_eq
25  use fv_mp_nlm_mod, only: ng, is_master, &
26  is,js,ie,je, isd,jsd,ied,jed, &
27  domain_decomp, fill_corners, xdir, ydir, &
28  mp_stop, mp_reduce_sum, mp_reduce_max, mp_gather, mp_bcst
29  use fv_grid_utils_nlm_mod, only: cubed_to_latlon, great_circle_dist, mid_pt_sphere, &
30  ptop_min, inner_prod, get_latlon_vector, get_unit_vect2, &
31  g_sum, latlon2xyz, cart_to_latlon, make_eta_level, f_p, project_sphere_v
32  use fv_surf_map_nlm_mod, only: surfdrv
33 
34  use fv_grid_tools_nlm_mod, only: todeg, missing, spherical_to_cartesian
35  use fv_eta_nlm_mod, only: compute_dz_l32, compute_dz_l101, set_hybrid_z, gw_1d, &
36  hybrid_z_dz
37 
38  use mpp_mod, only: mpp_error, fatal, mpp_root_pe, mpp_broadcast, mpp_sum
39  use mpp_domains_mod, only: mpp_update_domains, domain2d
40  use mpp_parameter_mod, only: agrid_param=>agrid,cgrid_ne_param=>cgrid_ne, &
41  scalar_pair
42  use fv_sg_nlm_mod, only: qsmith
43  use fv_diagnostics_nlm_mod, only: prt_maxmin, ppme, eqv_pot, qcly0
44 !!! DEBUG CODE
45  use mpp_mod, only: mpp_pe, mpp_chksum, stdout
46 !!! END DEBUG CODE
47  use fv_arrays_nlm_mod, only: fv_grid_type, fv_flags_type, fv_grid_bounds_type, r_grid
48  use tracer_manager_mod, only: get_tracer_index
49  use field_manager_mod, only: model_atmos
50  implicit none
51  private
52 
53 ! Test Case Number
54 ! -1 = Divergence conservation test
55 ! 0 = Idealized non-linear deformational flow
56 ! 1 = Cosine Bell advection
57 ! 2 = Zonal geostrophically balanced flow
58 ! 3 = non-rotating potential flow
59 ! 4 = Tropical cyclones (merger of Rankine vortices)
60 ! 5 = Zonal geostrophically balanced flow over an isolated mountain
61 ! 6 = Rossby Wave number 4
62 ! 7 = Barotropic instability
63 ! ! 8 = Potential flow (as in 5 but no rotation and initially at rest)
64 ! 8 = "Soliton" propagation twin-vortex along equator
65 ! 9 = Polar vortex
66 ! 10 = hydrostatically balanced 3D test with idealized mountain
67 ! 11 = Use this for cold starting the climate model with USGS terrain
68 ! 12 = Jablonowski & Williamson Baroclinic test case (Steady State)
69 ! 13 = Jablonowski & Williamson Baroclinic test case Perturbation
70 ! -13 = DCMIP 2016 J&W BC Wave, with perturbation
71 ! 14 = Use this for cold starting the Aqua-planet model
72 ! 15 = Small Earth density current
73 ! 16 = 3D hydrostatic non-rotating Gravity waves
74 ! 17 = 3D hydrostatic rotating Inertial Gravity waves (case 6-3-0)
75 ! 18 = 3D mountain-induced Rossby wave
76 ! 19 = As in 15 but without rotation
77 ! 20 = 3D non-hydrostatic lee vortices; non-rotating (small planet)
78 ! 21 = 3D non-hydrostatic lee vortices; rotating (small planet)
79 ! 30 = Super-Cell storm, curved hodograph, centered at OKC, no rotation
80 ! 31 = Super-Cell storm, curved hodograph, centered at OKC, with rotation
81 ! 32 = Super-Cell storm, straight hodograph, centered at OKC, no rotation
82 ! 33 = HIWPP Schar mountain waves, Ridge mountain (M1)
83 ! 34 = HIWPP Schar mountain waves, Circular mountain (M2)
84 ! 35 = HIWPP Schar mountain waves, Circular mountain with shear (M3)
85 ! 36 = HIWPP Super_Cell; no perturbation
86 ! 37 = HIWPP Super_Cell; with the prescribed thermal
87 ! 44 = Lock-exchange on the sphere; atm at rest with no mountain
88 ! 45 = New test
89 ! 51 = 3D tracer advection (deformational nondivergent flow)
90 ! 55 = TC
91 ! 101 = 3D non-hydrostatic Large-Eddy-Simulation (LES) with hybrid_z IC
92 
93  integer :: sphum, theta_d
94  real(kind=R_GRID), parameter :: radius = cnst_radius
95  real(kind=R_GRID), parameter :: one = 1.d0
96  integer :: test_case
97  logical :: bubble_do
98  real :: alpha
99  integer :: nsolitons
100  real :: soliton_size = 750.e3, soliton_umax = 50.
101 
102 ! Case 0 parameters
103  real :: p0_c0 = 3.0
104  real :: rgamma = 5.0
105  real :: lat0 = pi/2.0 !pi/4.8
106  real :: lon0 = 0.0 !pi-0.8
107 
108 ! pi_shift moves the initial location of the cosine bell for Case 1
109  real, parameter :: pi_shift = 0.0 !3.0*pi/4.
110 
111  ! -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
112  integer, parameter :: initwindscase0 =-1
113  integer, parameter :: initwindscase1 = 1
114  integer, parameter :: initwindscase2 = 5
115  integer, parameter :: initwindscase5 = 5
116  integer, parameter :: initwindscase6 =-1
117  integer, parameter :: initwindscase9 =-1
118 
119  real, allocatable, dimension(:) :: pz0, zz0
120 
121  integer :: tracer_test, wind_field
122 
123  ! Ubar = initial wind speed parameter
124  real :: ubar, vbar
125  ! gh0 = initial surface height parameter
126  real :: gh0
127 
128  ! case 9 parameters
129  real , allocatable :: case9_b(:,:)
130  real :: aoft(2)
131 
132 
133  ! Validating fields used in statistics
134  real , allocatable :: phi0(:,:,:) ! Validating Field
135  real , allocatable :: ua0(:,:,:) ! Validating U-Wind
136  real , allocatable :: va0(:,:,:) ! Validating V-Windfms_io_exit, get_tile_string, &
137 
138  real , allocatable :: gh_table(:), lats_table(:)
139  logical :: gh_initialized = .false.
140 
141  ! Initial Conservation statistics ; total mass ; enstrophy ; energy
142  real :: tmass_orig
143  real :: tvort_orig
144  real :: tener_orig
145 
146  integer, parameter :: interporder = 1
147 
148  public :: pz0, zz0
149  public :: test_case, bubble_do, alpha, tracer_test, wind_field, nsolitons, soliton_umax, soliton_size
150  public :: init_case, get_stats, check_courant_numbers
151 #ifdef NCDF_OUTPUT
152  public :: output, output_ncdf
153 #endif
154  public :: case9_forcing1, case9_forcing2, case51_forcing
155  public :: init_double_periodic, init_latlon
156  public :: checker_tracers
157 
158  INTERFACE mp_update_dwinds
159  MODULE PROCEDURE mp_update_dwinds_2d
160  MODULE PROCEDURE mp_update_dwinds_3d
161  END INTERFACE
162 
163  contains
164 
165 !-------------------------------------------------------------------------------
166 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
167 !
168 ! init_winds :: initialize the winds
169 !
170  subroutine init_winds(UBar, u,v,ua,va,uc,vc, defOnGrid, npx, npy, ng, ndims, nregions, nested, gridstruct, domain, tile)
171  ! 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
172 
173  real , intent(INOUT) :: UBar
174  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1)
175  real , intent(INOUT) :: v(isd:ied+1,jsd:jed )
176  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed )
177  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
178  real , intent(INOUT) :: ua(isd:ied ,jsd:jed )
179  real , intent(INOUT) :: va(isd:ied ,jsd:jed )
180  integer, intent(IN) :: defOnGrid
181  integer, intent(IN) :: npx, npy
182  integer, intent(IN) :: ng
183  integer, intent(IN) :: ndims
184  integer, intent(IN) :: nregions
185  logical, intent(IN) :: nested
186  type(fv_grid_type), intent(IN), target :: gridstruct
187  type(domain2d), intent(INOUT) :: domain
188  integer, intent(IN) :: tile
189 
190  real(kind=R_GRID) :: p1(2), p2(2), p3(2), p4(2), pt(2)
191  real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3)
192 
193  real :: dist, r, r0
194  integer :: i,j,k,n
195  real :: utmp, vtmp
196 
197  real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
198  integer :: is2, ie2, js2, je2
199 
200  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
201  real, pointer, dimension(:,:) :: area, rarea, fC, f0
202  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
203  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
204  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
205 
206  logical, pointer :: cubed_sphere, latlon
207 
208  logical, pointer :: have_south_pole, have_north_pole
209 
210  integer, pointer :: ntiles_g
211  real, pointer :: acapN, acapS, globalarea
212 
213  grid => gridstruct%grid_64
214  agrid=> gridstruct%agrid_64
215 
216  area => gridstruct%area
217  rarea => gridstruct%rarea
218 
219  fc => gridstruct%fC
220  f0 => gridstruct%f0
221 
222  ee1 => gridstruct%ee1
223  ee2 => gridstruct%ee2
224  ew => gridstruct%ew
225  es => gridstruct%es
226  en1 => gridstruct%en1
227  en2 => gridstruct%en2
228 
229  dx => gridstruct%dx
230  dy => gridstruct%dy
231  dxa => gridstruct%dxa
232  dya => gridstruct%dya
233  rdxa => gridstruct%rdxa
234  rdya => gridstruct%rdya
235  dxc => gridstruct%dxc
236  dyc => gridstruct%dyc
237 
238  cubed_sphere => gridstruct%cubed_sphere
239  latlon => gridstruct%latlon
240 
241  have_south_pole => gridstruct%have_south_pole
242  have_north_pole => gridstruct%have_north_pole
243 
244  ntiles_g => gridstruct%ntiles_g
245  acapn => gridstruct%acapN
246  acaps => gridstruct%acapS
247  globalarea => gridstruct%globalarea
248 
249  if (nested) then
250 
251  is2 = is-2
252  ie2 = ie+2
253  js2 = js-2
254  je2 = je+2
255 
256  else
257 
258  is2 = is
259  ie2 = ie
260  js2 = js
261  je2 = je
262 
263  end if
264 
265  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)
266 
267  psi(:,:) = 1.e25
268  psi_b(:,:) = 1.e25
269  do j=jsd,jed
270  do i=isd,ied
271  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
272  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
273  enddo
274  enddo
275  call mpp_update_domains( psi, domain )
276  do j=jsd,jed+1
277  do i=isd,ied+1
278  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
279  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
280  enddo
281  enddo
282 
283  if ( (cubed_sphere) .and. (defongrid==0) ) then
284  do j=js,je+1
285  do i=is,ie
286  dist = dx(i,j)
287  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
288  if (dist==0) vc(i,j) = 0.
289  enddo
290  enddo
291  do j=js,je
292  do i=is,ie+1
293  dist = dy(i,j)
294  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
295  if (dist==0) uc(i,j) = 0.
296  enddo
297  enddo
298  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
299  call fill_corners(uc, vc, npx, npy, vector=.true., cgrid=.true.)
300  do j=js,je
301  do i=is,ie+1
302  dist = dxc(i,j)
303  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
304  if (dist==0) v(i,j) = 0.
305  enddo
306  enddo
307  do j=js,je+1
308  do i=is,ie
309  dist = dyc(i,j)
310  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
311  if (dist==0) u(i,j) = 0.
312  enddo
313  enddo
314  call mp_update_dwinds(u, v, npx, npy, domain)
315  do j=js,je
316  do i=is,ie
317  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
318  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
319  dist = dya(i,j)
320  ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
321  if (dist==0) ua(i,j) = 0.
322  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
323  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
324  dist = dxa(i,j)
325  va(i,j) = (psi2 - psi1) / (dist)
326  if (dist==0) va(i,j) = 0.
327  enddo
328  enddo
329 
330  elseif ( (cubed_sphere) .and. (defongrid==1) ) then
331  do j=js,je+1
332  do i=is,ie
333  dist = dx(i,j)
334  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
335  if (dist==0) vc(i,j) = 0.
336  enddo
337  enddo
338  do j=js,je
339  do i=is,ie+1
340  dist = dy(i,j)
341  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
342  if (dist==0) uc(i,j) = 0.
343  enddo
344  enddo
345  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
346  call fill_corners(uc, vc, npx, npy, vector=.true., cgrid=.true.)
347  call ctoa(uc,vc,ua,va,dx, dy, dxc,dyc,dxa,dya,npx,npy,ng)
348  call atod(ua,va,u ,v ,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
349  ! call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd),v(isd,jsd), &
350  ! ua(isd,jsd),va(isd,jsd), uc(isd,jsd),vc(isd,jsd))
351  elseif ( (cubed_sphere) .and. (defongrid==2) ) then
352  do j=js2,je2
353  do i=is2,ie2+1
354  dist = dxc(i,j)
355  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
356  if (dist==0) v(i,j) = 0.
357  enddo
358  enddo
359  do j=js2,je2+1
360  do i=is2,ie2
361  dist = dyc(i,j)
362  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
363  if (dist==0) u(i,j) = 0.
364  enddo
365  enddo
366  call mp_update_dwinds(u, v, npx, npy, domain)
367  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
368  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
369  elseif ( (cubed_sphere) .and. (defongrid==3) ) then
370  do j=js,je
371  do i=is,ie
372  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
373  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
374  dist = dya(i,j)
375  ua(i,j) = -1.0 * (psi2 - psi1) / (dist)
376  if (dist==0) ua(i,j) = 0.
377  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
378  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
379  dist = dxa(i,j)
380  va(i,j) = (psi2 - psi1) / (dist)
381  if (dist==0) va(i,j) = 0.
382  enddo
383  enddo
384  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
385  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
386  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested,domain)
387  elseif ( (latlon) .or. (defongrid==4) ) then
388 
389  do j=js,je
390  do i=is,ie
391  ua(i,j) = ubar * ( cos(agrid(i,j,2))*cos(alpha) + &
392  sin(agrid(i,j,2))*cos(agrid(i,j,1))*sin(alpha) )
393  va(i,j) = -ubar * sin(agrid(i,j,1))*sin(alpha)
394  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
395  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
396  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
397  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
398  if (cubed_sphere) call rotate_winds(ua(i,j), va(i,j), p1,p2,p3,p4, agrid(i,j,1:2), 2, 1)
399 
400  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
401  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
402  dist = dya(i,j)
403  if ( (tile==1) .and.(i==1) ) print*, ua(i,j), -1.0 * (psi2 - psi1) / (dist)
404 
405  enddo
406  enddo
407  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
408  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, nested, domain)
409  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
410  elseif ( (latlon) .or. (defongrid==5) ) then
411 ! SJL mods:
412 ! v-wind:
413  do j=js2,je2
414  do i=is2,ie2+1
415  p1(:) = grid(i ,j ,1:2)
416  p2(:) = grid(i,j+1 ,1:2)
417  call mid_pt_sphere(p1, p2, pt)
418  call get_unit_vect2 (p1, p2, e2)
419  call get_latlon_vector(pt, ex, ey)
420  utmp = ubar * ( cos(pt(2))*cos(alpha) + &
421  sin(pt(2))*cos(pt(1))*sin(alpha) )
422  vtmp = -ubar * sin(pt(1))*sin(alpha)
423  v(i,j) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
424  enddo
425  enddo
426 ! D grid u-wind:
427  do j=js2,je2+1
428  do i=is2,ie2
429  p1(:) = grid(i ,j ,1:2)
430  p2(:) = grid(i+1,j ,1:2)
431  call mid_pt_sphere(p1, p2, pt)
432  call get_unit_vect2 (p1, p2, e1)
433  call get_latlon_vector(pt, ex, ey)
434  utmp = ubar * ( cos(pt(2))*cos(alpha) + &
435  sin(pt(2))*cos(pt(1))*sin(alpha) )
436  vtmp = -ubar * sin(pt(1))*sin(alpha)
437  u(i,j) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
438  enddo
439  enddo
440 
441  call mp_update_dwinds(u, v, npx, npy, domain)
442  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
443  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, nested, domain)
444  else
445  !print*, 'Choose an appropriate grid to define the winds on'
446  !stop
447  endif
448 
449  end subroutine init_winds
450 !
451 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
452 !-------------------------------------------------------------------------------
453 
454 !-------------------------------------------------------------------------------
455 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
456 !
457 ! init_case :: initialize the Williamson test cases:
458 ! case 1 (2-D advection of a cosine bell)
459 ! case 2 (Steady State Zonal Geostrophic Flow)
460 ! case 5 (Steady State Zonal Geostrophic Flow over Mountain)
461 ! case 6 (Rossby Wave-4 Case)
462 ! case 9 (Stratospheric Vortex Breaking Case)
463 !
464  subroutine init_case(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
465  gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, &
466  dry_mass, mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, adiabatic, &
467  ks, npx_global, ptop, domain_in, tile_in, bd)
468 
469  type(fv_grid_bounds_type), intent(IN) :: bd
470  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
471  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
472  real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
473  real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
474  real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
475  real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
476 
477  real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
478 
479  real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
480  real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
481  real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
482  real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
483  real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
484 
485  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
486  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
487  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
488  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
489  real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:)
490  real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
491 
492  real , intent(inout) :: ak(npz+1)
493  real , intent(inout) :: bk(npz+1)
494 
495  integer, intent(IN) :: npx, npy, npz
496  integer, intent(IN) :: ng, ncnst, nwat
497  integer, intent(IN) :: ndims
498  integer, intent(IN) :: nregions
499 
500  real, intent(IN) :: dry_mass
501  logical, intent(IN) :: mountain
502  logical, intent(IN) :: moist_phys
503  logical, intent(IN) :: hydrostatic
504  logical, intent(IN) :: hybrid_z
505  logical, intent(IN) :: adiabatic
506  integer, intent(IN) :: ks
507 
508  type(fv_grid_type), target :: gridstruct
509  type(fv_flags_type), target, intent(IN) :: flagstruct
510 
511  integer, intent(IN) :: npx_global
512  integer, intent(IN), target :: tile_in
513  real, intent(INOUT) :: ptop
514 
515  type(domain2d), intent(IN), target :: domain_in
516 
517  real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
518  real :: tmp1(1 :npx ,1 :npy ,1:nregions)
519 
520  real(kind=R_GRID) :: p0(2) ! Temporary Point
521  real(kind=R_GRID) :: p1(2) ! Temporary Point
522  real(kind=R_GRID) :: p2(2) ! Temporary Point
523  real(kind=R_GRID) :: p3(2) ! Temporary Point
524  real(kind=R_GRID) :: p4(2) ! Temporary Point
525  real(kind=R_GRID) :: pa(2) ! Temporary Point
526  real(kind=R_GRID) :: pb(2) ! Temporary Point
527  real(kind=R_GRID) :: pcen(2) ! Temporary Point
528  real(kind=R_GRID) :: e1(3), e2(3), e3(3), ex(3), ey(3)
529  real :: dist, r, r1, r2, r0, omg, a, b, c
530  integer :: i,j,k,nreg,z,zz
531  integer :: i0,j0,n0, nt
532  real :: utmp,vtmp,ftmp
533  real :: rk
534 
535  integer, parameter :: jm = 5761
536  real :: ll_phi(jm)
537  real :: ll_u(jm)
538  real :: ll_j(jm)
539  real :: cose(jm)
540  real :: sine(jm)
541  real :: cosp(jm)
542  real :: ddeg, deg, ddp, dp, ph5
543  real :: myb, myc, yy
544  integer :: jj,jm1
545 
546  real :: vtx, p, w_p
547  real :: x1,y1,z1,x2,y2,z2,ang
548 
549  integer :: initwindscase
550 
551  real :: dummy
552  real :: ftop
553  real :: v1,v2
554  real :: m=1
555  real :: n=1
556  real :: l1_norm
557  real :: l2_norm
558  real :: linf_norm
559  real :: pmin, pmin1
560  real :: pmax, pmax1
561  real :: grad(bd%isd:bd%ied ,bd%jsd:bd%jed,2)
562  real :: div0(bd%isd:bd%ied ,bd%jsd:bd%jed )
563  real :: vor0(bd%isd:bd%ied ,bd%jsd:bd%jed )
564  real :: divg(bd%isd:bd%ied ,bd%jsd:bd%jed )
565  real :: vort(bd%isd:bd%ied ,bd%jsd:bd%jed )
566  real :: ztop, rgrav, p00, pturb, zmid, pk0, t00
567  real :: dz1(npz), ppt(npz)
568  real :: ze1(npz+1), pe1(npz+1)
569 
570  integer :: nlon,nlat
571  character(len=80) :: oflnm, hgtflnm
572  integer :: is2, ie2, js2, je2
573 
574  real :: psi(bd%isd:bd%ied,bd%jsd:bd%jed)
575  real :: psi_b(bd%isd:bd%ied+1,bd%jsd:bd%jed+1)
576  real :: psi1, psi2
577 
578 ! Baroclinic Test Case 12
579  real :: eta(npz), eta_0, eta_s, eta_t
580  real :: eta_v(npz), press, anti_rot
581  real :: t_0, t_mean, delta_t, lapse_rate, n2, zeta, s0
582  real :: pt1,pt2,pt3,pt4,pt5,pt6, pt7, pt8, pt9, u1, pt0
583  real :: uu1, uu2, uu3, vv1, vv2, vv3
584 ! real wbuffer(npx+1,npz)
585 ! real sbuffer(npy+1,npz)
586  real wbuffer(npy+2,npz)
587  real sbuffer(npx+2,npz)
588 
589  real :: gz(bd%isd:bd%ied,bd%jsd:bd%jed,npz+1), zt, zdist
590  real :: zvir
591 
592  integer :: cl, cl2
593 
594 ! Super-Cell
595  real :: us0 = 30.
596  real, dimension(npz):: pk1, ts1, qs1, uz1, zs1, dudz
597  real:: zm, zc
598  real(kind=R_GRID):: pp0(2) ! center position
599 
600 !Test case 35
601  real:: cs_m3
602 !Test case 51
603  real :: omega0, k_cell, z0, h, px
604  real :: d1, d2, p1p(2), rt, s
605  real :: wind_alpha, period, h0, rm, zp3(3), dz3(3), k0, lp
606 
607 
608 !Test case 55
609  real, dimension(npz+1) :: pe0, gz0, ue, ve, we, pte, qe
610  real :: d, cor, exppr, exppz, gamma, ts0, q00, exponent, ztrop, height, zp, rp
611  real :: qtrop, ttrop, zq1, zq2
612  real :: dum, dum1, dum2, dum3, dum4, dum5, dum6, ptmp, uetmp, vetmp
613  real :: pe_u(bd%is:bd%ie,npz+1,bd%js:bd%je+1)
614  real :: pe_v(bd%is:bd%ie+1,npz+1,bd%js:bd%je)
615  real :: ps_u(bd%is:bd%ie,bd%js:bd%je+1)
616  real :: ps_v(bd%is:bd%ie+1,bd%js:bd%je)
617 
618 
619  real :: dz, zetam
620 
621  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
622  real(kind=R_GRID), pointer, dimension(:,:) :: area
623  real, pointer, dimension(:,:) :: rarea, fc, f0
624  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
625  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
626  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
627 
628  logical, pointer :: cubed_sphere, latlon
629 
630  type(domain2d), pointer :: domain
631  integer, pointer :: tile
632 
633  logical, pointer :: have_south_pole, have_north_pole
634 
635  integer, pointer :: ntiles_g
636  real, pointer :: acapn, acaps, globalarea
637 
638  is = bd%is
639  ie = bd%ie
640  js = bd%js
641  je = bd%je
642  isd = bd%isd
643  ied = bd%ied
644  jsd = bd%jsd
645  jed = bd%jed
646 
647  grid => gridstruct%grid_64
648  agrid=> gridstruct%agrid_64
649 
650  area => gridstruct%area_64
651  rarea => gridstruct%rarea
652 
653  fc => gridstruct%fC
654  f0 => gridstruct%f0
655 
656  ee1 => gridstruct%ee1
657  ee2 => gridstruct%ee2
658  ew => gridstruct%ew
659  es => gridstruct%es
660  en1 => gridstruct%en1
661  en2 => gridstruct%en2
662 
663  dx => gridstruct%dx
664  dy => gridstruct%dy
665  dxa => gridstruct%dxa
666  dya => gridstruct%dya
667  rdxa => gridstruct%rdxa
668  rdya => gridstruct%rdya
669  dxc => gridstruct%dxc
670  dyc => gridstruct%dyc
671 
672  cubed_sphere => gridstruct%cubed_sphere
673  latlon => gridstruct%latlon
674 
675  domain => domain_in
676  tile => tile_in
677 
678  have_south_pole => gridstruct%have_south_pole
679  have_north_pole => gridstruct%have_north_pole
680 
681  ntiles_g => gridstruct%ntiles_g
682  acapn => gridstruct%acapN
683  acaps => gridstruct%acapS
684  globalarea => gridstruct%globalarea
685 
686  if (gridstruct%nested) then
687  is2 = isd
688  ie2 = ied
689  js2 = jsd
690  je2 = jed
691  else
692  is2 = is
693  ie2 = ie
694  js2 = js
695  je2 = je
696  end if
697 
698  pe(:,:,:) = 0.0
699  pt(:,:,:) = 1.0
700  f0(:,:) = huge(dummy)
701  fc(:,:) = huge(dummy)
702  do j=jsd,jed+1
703  do i=isd,ied+1
704  fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
705  sin(grid(i,j,2))*cos(alpha) )
706  enddo
707  enddo
708  do j=jsd,jed
709  do i=isd,ied
710  f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
711  sin(agrid(i,j,2))*cos(alpha) )
712  enddo
713  enddo
714  call mpp_update_domains( f0, domain )
715  if (cubed_sphere) call fill_corners(f0, npx, npy, ydir)
716 
717  delp(isd:is-1,jsd:js-1,1:npz)=0.
718  delp(isd:is-1,je+1:jed,1:npz)=0.
719  delp(ie+1:ied,jsd:js-1,1:npz)=0.
720  delp(ie+1:ied,je+1:jed,1:npz)=0.
721 
722 #if defined(SW_DYNAMICS)
723  select case (test_case)
724  case(-2)
725  case(-1)
726  ubar = (2.0*pi*radius)/(12.0*86400.0)
727  gh0 = 2.94e4
728  phis = 0.0
729  do j=js,je
730  do i=is,ie
731  delp(i,j,1) = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
732  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
733  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
734  enddo
735  enddo
736  call init_winds(ubar, u,v,ua,va,uc,vc, 1, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
737 
738 ! Test Divergence operator at cell centers
739  do j=js,je
740  do i=is,ie
741  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
742  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
743  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)
744  enddo
745  enddo
746 ! Test Vorticity operator at cell centers
747  do j=js,je
748  do i=is,ie
749  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
750  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
751  enddo
752  enddo
753  div0(:,:) = 1.e-20
754  ! call mpp_update_domains( div0, domain )
755  ! call mpp_update_domains( vor0, domain )
756  ! call mpp_update_domains( divg, domain )
757  ! call mpp_update_domains( vort, domain )
758  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
759  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
760  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)
761  201 format(' ',a,e21.14,' ',e21.14)
762  202 format(' ',a,i4.4,'x',i4.4,'x',i4.4)
763  if ( is_master() ) then
764  write(*,*) ' Error Norms of Analytical Divergence field C-Winds initialized'
765  write(*,201) 'Divergence MAX error : ', pmax
766  write(*,201) 'Divergence MIN error : ', pmin
767  write(*,201) 'Divergence L1_norm : ', l1_norm
768  write(*,201) 'Divergence L2_norm : ', l2_norm
769  write(*,201) 'Divergence Linf_norm : ', linf_norm
770  endif
771 
772  call init_winds(ubar, u,v,ua,va,uc,vc, 3, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
773 ! Test Divergence operator at cell centers
774  do j=js,je
775  do i=is,ie
776  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
777  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
778  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)
779  enddo
780  enddo
781 ! Test Vorticity operator at cell centers
782  do j=js,je
783  do i=is,ie
784  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
785  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
786  enddo
787  enddo
788  ua0 = ua
789  va0 = va
790  div0(:,:) = 1.e-20
791  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
792  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
793  if ( is_master() ) then
794  write(*,*) ' Error Norms of Analytical Divergence field A-Winds initialized'
795  write(*,201) 'Divergence MAX error : ', pmax
796  write(*,201) 'Divergence MIN error : ', pmin
797  write(*,201) 'Divergence L1_norm : ', l1_norm
798  write(*,201) 'Divergence L2_norm : ', l2_norm
799  write(*,201) 'Divergence Linf_norm : ', linf_norm
800  endif
801 
802  call init_winds(ubar, u,v,ua,va,uc,vc, 2, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
803  !call d2a2c(npx,npy,1, is,ie, js,je, ng, u(isd,jsd,1),v(isd,jsd,1), &
804  ! ua(isd,jsd,1),va(isd,jsd,1), uc(isd,jsd,1),vc(isd,jsd,1))
805 ! Test Divergence operator at cell centers
806  do j=js,je
807  do i=is,ie
808  divg(i,j) = (rarea(i,j)) * ( (uc(i+1,j,1)*dy(i+1,j) - uc(i,j,1)*dy(i,j)) + &
809  (vc(i,j+1,1)*dx(i,j+1) - vc(i,j,1)*dx(i,j)) )
810  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)
811  enddo
812  enddo
813 ! Test Vorticity operator at cell centers
814  do j=js,je
815  do i=is,ie
816  vort(i,j) = (rarea(i,j)) * ( (v(i+1,j,1)*dy(i+1,j) - v(i,j,1)*dy(i,j)) - &
817  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
818  enddo
819  enddo
820  div0(:,:) = 1.e-20
821  call get_scalar_stats( divg, div0, npx, npy, ndims, nregions, &
822  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
823  if ( is_master() ) then
824  write(*,*) ' Error Norms of Analytical Divergence field D-Winds initialized'
825  write(*,201) 'Divergence MAX error : ', pmax
826  write(*,201) 'Divergence MIN error : ', pmin
827  write(*,201) 'Divergence L1_norm : ', l1_norm
828  write(*,201) 'Divergence L2_norm : ', l2_norm
829  write(*,201) 'Divergence Linf_norm : ', linf_norm
830  endif
831 
832  call mp_stop()
833  stop
834  case(0)
835  do j=jsd,jed
836  do i=isd,ied
837 
838  x1 = agrid(i,j,1)
839  y1 = agrid(i,j,2)
840  z1 = radius
841 
842  p = p0_c0 * cos(y1)
843  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
844  w_p = 0.0
845  if (p /= 0.0) w_p = vtx/p
846  delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*0.0) )
847  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)))
848  va(i,j,1) = w_p*cos(lat0)*sin(agrid(i,j,1) - lon0)
849  ua(i,j,1) = ua(i,j,1)*radius/86400.0
850  va(i,j,1) = va(i,j,1)*radius/86400.0
851 
852  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
853  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
854  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
855  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
856  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)
857 
858  enddo
859  enddo
860  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
861  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain)
862  call mp_update_dwinds(u, v, npx, npy, npz, domain)
863  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
864  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
865  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
866  initwindscase=initwindscase0
867  case(1)
868  ubar = (2.0*pi*radius)/(12.0*86400.0)
869  gh0 = 1.0
870  phis = 0.0
871  r0 = radius/3. !RADIUS radius/3.
872  p1(1) = pi/2. + pi_shift
873  p1(2) = 0.
874  do j=jsd,jed
875  do i=isd,ied
876  p2(1) = agrid(i,j,1)
877  p2(2) = agrid(i,j,2)
878  r = great_circle_dist( p1, p2, radius )
879  if (r < r0) then
880  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
881  else
882  delp(i,j,1) = phis(i,j)
883  endif
884  enddo
885  enddo
886  initwindscase=initwindscase1
887  case(2)
888 #ifdef TEST_TRACER
889 !!$ do j=js2,je2
890 !!$ do i=is2,ie2
891 !!$ q(i,j,1,:) = 1.e-3*cos(agrid(i,j,2))!*(1.+cos(agrid(i,j,1)))
892 !!$ enddo
893 !!$ enddo
894  gh0 = 1.0e-6
895  r0 = radius/3. !RADIUS radius/3.
896  p1(2) = 35./180.*pi !0.
897  p1(1) = pi/4.!pi/2.
898  do j=jsd,jed
899  do i=isd,ied
900  p2(1) = agrid(i,j,1)
901  p2(2) = agrid(i,j,2)
902  r = great_circle_dist( p1, p2, radius )
903  if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.)) then
904  !q(i,j,k,1) = max(gh0*0.5*(1.0+cos(PI*r/r0))*exp(real(k-npz)),0.)
905  q(i,j,1,1) = gh0
906  else
907  q(i,j,1,1) = 0.
908  endif
909  enddo
910  enddo
911 #endif
912  ubar = (2.0*pi*radius)/(12.0*86400.0)
913  gh0 = 2.94e4
914  phis = 0.0
915  do j=js2,je2
916  do i=is2,ie2
917 ! do j=jsd,jed
918 ! do i=isd,ied
919 #ifdef FIVE_AVG
920  pt5 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
921  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
922  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
923  pt1 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
924  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
925  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0
926  pt2 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
927  ( -1.*cos(grid(i+1,j ,1))*cos(grid(i+1,j ,2))*sin(alpha) + &
928  sin(grid(i+1,j ,2))*cos(alpha) ) ** 2.0
929  pt3 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
930  ( -1.*cos(grid(i+1,j+1,1))*cos(grid(i+1,j+1,2))*sin(alpha) + &
931  sin(grid(i+1,j+1,2))*cos(alpha) ) ** 2.0
932  pt4 = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
933  ( -1.*cos(grid(i,j+1,1))*cos(grid(i,j+1,2))*sin(alpha) + &
934  sin(grid(i,j+1,2))*cos(alpha) ) ** 2.0
935  delp(i,j,1) = (0.25*(pt1+pt2+pt3+pt4) + 3.*pt5) / 4.
936 #else
937  delp(i,j,1) = gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
938  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
939  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2.0
940 #endif
941  enddo
942  enddo
943  initwindscase=initwindscase2
944  case(3)
945 !----------------------------
946 ! Non-rotating potential flow
947 !----------------------------
948 #ifdef NO_WIND
949  ubar = 0.
950 #else
951  ubar = 40.
952 #endif
953  gh0 = 1.0e3 * grav
954  phis = 0.0
955  r0 = radius/3. !RADIUS radius/3.
956  p1(1) = pi*1.5
957  p1(2) = 0.
958  do j=jsd,jed
959  do i=isd,ied
960  p2(1) = agrid(i,j,1)
961  p2(2) = agrid(i,j,2)
962  r = great_circle_dist( p1, p2, radius )
963  if (r < r0) then
964  delp(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
965  else
966  delp(i,j,1) = phis(i,j)
967  endif
968 ! Add a constant:
969  delp(i,j,1) = delp(i,j,1) + grav*2.e3
970  enddo
971  enddo
972 
973 #ifdef NO_WIND
974  u = 0.; v = 0.
975  f0 = 0.; fc = 0.
976 #else
977 
978  do j=js,je
979  do i=is,ie+1
980  p1(:) = grid(i ,j ,1:2)
981  p2(:) = grid(i,j+1 ,1:2)
982  call mid_pt_sphere(p1, p2, p3)
983  call get_unit_vect2(p1, p2, e2)
984  call get_latlon_vector(p3, ex, ey)
985  utmp = ubar * cos(p3(2))
986  vtmp = 0.
987  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
988  enddo
989  enddo
990  do j=js,je+1
991  do i=is,ie
992  p1(:) = grid(i, j,1:2)
993  p2(:) = grid(i+1,j,1:2)
994  call mid_pt_sphere(p1, p2, p3)
995  call get_unit_vect2(p1, p2, e1)
996  call get_latlon_vector(p3, ex, ey)
997  utmp = ubar * cos(p3(2))
998  vtmp = 0.
999  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1000  enddo
1001  enddo
1002 
1003  anti_rot = -ubar/ radius
1004  do j=jsd,jed+1
1005  do i=isd,ied+1
1006  fc(i,j) = 2.*anti_rot*sin(grid(i,j,2))
1007  enddo
1008  enddo
1009  do j=jsd,jed
1010  do i=isd,ied
1011  f0(i,j) = 2.*anti_rot*sin(agrid(i,j,2))
1012  enddo
1013  enddo
1014 #endif
1015  initwindscase= -1
1016 
1017  case(4)
1018 
1019 !----------------------------
1020 ! Tropical cyclones
1021 !----------------------------
1022 ! f0 = 0.; fC = 0. ! non-rotating planet setup
1023  u = 0.
1024  v = 0.
1025  phis = 0.0 ! flat terrain
1026 
1027  ubar = 50. ! maxmium wind speed (m/s)
1028  r0 = 250.e3 ! RADIUS of the maximum wind of the Rankine vortex
1029  gh0 = grav * 1.e3
1030 
1031  do j=jsd,jed
1032  do i=isd,ied
1033  delp(i,j,1) = gh0
1034  enddo
1035  enddo
1036 
1037 ! ddeg = 2.*r0/radius ! no merger
1038  ddeg = 1.80*r0/radius ! merged
1039 
1040  p1(1) = pi*1.5 - ddeg
1041  p1(2) = pi/18. ! 10 N
1042  call rankine_vortex(ubar, r0, p1, u, v, grid)
1043 
1044  p2(1) = pi*1.5 + ddeg
1045  p2(2) = pi/18. ! 10 N
1046  call rankine_vortex(ubar, r0, p2, u, v, grid)
1047 
1048 #ifndef SINGULAR_VORTEX
1049 !-----------
1050 ! Anti-pole:
1051 !-----------
1052  ubar = -ubar
1053  call latlon2xyz(p1, e1)
1054  do i=1,3
1055  e1(i) = -e1(i)
1056  enddo
1057  call cart_to_latlon(1, e1, p3(1), p3(2))
1058  call rankine_vortex(ubar, r0, p3, u, v, grid)
1059 
1060  call latlon2xyz(p2, e1)
1061  do i=1,3
1062  e1(i) = -e1(i)
1063  enddo
1064  call cart_to_latlon(1, e1, p4(1), p4(2))
1065  call rankine_vortex(ubar, r0, p4, u, v, grid)
1066 #endif
1067  call mp_update_dwinds(u, v, npx, npy, npz, domain)
1068  initwindscase=-1 ! do nothing
1069 
1070  case(5)
1071 
1072  ubar = 20.
1073  gh0 = 5960.*grav
1074  phis = 0.0
1075  r0 = pi/9.
1076  p1(1) = pi/2.
1077  p1(2) = pi/6.
1078  do j=js2,je2
1079  do i=is2,ie2
1080  p2(1) = agrid(i,j,1)
1081  p2(2) = agrid(i,j,2)
1082  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1083  r = sqrt(r)
1084  phis(i,j) = 2000.0*grav*(1.0-(r/r0))
1085  enddo
1086  enddo
1087  do j=js2,je2
1088  do i=is2,ie2
1089  delp(i,j,1) =gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
1090  ( -1.*cos(agrid(i ,j ,1))*cos(agrid(i ,j ,2))*sin(alpha) + &
1091  sin(agrid(i ,j ,2))*cos(alpha) ) ** 2 - phis(i,j)
1092  enddo
1093  enddo
1094  initwindscase=initwindscase5
1095  case(6)
1096  gh0 = 8.e3*grav
1097  r = 4.
1098  omg = 7.848e-6
1099  rk = 7.848e-6
1100  phis = 0.0
1101  do j=js,je
1102  do i=is,ie
1103  a = 0.5*omg*(2.*omega+omg)*(cos(agrid(i,j,2))**2) + &
1104  0.25*rk*rk*(cos(agrid(i,j,2))**(r+r)) * &
1105  ( (r+1)*(cos(agrid(i,j,2))**2) + (2.*r*r-r-2.) - &
1106  2.*(r*r)*cos(agrid(i,j,2))**(-2.) )
1107  b = (2.*(omega+omg)*rk / ((r+1)*(r+2))) * (cos(agrid(i,j,2))**r) * &
1108  ( (r*r+2.*r+2.) - ((r+1.)*cos(agrid(i,j,2)))**2 )
1109  c = 0.25*rk*rk*(cos(agrid(i,j,2))**(2.*r)) * ( &
1110  (r+1) * (cos(agrid(i,j,2))**2.) - (r+2.) )
1111  delp(i,j,1) =gh0 + radius*radius*(a+b*cos(r*agrid(i,j,1))+c*cos(2.*r*agrid(i,j,1)))
1112  delp(i,j,1) = delp(i,j,1) - phis(i,j)
1113  enddo
1114  enddo
1115  do j=js,je
1116  do i=is,ie+1
1117  p1(:) = grid(i ,j ,1:2)
1118  p2(:) = grid(i,j+1 ,1:2)
1119  call mid_pt_sphere(p1, p2, p3)
1120  call get_unit_vect2(p1, p2, e2)
1121  call get_latlon_vector(p3, ex, ey)
1122  utmp = radius*omg*cos(p3(2)) + &
1123  radius*rk*(cos(p3(2))**(r-1))*(r*sin(p3(2))**2-cos(p3(2))**2)*cos(r*p3(1))
1124  vtmp = -radius*rk*r*sin(p3(2))*sin(r*p3(1))*cos(p3(2))**(r-1)
1125  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
1126  enddo
1127  enddo
1128  do j=js,je+1
1129  do i=is,ie
1130  p1(:) = grid(i, j,1:2)
1131  p2(:) = grid(i+1,j,1:2)
1132  call mid_pt_sphere(p1, p2, p3)
1133  call get_unit_vect2(p1, p2, e1)
1134  call get_latlon_vector(p3, ex, ey)
1135  utmp = radius*omg*cos(p3(2)) + &
1136  radius*rk*(cos(p3(2))**(r-1))*(r*sin(p3(2))**2-cos(p3(2))**2)*cos(r*p3(1))
1137  vtmp = -radius*rk*r*sin(p3(2))*sin(r*p3(1))*cos(p3(2))**(r-1)
1138  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
1139  enddo
1140  enddo
1141  call mp_update_dwinds(u, v, npx, npy, npz, domain)
1142  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
1143  !call mpp_update_domains( ua, va, domain, gridtype=AGRID_PARAM)
1144  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
1145  initwindscase=initwindscase6
1146  case(7)
1147 ! Barotropically unstable jet
1148  gh0 = 10.e3*grav
1149  phis = 0.0
1150  r0 = radius/12.
1151  p2(1) = pi/2.
1152  p2(2) = pi/4.
1153  do j=js,je
1154  do i=is,ie
1155 ! ftmp = gh0
1156 ! 9-point average:
1157 ! 9 4 8
1158 !
1159 ! 5 1 3
1160 !
1161 ! 6 2 7
1162  pt1 = gh_jet(npy, agrid(i,j,2))
1163  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), pa)
1164  pt2 = gh_jet(npy, pa(2))
1165  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), pa)
1166  pt3 = gh_jet(npy, pa(2))
1167  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), pa)
1168  pt4 = gh_jet(npy, pa(2))
1169  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), pa)
1170  pt5 = gh_jet(npy, pa(2))
1171  pt6 = gh_jet(npy, grid(i, j, 2))
1172  pt7 = gh_jet(npy, grid(i+1,j, 2))
1173  pt8 = gh_jet(npy, grid(i+1,j+1,2))
1174  pt9 = gh_jet(npy, grid(i ,j+1,2))
1175  ftmp = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1176 #ifndef NEW_PERT
1177  delp(i,j,1) = ftmp + 120.*grav*cos(agrid(i,j,2)) * &
1178  exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1179 ! phis(i,j) = ftmp
1180 ! delp(i,j,1) = 10.E3*grav + 120.*grav*cos(agrid(i,j,2)) * &
1181 ! exp( -(3.*(agrid(i,j,1)-pi))**2 ) * exp( -(15.*(agrid(i,j,2)-pi/4.))**2 )
1182 #else
1183 ! Using great circle dist:
1184  p1(:) = agrid(i,j,1:2)
1185  delp(i,j,1) = ftmp
1186  r = great_circle_dist(p1, p2, radius)
1187  if ( r < 3.*r0 ) then
1188  delp(i,j,1) = delp(i,j,1) + 1000.*grav*exp(-(r/r0)**2)
1189  endif
1190 #endif
1191  enddo
1192  enddo
1193 
1194 ! v-wind:
1195  do j=js,je
1196  do i=is,ie+1
1197  p2(:) = grid(i,j+1,1:2)
1198  vv1 = u_jet(p2(2))*(ee2(2,i,j+1)*cos(p2(1)) - ee2(1,i,j+1)*sin(p2(1)))
1199  p1(:) = grid(i,j,1:2)
1200  vv3 = u_jet(p1(2))*(ee2(2,i,j)*cos(p1(1)) - ee2(1,i,j)*sin(p1(1)))
1201 ! Mid-point:
1202  call mid_pt_sphere(p1, p2, pa)
1203  vv2 = u_jet(pa(2))*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1204 ! 3-point average:
1205  v(i,j,1) = 0.25*(vv1 + 2.*vv2 + vv3)
1206 ! v(i,j,1) = vv2
1207  enddo
1208  enddo
1209 ! U-wind:
1210  do j=js,je+1
1211  do i=is,ie
1212  p1(:) = grid(i,j,1:2)
1213  uu1 = u_jet(p1(2))*(ee1(2,i,j)*cos(p1(1)) - ee1(1,i,j)*sin(p1(1)))
1214  p2(:) = grid(i+1,j,1:2)
1215  uu3 = u_jet(p2(2))*(ee1(2,i+1,j)*cos(p2(1)) - ee1(1,i+1,j)*sin(p2(1)))
1216 ! Mid-point:
1217  call mid_pt_sphere(p1, p2, pa)
1218  uu2 = u_jet(pa(2))*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1219 ! 3-point average:
1220  u(i,j,1) = 0.25*(uu1 + 2.*uu2 + uu3)
1221 ! u(i,j,1) = uu2
1222  enddo
1223  enddo
1224  initwindscase=initwindscase6 ! shouldn't do anything with this
1225 !initialize tracer with shallow-water PV
1226  !Compute vorticity
1227  call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,1), dx, dy, rarea)
1228  do j=jsd,jed+1
1229  do i=isd,ied+1
1230  fc(i,j) = 2.*omega*( -1.*cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) + &
1231  sin(grid(i,j,2))*cos(alpha) )
1232  enddo
1233  enddo
1234  do j=jsd,jed
1235  do i=isd,ied
1236  f0(i,j) = 2.*omega*( -1.*cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) + &
1237  sin(agrid(i,j,2))*cos(alpha) )
1238  enddo
1239  enddo
1240  call mpp_update_domains( f0, domain )
1241  if (cubed_sphere) call fill_corners(f0, npx, npy, ydir)
1242  do j=js,je
1243  do i=is,ie
1244  q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) / delp(i,j,npz) * 1.e6 ! PVU
1245  !q(i,j,npz,1) = ( q(i,j,npz,1) + f0(i,j) ) * grav / delp(i,j,npz)
1246  enddo
1247  enddo
1248 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
1249 
1250  case(8)
1251 #ifdef USE_OLD
1252 !----------------------------
1253 ! Non-rotating potential flow
1254 !----------------------------
1255  gh0 = 5960.*grav
1256  phis = 0.0
1257  r0 = pi/9.
1258  p1(1) = pi/2.
1259  p1(2) = pi/6.
1260  do j=js,je
1261  do i=is,ie
1262  p2(1) = agrid(i,j,1)
1263  p2(2) = agrid(i,j,2)
1264  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1265  r = sqrt(r)
1266  phis(i,j) = 2000.0*grav*(1.0-(r/r0))
1267  enddo
1268  enddo
1269  do j=js,je
1270  do i=is,ie
1271  delp(i,j,1) = gh0
1272  enddo
1273  enddo
1274  u = 0.; v = 0.
1275  f0 = 0.; fc = 0.
1276  initwindscase= -1
1277 #endif
1278 !----------------------------
1279 ! Soliton twin-vortex
1280 !----------------------------
1281  if ( is_master() ) write(*,*) 'Initialzing case-8: soliton twin cycolne...'
1282  f0 = 0.; fc = 0. ! non-rotating planet setup
1283  phis = 0.0 ! flat terrain
1284  gh0 = 5.e3*grav
1285  do j=js,je
1286  do i=is,ie
1287  delp(i,j,1) = gh0
1288  enddo
1289  enddo
1290 
1291 ! Initiate the westerly-wind-burst:
1292  ubar = soliton_umax
1293  r0 = soliton_size
1294 !!$ ubar = 200. ! maxmium wind speed (m/s)
1295 !!$ r0 = 250.e3
1296 !!$ ubar = 50. ! maxmium wind speed (m/s)
1297 !!$ r0 = 750.e3
1298 ! #1 1: westerly
1299  p0(1) = pi*0.5
1300  p0(2) = 0.
1301 
1302  do j=js,je
1303  do i=is,ie+1
1304  p1(:) = grid(i ,j ,1:2)
1305  p2(:) = grid(i,j+1 ,1:2)
1306  call mid_pt_sphere(p1, p2, p3)
1307  r = great_circle_dist( p0, p3, radius )
1308  utmp = ubar*exp(-(r/r0)**2)
1309  call get_unit_vect2(p1, p2, e2)
1310  call get_latlon_vector(p3, ex, ey)
1311  v(i,j,1) = utmp*inner_prod(e2,ex)
1312  enddo
1313  enddo
1314  do j=js,je+1
1315  do i=is,ie
1316  p1(:) = grid(i, j,1:2)
1317  p2(:) = grid(i+1,j,1:2)
1318  call mid_pt_sphere(p1, p2, p3)
1319  r = great_circle_dist( p0, p3, radius )
1320  utmp = ubar*exp(-(r/r0)**2)
1321  call get_unit_vect2(p1, p2, e1)
1322  call get_latlon_vector(p3, ex, ey)
1323  u(i,j,1) = utmp*inner_prod(e1,ex)
1324  enddo
1325  enddo
1326 
1327 ! #1 2: easterly
1328  p0(1) = p0(1) + pi
1329  p0(2) = 0.
1330 
1331  do j=js,je
1332  do i=is,ie+1
1333  p1(:) = grid(i ,j ,1:2)
1334  p2(:) = grid(i,j+1 ,1:2)
1335  call mid_pt_sphere(p1, p2, p3)
1336  r = great_circle_dist( p0, p3, radius )
1337  utmp = ubar*exp(-(r/r0)**2)
1338  call get_unit_vect2(p1, p2, e2)
1339  call get_latlon_vector(p3, ex, ey)
1340  v(i,j,1) = v(i,j,1) - utmp*inner_prod(e2,ex)
1341  enddo
1342  enddo
1343  do j=js,je+1
1344  do i=is,ie
1345  p1(:) = grid(i, j,1:2)
1346  p2(:) = grid(i+1,j,1:2)
1347  call mid_pt_sphere(p1, p2, p3)
1348  r = great_circle_dist( p0, p3, radius )
1349  utmp = ubar*exp(-(r/r0)**2)
1350  call get_unit_vect2(p1, p2, e1)
1351  call get_latlon_vector(p3, ex, ey)
1352  u(i,j,1) = u(i,j,1) - utmp*inner_prod(e1,ex)
1353  enddo
1354  enddo
1355  initwindscase= -1
1356 
1357  case(9)
1358 #ifdef USE_OLD
1359  jm1 = jm - 1
1360  ddp = pi/dble(jm1)
1361  dp = ddp
1362  ll_j(1) = -0.5*pi
1363  do j=2,jm
1364  ph5 = -0.5*pi + (dble(j-1)-0.5)*ddp
1365  ll_j(j) = -0.5*pi + (dble(j-1)*ddp)
1366  sine(j) = sin(ph5)
1367  enddo
1368  cosp( 1) = 0.
1369  cosp(jm) = 0.
1370  do j=2,jm1
1371  cosp(j) = (sine(j+1)-sine(j)) / dp
1372  enddo
1373  do j=2,jm
1374  cose(j) = 0.5 * (cosp(j-1) + cosp(j))
1375  enddo
1376  cose(1) = cose(2)
1377  ddeg = 180./float(jm-1)
1378  do j=2,jm
1379  deg = -90. + (float(j-1)-0.5)*ddeg
1380  if (deg <= 0.) then
1381  ll_u(j) = -10.*(deg+90.)/90.
1382  elseif (deg <= 60.) then
1383  ll_u(j) = -10. + deg
1384  else
1385  ll_u(j) = 50. - (50./30.)* (deg - 60.)
1386  endif
1387  enddo
1388  ll_phi(1) = 6000. * grav
1389  do j=2,jm1
1390  ll_phi(j)=ll_phi(j-1) - dp*sine(j) * &
1391  (radius*2.*omega + ll_u(j)/cose(j))*ll_u(j)
1392  enddo
1393  phis = 0.0
1394  do j=js,je
1395  do i=is,ie
1396  do jj=1,jm1
1397  if ( (ll_j(jj) <= agrid(i,j,2)) .and. (agrid(i,j,2) <= ll_j(jj+1)) ) then
1398  delp(i,j,1)=0.5*(ll_phi(jj)+ll_phi(jj+1))
1399  endif
1400  enddo
1401  enddo
1402  enddo
1403 
1404  do j=js,je
1405  do i=is,ie
1406  if (agrid(i,j,2)*todeg <= 0.0) then
1407  ua(i,j,1) = -10.*(agrid(i,j,2)*todeg + 90.)/90.
1408  elseif (agrid(i,j,2)*todeg <= 60.0) then
1409  ua(i,j,1) = -10. + agrid(i,j,2)*todeg
1410  else
1411  ua(i,j,1) = 50. - (50./30.)* (agrid(i,j,2)*todeg - 60.)
1412  endif
1413  va(i,j,1) = 0.0
1414  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1415  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
1416  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
1417  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
1418  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)
1419  enddo
1420  enddo
1421 
1422  call mpp_update_domains( ua, va, domain, gridtype=agrid_param)
1423  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
1424  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
1425  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
1426  call atod(ua,va, u, v,dxa, dya,dxc,dyc,npx,npy,ng, gridstruct%nested, domain)
1427  call mp_update_dwinds(u, v, npx, npy, npz, domain)
1428  initwindscase=initwindscase9
1429 
1430 
1431  call get_case9_b(case9_b, agrid)
1432  aoft(:) = 0.0
1433 #else
1434 !----------------------------
1435 ! Soliton twin-vortex
1436 !----------------------------
1437  if ( is_master() ) write(*,*) 'Initialzing case-9: soliton cyclones...'
1438  f0 = 0.; fc = 0. ! non-rotating planet setup
1439  phis = 0.0 ! flat terrain
1440  gh0 = 5.e3*grav
1441  do j=js,je
1442  do i=is,ie
1443  delp(i,j,1) = gh0
1444  enddo
1445  enddo
1446 
1447 ! Initiate the westerly-wind-burst:
1448  ubar = soliton_umax
1449  r0 = soliton_size
1450 !!$ ubar = 200. ! maxmium wind speed (m/s)
1451 !!$ r0 = 250.e3
1452 !!$ ubar = 50. ! maxmium wind speed (m/s)
1453 !!$ r0 = 750.e3
1454  p0(1) = pi*0.5
1455  p0(2) = 0.
1456 
1457  do j=js,je
1458  do i=is,ie+1
1459  p1(:) = grid(i ,j ,1:2)
1460  p2(:) = grid(i,j+1 ,1:2)
1461  call mid_pt_sphere(p1, p2, p3)
1462  r = great_circle_dist( p0, p3, radius )
1463  utmp = ubar*exp(-(r/r0)**2)
1464  call get_unit_vect2(p1, p2, e2)
1465  call get_latlon_vector(p3, ex, ey)
1466  v(i,j,1) = utmp*inner_prod(e2,ex)
1467  enddo
1468  enddo
1469  do j=js,je+1
1470  do i=is,ie
1471  p1(:) = grid(i, j,1:2)
1472  p2(:) = grid(i+1,j,1:2)
1473  call mid_pt_sphere(p1, p2, p3)
1474  r = great_circle_dist( p0, p3, radius )
1475  utmp = ubar*exp(-(r/r0)**2)
1476  call get_unit_vect2(p1, p2, e1)
1477  call get_latlon_vector(p3, ex, ey)
1478  u(i,j,1) = utmp*inner_prod(e1,ex)
1479  enddo
1480  enddo
1481  initwindscase= -1
1482 #endif
1483  end select
1484 !--------------- end s-w cases --------------------------
1485 
1486 ! Copy 3D data for Shallow Water Tests
1487  do z=2,npz
1488  delp(:,:,z) = delp(:,:,1)
1489  enddo
1490 
1491  call mpp_update_domains( delp, domain )
1492  call mpp_update_domains( phis, domain )
1493  phi0 = delp
1494 
1495  call init_winds(ubar, u,v,ua,va,uc,vc, initwindscase, npx, npy, ng, ndims, nregions, gridstruct%nested, gridstruct, domain, tile)
1496 ! Copy 3D data for Shallow Water Tests
1497  do z=2,npz
1498  u(:,:,z) = u(:,:,1)
1499  v(:,:,z) = v(:,:,1)
1500  enddo
1501 
1502  do j=js,je
1503  do i=is,ie
1504  ps(i,j) = delp(i,j,1)
1505  enddo
1506  enddo
1507 ! -------- end s-w section ----------------------------------
1508 #else
1509 
1510  if (test_case==10 .or. test_case==14) then
1511 
1512  alpha = 0.
1513 
1514  ! Initialize dry atmosphere
1515  q(:,:,:,:) = 3.e-6
1516  u(:,:,:) = 0.0
1517  v(:,:,:) = 0.0
1518  if (.not.hydrostatic) w(:,:,:)= 0.0
1519 
1520  if ( test_case==14 ) then
1521 ! Aqua-planet case: mean SLP=1.E5
1522  phis = 0.0
1523  call hydro_eq(npz, is, ie, js, je, ps, phis, 1.e5, &
1524  delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
1525  else
1526 ! Initialize topography
1527  gh0 = 5960.*grav
1528  phis = 0.0
1529  r0 = pi/9.
1530  p1(1) = pi/4.
1531  p1(2) = pi/6. + (7.5/180.0)*pi
1532  do j=js2,je2
1533  do i=is2,ie2
1534  p2(1) = agrid(i,j,1)
1535  p2(2) = agrid(i,j,2)
1536  r = min(r0*r0, (p2(1)-p1(1))*(p2(1)-p1(1)) + (p2(2)-p1(2))*(p2(2)-p1(2)) )
1537  r = sqrt(r)
1538  phis(i,j) = gh0*(1.0-(r/r0))
1539  enddo
1540  enddo
1541  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1542  delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1543  endif
1544 
1545  else if (test_case==11) then
1546  call surfdrv(npx, npy, gridstruct%grid_64, gridstruct%agrid_64, &
1547  gridstruct%area_64, dx, dy, dxa, dya, dxc, dyc, &
1548  gridstruct%sin_sg, phis, &
1549  flagstruct%stretch_fac, gridstruct%nested, &
1550  npx_global, domain, flagstruct%grid_number, bd)
1551  call mpp_update_domains( phis, domain )
1552 
1553  if ( hybrid_z ) then
1554  rgrav = 1./ grav
1555  if( npz==32 ) then
1556  call compute_dz_l32( npz, ztop, dz1 )
1557  else
1558 ! call mpp_error(FATAL, 'You must provide a routine for hybrid_z')
1559  if ( is_master() ) write(*,*) 'Using const DZ'
1560  ztop = 45.e3 ! assuming ptop = 100.
1561  dz1(1) = ztop / real(npz)
1562  dz1(npz) = 0.5*dz1(1)
1563  do z=2,npz-1
1564  dz1(z) = dz1(1)
1565  enddo
1566  dz1(1) = 2.*dz1(2)
1567  endif
1568 
1569  call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
1570  phis, ze0, delz)
1571 ! call prt_maxmin('ZE0', ze0, is, ie, js, je, 0, npz, 1.E-3)
1572 ! call prt_maxmin('DZ0', delz, is, ie, js, je, 0, npz, 1. )
1573  endif
1574 
1575 ! Initialize dry atmosphere
1576  u = 0.
1577  v = 0.
1578  q(:,:,:,:) = 0.
1579  q(:,:,:,1) = 3.e-6
1580 
1581  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
1582  delp, ak, bk, pt, delz, area, ng, mountain, hydrostatic, hybrid_z, domain)
1583 
1584  else if ( (test_case==12) .or. (test_case==13) ) then
1585 
1586 #ifdef HIWPP_TRACER
1587  if (is_master()) print*, 'TEST TRACER enabled for this test case'
1588 #ifdef HIWPP
1589  call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
1590  ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
1591 #else
1592  !For consistency with earlier single-grid simulations use gh0 = 1.0e-6 and p1(1) = 195.*pi/180.
1593  q(:,:,:,:) = 0.
1594  gh0 = 1.0e-3
1595  r0 = radius/3. !RADIUS radius/3.
1596  p1(2) = 51.*pi/180.
1597  p1(1) = 205.*pi/180. !231.*pi/180.
1598  do k=1,npz
1599  do j=jsd,jed
1600  do i=isd,ied
1601  p2(1) = agrid(i,j,1)
1602  p2(2) = agrid(i,j,2)
1603  r = great_circle_dist( p1, p2, radius )
1604  if (r < r0 .and. .not.( abs(p1(2)-p2(2)) < 1./18. .and. p2(1)-p1(1) < 5./36.) .and. k > 16) then
1605  q(i,j,k,1) = gh0
1606  else
1607  q(i,j,k,1) = 0.
1608  endif
1609  enddo
1610  enddo
1611  enddo
1612 #endif
1613 
1614 #else
1615 
1616  q(:,:,:,:) = 0.
1617 
1618 #ifdef HIWPP
1619 
1620  cl = get_tracer_index(model_atmos, 'cl')
1621  cl2 = get_tracer_index(model_atmos, 'cl2')
1622  if (cl > 0 .and. cl2 > 0) then
1623  call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
1624  q, delp,ncnst,agrid(isd:ied,jsd:jed,1),agrid(isd:ied,jsd:jed,2))
1625  call mpp_update_domains(q,domain)
1626  endif
1627 
1628 #endif
1629 #endif
1630  ! Initialize surface Pressure
1631  ps(:,:) = 1.e5
1632  ! Initialize detla-P
1633 !$OMP parallel do default(none) shared(is,ie,js,je,npz,delp,ak,ps,bk)
1634  do z=1,npz
1635  do j=js,je
1636  do i=is,ie
1637  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
1638  enddo
1639  enddo
1640  enddo
1641 
1642 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,ptop,peln,pk,delp)
1643  do j=js,je
1644  do i=is, ie
1645  pe(i,1,j) = ptop
1646  peln(i,1,j) = log(ptop)
1647  pk(i,j,1) = ptop**kappa
1648  enddo
1649 ! Top down
1650  do k=2,npz+1
1651  do i=is,ie
1652  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
1653  pk(i,j,k) = exp( kappa*log(pe(i,k,j)) )
1654  peln(i,k,j) = log(pe(i,k,j))
1655  enddo
1656  enddo
1657  enddo
1658 
1659 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pkz,pk,peln)
1660  do k=1,npz
1661  do j=js,je
1662  do i=is,ie
1663  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
1664  enddo
1665  enddo
1666  enddo
1667 
1668  ! Setup ETA auxil variable
1669  eta_0 = 0.252
1670  do k=1,npz
1671  eta(k) = 0.5*( (ak(k)+ak(k+1))/1.e5 + bk(k)+bk(k+1) )
1672  eta_v(k) = (eta(k) - eta_0)*pi*0.5
1673  enddo
1674 
1675  if ( .not. adiabatic ) then
1676  !Set up moisture
1677  sphum = get_tracer_index(model_atmos, 'sphum')
1678  pcen(1) = pi/9.
1679  pcen(2) = 2.0*pi/9.
1680 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pe,q,agrid,pcen,delp,peln) &
1681 !$OMP private(ptmp)
1682  do k=1,npz
1683  do j=js,je
1684  do i=is,ie
1685  !r = great_circle_dist(pcen, agrid(i,j,:), radius)
1686  !ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j)) - 100000.
1687  !q(i,j,k,1) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1688  ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j)) - 100000.
1689  q(i,j,k,sphum) = 0.021*exp(-(agrid(i,j,2)/pcen(2))**4.)*exp(-(ptmp/34000.)**2.)
1690 ! SJL:
1691 ! q(i,j,k,sphum) = max(1.e-25, q(i,j,k,sphum))
1692  enddo
1693  enddo
1694  enddo
1695  endif
1696 
1697  ! Initialize winds
1698  ubar = 35.0
1699  r0 = 1.0
1700  pcen(1) = pi/9.
1701  pcen(2) = 2.0*pi/9.
1702  if (test_case == 13) then
1703 #ifdef ALT_PERT
1704  u1 = 0.0
1705  pt0 = 3.0
1706 #else
1707  u1 = 1.0
1708  pt0 = 0.0
1709 #endif
1710  r0 = radius/10.0
1711  endif
1712 
1713 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta_v,grid,Ubar,pcen,r0,ee2,v,ee1,es,u,u1,ew) &
1714 !$OMP private(utmp,r,vv1,vv3,p1,p2,vv2,uu1,uu2,uu3,pa)
1715  do z=1,npz
1716  do j=js,je
1717  do i=is,ie+1
1718  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j+1,2))**2.0
1719  ! Perturbation if Case==13
1720  r = great_circle_dist( pcen, grid(i,j+1,1:2), radius )
1721  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1722  vv1 = utmp*(ee2(2,i,j+1)*cos(grid(i,j+1,1)) - ee2(1,i,j+1)*sin(grid(i,j+1,1)))
1723 
1724  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j,2))**2.0
1725  ! Perturbation if Case==13
1726  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1727  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1728  vv3 = utmp*(ee2(2,i,j)*cos(grid(i,j,1)) - ee2(1,i,j)*sin(grid(i,j,1)))
1729 ! Mid-point:
1730  p1(:) = grid(i ,j ,1:2)
1731  p2(:) = grid(i,j+1 ,1:2)
1732  call mid_pt_sphere(p1, p2, pa)
1733  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*pa(2))**2.0
1734  ! Perturbation if Case==13
1735  r = great_circle_dist( pcen, pa, radius )
1736  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1737  vv2 = utmp*(ew(2,i,j,2)*cos(pa(1)) - ew(1,i,j,2)*sin(pa(1)))
1738 ! 3-point average:
1739  v(i,j,z) = 0.25*(vv1 + 2.*vv2 + vv3)
1740  enddo
1741  enddo
1742  do j=js,je+1
1743  do i=is,ie
1744  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i,j,2))**2.0
1745  ! Perturbation if Case==13
1746  r = great_circle_dist( pcen, grid(i,j,1:2), radius )
1747  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1748  uu1 = utmp*(ee1(2,i,j)*cos(grid(i,j,1)) - ee1(1,i,j)*sin(grid(i,j,1)))
1749 
1750  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*grid(i+1,j,2))**2.0
1751  ! Perturbation if Case==13
1752  r = great_circle_dist( pcen, grid(i+1,j,1:2), radius )
1753  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1754  uu3 = utmp*(ee1(2,i+1,j)*cos(grid(i+1,j,1)) - ee1(1,i+1,j)*sin(grid(i+1,j,1)))
1755 ! Mid-point:
1756  p1(:) = grid(i ,j ,1:2)
1757  p2(:) = grid(i+1,j ,1:2)
1758  call mid_pt_sphere(p1, p2, pa)
1759  utmp = ubar * cos(eta_v(z))**(3.0/2.0) * sin(2.0*pa(2))**2.0
1760  ! Perturbation if Case==13
1761  r = great_circle_dist( pcen, pa, radius )
1762  if (-(r/r0)**2.0 > -40.0) utmp = utmp + u1*exp(-(r/r0)**2.0)
1763  uu2 = utmp*(es(2,i,j,1)*cos(pa(1)) - es(1,i,j,1)*sin(pa(1)))
1764 ! 3-point average:
1765  u(i,j,z) = 0.25*(uu1 + 2.*uu2 + uu3)
1766  enddo
1767  enddo
1768  enddo ! z-loop
1769 
1770  ! Temperature
1771  eta_s = 1.0 ! Surface Level
1772  eta_t = 0.2 ! Tropopause
1773  t_0 = 288.0
1774  delta_t = 480000.0
1775  lapse_rate = 0.005
1776 !$OMP parallel do default(none) shared(is,ie,js,je,npz,eta,ak,bk,T_0,lapse_rate,eta_t, &
1777 !$OMP delta_T,ptop,delp,Ubar,eta_v,agrid,grid,pcen,pt,r0) &
1778 !$OMP private(T_mean,press,pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1,r)
1779  do z=1,npz
1780  eta(z) = 0.5*( (ak(z)+ak(z+1))/1.e5 + bk(z)+bk(z+1) )
1781  ! if (is_master()) print*, z, eta
1782  t_mean = t_0 * eta(z)**(rdgas*lapse_rate/grav)
1783  if (eta_t > eta(z)) t_mean = t_mean + delta_t*(eta_t - eta(z))**5.0
1784 
1785  230 format(i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
1786  press = ptop
1787  do zz=1,z
1788  press = press + delp(is,js,zz)
1789  enddo
1790  if (is_master()) write(*,230) z, eta(z), press/100., t_mean
1791  do j=js,je
1792  do i=is,ie
1793 ! A-grid cell center: i,j
1794  pt1 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1795  ( -2.0*(sin(agrid(i,j,2))**6.0) *(cos(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1796  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1797  ( (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 )
1798 #ifndef NO_AVG13
1799 ! 9-point average: should be 2nd order accurate for a rectangular cell
1800 !
1801 ! 9 4 8
1802 !
1803 ! 5 1 3
1804 !
1805 ! 6 2 7
1806 !
1807  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1808  pt2 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1809  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1810  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1811  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1812  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1813  pt3 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1814  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1815  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1816  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1817  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1818  pt4 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1819  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1820  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1821  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1822  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1823  pt5 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1824  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1825  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1826  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1827 
1828  pt6 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1829  ( -2.0*(sin(grid(i,j,2))**6.0) *(cos(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1830  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1831  ( (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 )
1832  pt7 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1833  ( -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 ) * &
1834  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1835  ( (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 )
1836  pt8 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1837  ( -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 ) * &
1838  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1839  ( (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 )
1840  pt9 = t_mean + 0.75*(eta(z)*pi*ubar/rdgas)*sin(eta_v(z))*sqrt(cos(eta_v(z))) * ( &
1841  ( -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 ) * &
1842  2.0*ubar*cos(eta_v(z))**(3.0/2.0) + &
1843  ( (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 )
1844  pt(i,j,z) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1845 #else
1846  pt(i,j,z) = pt1
1847 #endif
1848 
1849 #ifdef ALT_PERT
1850  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
1851  if ( (r/r0)**2 < 40. ) then
1852  pt(i,j,z) = pt(i,j,z) + pt0*exp(-(r/r0)**2)
1853  endif
1854 #endif
1855 
1856  enddo
1857  enddo
1858  enddo
1859  if (is_master()) print*,' '
1860  ! Surface Geopotential
1861  phis(:,:)=1.e25
1862 !$OMP parallel do default(none) shared(is2,ie2,js2,je2,Ubar,eta_s,eta_0,agrid,grid,phis) &
1863 !$OMP private(pt1,pt2,pt3,pt4,pt5,pt6,pt7,pt8,pt9,p1)
1864  do j=js2,je2
1865  do i=is2,ie2
1866  pt1 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1867  ( -2.0*(sin(agrid(i,j,2))**6.0) *(cos(agrid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1868  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1869  ( (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 )
1870 #ifndef NO_AVG13
1871 ! 9-point average:
1872 !
1873 ! 9 4 8
1874 !
1875 ! 5 1 3
1876 !
1877 ! 6 2 7
1878 !
1879  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p1)
1880  pt2 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1881  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1882  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1883  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1884  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p1)
1885  pt3 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1886  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1887  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1888  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1889  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p1)
1890  pt4 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1891  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1892  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1893  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1894  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
1895  pt5 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1896  ( -2.0*(sin(p1(2))**6.0) *(cos(p1(2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1897  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1898  ( (8.0/5.0)*(cos(p1(2))**3.0)*(sin(p1(2))**2.0 + 2.0/3.0) - pi/4.0 )*radius*omega )
1899 
1900  pt6 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1901  ( -2.0*(sin(grid(i,j,2))**6.0) *(cos(grid(i,j,2))**2.0 + 1.0/3.0) + 10.0/63.0 ) * &
1902  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1903  ( (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 )
1904  pt7 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1905  ( -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 ) * &
1906  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1907  ( (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 )
1908  pt8 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1909  ( -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 ) * &
1910  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1911  ( (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 )
1912  pt9 = ubar* (cos( (eta_s-eta_0)*pi/2.0 ))**(3.0/2.0) * ( &
1913  ( -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 ) * &
1914  ubar*cos( (eta_s-eta_0)*pi/2.0 )**(3.0/2.0) + &
1915  ( (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 )
1916  phis(i,j) = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
1917 #else
1918  phis(i,j) = pt1
1919 #endif
1920  enddo
1921  enddo
1922 
1923  if ( .not.hydrostatic ) then
1924 !$OMP parallel do default(none) shared(is,ie,js,je,npz,pt,delz,peln,w)
1925  do k=1,npz
1926  do j=js,je
1927  do i=is,ie
1928  w(i,j,k) = 0.
1929  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
1930  enddo
1931  enddo
1932  enddo
1933  endif
1934  !Assume pt is virtual temperature at this point; then convert to regular temperature
1935  if (.not. adiabatic) then
1936  zvir = rvgas/rdgas - 1.
1937 !$OMP parallel do default(none) shared(sphum,is,ie,js,je,npz,pt,zvir,q)
1938  do k=1,npz
1939  do j=js,je
1940  do i=is,ie
1941  pt(i,j,k) = pt(i,j,k)/(1. + zvir*q(i,j,k,sphum))
1942  enddo
1943  enddo
1944  enddo
1945  endif
1946 
1947  !Set up tracer #2 to be the initial EPV
1948 ! call get_vorticity(is, ie, js, je, isd, ied, jsd, jed, npz, u, v, q(is:ie,js:je,:,2))
1949 ! call pv_entropy(is, ie, js, je, ng, npz, q(is:ie,js:je,:,2), f0, pt, pkz, delp, grav)
1950 
1951  write(stdout(), *) 'PI:', pi
1952  write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
1953 
1954  else if ( (test_case==-12) .or. (test_case==-13) ) then
1955 
1956  call dcmip16_bc(delp,pt,u,v,q,w,delz, &
1957  is,ie,js,je,isd,ied,jsd,jed,npz,ncnst,ak,bk,ptop, &
1958  pk,peln,pe,pkz,gz,phis,ps,grid,agrid,hydrostatic, &
1959  nwat, adiabatic, test_case == -13, domain)
1960 
1961  write(stdout(), *) 'PHIS:', mpp_chksum(phis(is:ie,js:je))
1962 
1963  else if ( test_case==15 .or. test_case==19 ) then
1964 !------------------------------------
1965 ! Non-hydrostatic 3D density current:
1966 !------------------------------------
1967 ! C100_L64; hybrid_z = .T., make_nh = .F. , make_hybrid_z = .false.
1968 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
1969 
1970  if ( test_case == 19 ) then
1971  f0(:,:) = 0.
1972  fc(:,:) = 0.
1973  endif
1974 
1975  phis = 0.
1976  u = 0.
1977  v = 0.
1978  w = 0.
1979  t00 = 300.
1980  p00 = 1.e5
1981  pk0 = p00**kappa
1982 ! Set up vertical coordinare with constant del-z spacing:
1983  ztop = 6.4e3
1984  ze1( 1) = ztop
1985  ze1(npz+1) = 0.
1986  do k=npz,2,-1
1987  ze1(k) = ze1(k+1) + ztop/real(npz)
1988  enddo
1989 
1990 ! Provide some room for the top layer
1991  ze1(1) = ztop + 1.5*ztop/real(npz)
1992 
1993  do j=js,je
1994  do i=is,ie
1995  ps(i,j) = p00
1996  pe(i,npz+1,j) = p00
1997  pk(i,j,npz+1) = pk0
1998  enddo
1999  enddo
2000 
2001  do k=npz,1,-1
2002  do j=js,je
2003  do i=is,ie
2004  delz(i,j,k) = ze1(k+1) - ze1(k)
2005  pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
2006  pe(i,k,j) = pk(i,j,k)**(1./kappa)
2007  enddo
2008  enddo
2009  enddo
2010 
2011  ptop = pe(is,1,js)
2012  if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
2013 
2014  do k=1,npz+1
2015  do j=js,je
2016  do i=is,ie
2017  peln(i,k,j) = log(pe(i,k,j))
2018  ze0(i,j,k) = ze1(k)
2019  enddo
2020  enddo
2021  enddo
2022 
2023  do k=1,npz
2024  do j=js,je
2025  do i=is,ie
2026  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2027  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2028  pt(i,j,k) = t00/pk0 ! potential temp
2029  enddo
2030  enddo
2031  enddo
2032 
2033 ! Perturbation: center at 3 km from the ground
2034  pturb = 15.
2035  p1(1) = pi
2036  p1(2) = 0.
2037 
2038  do k=1,npz
2039 #ifndef STD_BUBBLE
2040  r0 = 0.5*(ze1(k)+ze1(k+1)) - 3.2e3
2041 #else
2042  r0 = (0.5*(ze1(k)+ze1(k+1)) - 3.0e3) / 2.e3
2043 #endif
2044  do j=js,je
2045  do i=is,ie
2046 ! Impose perturbation in potential temperature: pturb
2047  p2(1) = agrid(i,j,1)
2048  p2(2) = agrid(i,j,2)
2049 #ifndef STD_BUBBLE
2050  r = great_circle_dist( p1, p2, radius )
2051  dist = sqrt( r**2 + r0**2 ) / 3.2e3
2052 #else
2053  r = great_circle_dist( p1, p2, radius ) / 4.e3
2054  dist = sqrt( r**2 + r0**2 )
2055 #endif
2056  if ( dist<=1. ) then
2057  q(i,j,k,1) = pk0 * pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2058  pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
2059  else
2060  q(i,j,k,1) = 0.
2061  endif
2062 ! Transform back to temperature:
2063  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
2064  enddo
2065  enddo
2066  enddo
2067 
2068  else if ( test_case==16 ) then
2069 
2070 ! Non-rotating:
2071  f0(:,:) = 0.
2072  fc(:,:) = 0.
2073 ! Initialize dry atmosphere
2074  phis = 0.
2075  u = 0.
2076  v = 0.
2077  p00 = 1000.e2
2078 ! Set up vertical coordinare with constant del-z spacing:
2079  ztop = 10.e3
2080  call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2081 
2082  do z=1,npz+1
2083  pe1(z) = ak(z) + bk(z)*p00
2084  enddo
2085 
2086  ze1(npz+1) = 0.
2087  do z=npz,2,-1
2088  ze1(z) = ze1(z+1) + ztop/real(npz)
2089  enddo
2090  ze1(1) = ztop
2091 
2092  if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2093 
2094  do j=jsd,jed
2095  do i=isd,ied
2096  ps(i,j) = pe1(npz+1)
2097  enddo
2098  enddo
2099 
2100  do z=1,npz+1
2101  do j=js,je
2102  do i=is,ie
2103  pe(i,z,j) = pe1(z)
2104  peln(i,z,j) = log(pe1(z))
2105  pk(i,j,z) = exp(kappa*peln(i,z,j))
2106  enddo
2107  enddo
2108  enddo
2109 
2110 ! Horizontal shape function
2111  p1(1) = pi
2112  p1(2) = 0.
2113  r0 = radius / 3.
2114  do j=js,je
2115  do i=is,ie
2116  r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2117  if ( r<r0 ) then
2118  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2119  else
2120  vort(i,j) = 0
2121  endif
2122  enddo
2123  enddo
2124 
2125  q = 0.
2126  pk0 = p00**kappa
2127  pturb = 10./pk0
2128  do z=1,npz
2129  zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2130  do j=js,je
2131  do i=is,ie
2132  pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2133  delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2134 ! Impose perturbation in potential temperature: pturb
2135  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2136  q(i,j,z,1) = q(i,j,z,1) + vort(i,j)*zmid
2137  enddo
2138  enddo
2139  enddo
2140 
2141  elseif ( test_case==17 ) then
2142 ! Initialize dry atmosphere
2143  phis = 0.
2144  u = 0.
2145  v = 0.
2146  p00 = 1000.e2
2147 ! Set up vertical coordinare with constant del-z spacing:
2148  ztop = 10.e3
2149  call gw_1d(npz, p00, ak, bk, ptop, ztop, ppt)
2150 
2151  do z=1,npz+1
2152  pe1(z) = ak(z) + bk(z)*p00
2153  enddo
2154 
2155  ze1(npz+1) = 0.
2156  do z=npz,2,-1
2157  ze1(z) = ze1(z+1) + ztop/real(npz)
2158  enddo
2159  ze1(1) = ztop
2160 
2161  if ( is_master() ) write(*,*) 'Model top (pa)=', ptop
2162 
2163  do j=jsd,jed
2164  do i=isd,ied
2165  ps(i,j) = pe1(npz+1)
2166  enddo
2167  enddo
2168 
2169  do z=1,npz+1
2170  do j=js,je
2171  do i=is,ie
2172  pe(i,z,j) = pe1(z)
2173  peln(i,z,j) = log(pe1(z))
2174  pk(i,j,z) = exp(kappa*peln(i,z,j))
2175  enddo
2176  enddo
2177  enddo
2178 
2179 ! Horizontal shape function
2180  p1(1) = pi
2181  p1(2) = pi/4.
2182  r0 = radius / 3.
2183  do j=js,je
2184  do i=is,ie
2185  r = great_circle_dist( p1, agrid(i,j,1:2), radius )
2186  if ( r<r0 ) then
2187  vort(i,j) = 0.5*(1.+cos(pi*r/r0))
2188  else
2189  vort(i,j) = 0
2190  endif
2191  enddo
2192  enddo
2193 
2194  pk0 = p00**kappa
2195  pturb = 10./pk0
2196  do z=1,npz
2197  zmid = sin( 0.5*(ze1(z)+ze1(z+1))*pi/ztop )
2198  do j=js,je
2199  do i=is,ie
2200  pkz(i,j,z) = (pk(i,j,z+1)-pk(i,j,z))/(kappa*(peln(i,z+1,j)-peln(i,z,j)))
2201  delp(i,j,z) = pe(i,z+1,j)-pe(i,z,j)
2202 ! Impose perturbation in potential temperature: pturb
2203  pt(i,j,z) = ( ppt(z) + pturb*vort(i,j)*zmid ) * pkz(i,j,z)
2204  enddo
2205  enddo
2206  enddo
2207 
2208  elseif ( test_case==18 ) then
2209  ubar = 20.
2210  pt0 = 288.
2211  n2 = grav**2 / (cp_air*pt0)
2212 
2213  pcen(1) = pi/2.
2214  pcen(2) = pi/6.
2215 
2216  ! Initialize surface Pressure
2217  do j=js2,je2
2218  do i=is2,ie2
2219  r = great_circle_dist( pcen, agrid(i,j,1:2), radius )
2220  phis(i,j) = grav*2.e3*exp( -(r/1500.e3)**2 )
2221  ps(i,j) = 930.e2 * exp( -radius*n2*ubar/(2.*grav*grav*kappa)*(ubar/radius+2.*omega)* &
2222  (sin(agrid(i,j,2))**2-1.) - n2/(grav*grav*kappa)*phis(i,j))
2223  enddo
2224  enddo
2225 
2226  do z=1,npz
2227  do j=js,je
2228  do i=is,ie
2229  pt(i,j,z) = pt0
2230  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
2231  enddo
2232  enddo
2233 ! v-wind:
2234  do j=js,je
2235  do i=is,ie+1
2236  p1(:) = grid(i ,j ,1:2)
2237  p2(:) = grid(i,j+1 ,1:2)
2238  call mid_pt_sphere(p1, p2, p3)
2239  call get_unit_vect2(p1, p2, e2)
2240  call get_latlon_vector(p3, ex, ey)
2241  utmp = ubar * cos(p3(2))
2242  vtmp = 0.
2243  v(i,j,z) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2244  enddo
2245  enddo
2246 
2247 ! u-wind
2248  do j=js,je+1
2249  do i=is,ie
2250  p1(:) = grid(i, j,1:2)
2251  p2(:) = grid(i+1,j,1:2)
2252  call mid_pt_sphere(p1, p2, p3)
2253  call get_unit_vect2(p1, p2, e1)
2254  call get_latlon_vector(p3, ex, ey)
2255  utmp = ubar * cos(p3(2))
2256  vtmp = 0.
2257  u(i,j,z) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2258  enddo
2259  enddo
2260  enddo
2261 
2262  else if ( test_case==20 .or. test_case==21 ) then
2263 !------------------------------------
2264 ! Non-hydrostatic 3D lee vortices
2265 !------------------------------------
2266  f0(:,:) = 0.
2267  fc(:,:) = 0.
2268 
2269  if ( test_case == 20 ) then
2270  ubar = 4. ! u = Ubar * cos(lat)
2271  ftop = 2.0e3 * grav
2272  else
2273  ubar = 8. ! u = Ubar * cos(lat)
2274  ftop = 4.0e3 * grav
2275  endif
2276 
2277  w = 0.
2278 
2279  do j=js,je
2280  do i=is,ie+1
2281  p1(:) = grid(i ,j ,1:2)
2282  p2(:) = grid(i,j+1 ,1:2)
2283  call mid_pt_sphere(p1, p2, p3)
2284  call get_unit_vect2(p1, p2, e2)
2285  call get_latlon_vector(p3, ex, ey)
2286  utmp = ubar * cos(p3(2))
2287  vtmp = 0.
2288  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
2289  enddo
2290  enddo
2291  do j=js,je+1
2292  do i=is,ie
2293  p1(:) = grid(i, j,1:2)
2294  p2(:) = grid(i+1,j,1:2)
2295  call mid_pt_sphere(p1, p2, p3)
2296  call get_unit_vect2(p1, p2, e1)
2297  call get_latlon_vector(p3, ex, ey)
2298  utmp = ubar * cos(p3(2))
2299  vtmp = 0.
2300  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
2301  enddo
2302  enddo
2303 
2304 ! copy vertically; no wind shear
2305  do k=2,npz
2306  do j=js,je+1
2307  do i=is,ie
2308  u(i,j,k) = u(i,j,1)
2309  enddo
2310  enddo
2311  do j=js,je
2312  do i=is,ie+1
2313  v(i,j,k) = v(i,j,1)
2314  enddo
2315  enddo
2316  enddo
2317 
2318 ! Center of the mountain:
2319  p1(1) = (0.5-0.125) * pi
2320  p1(2) = 0.
2321  call latlon2xyz(p1, e1)
2322  uu1 = 5.0e3
2323  uu2 = 10.0e3
2324  do j=js2,je2
2325  do i=is2,ie2
2326  p2(:) = agrid(i,j,1:2)
2327  r = great_circle_dist( p1, p2, radius )
2328  if ( r < pi*radius ) then
2329  p4(:) = p2(:) - p1(:)
2330  if ( abs(p4(1)) > 1.e-12 ) then
2331  zeta = asin( p4(2) / sqrt(p4(1)**2 + p4(2)**2) )
2332  else
2333  zeta = pi/2.
2334  endif
2335  if ( p4(1) <= 0. ) zeta = pi - zeta
2336  zeta = zeta + pi/6.
2337  v1 = r/uu1 * cos( zeta )
2338  v2 = r/uu2 * sin( zeta )
2339  phis(i,j) = ftop / ( 1. + v1**2 + v2**2 )
2340  else
2341  phis(i,j) = 0.
2342  endif
2343  enddo
2344  enddo
2345 
2346  if ( hybrid_z ) then
2347  rgrav = 1./ grav
2348  if( npz==32 ) then
2349  call compute_dz_l32( npz, ztop, dz1 )
2350  elseif( npz.eq.31 .or. npz.eq.41 .or. npz.eq.51 ) then
2351  ztop = 16.e3
2352  call hybrid_z_dz(npz, dz1, ztop, 1.0)
2353  else
2354  if ( is_master() ) write(*,*) 'Using const DZ'
2355  ztop = 15.e3
2356  dz1(1) = ztop / real(npz)
2357  do k=2,npz
2358  dz1(k) = dz1(1)
2359  enddo
2360 ! Make top layer thicker
2361  dz1(1) = max( 1.0e3, 3.*dz1(2) ) ! min 1 km
2362  endif
2363 
2364 ! Re-compute ztop
2365  ze1(npz+1) = 0.
2366  do k=npz,1,-1
2367  ze1(k) = ze1(k+1) + dz1(k)
2368  enddo
2369  ztop = ze1(1)
2370 
2371  call set_hybrid_z( is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
2372  phis, ze0, delz )
2373  else
2374  call mpp_error(fatal, 'This test case is only currently setup for hybrid_z')
2375  endif
2376 
2377  do k=1,npz
2378  do j=js,je
2379  do i=is,ie
2380  delz(i,j,k) = ze0(i,j,k+1) - ze0(i,j,k)
2381  enddo
2382  enddo
2383  enddo
2384 
2385  p00 = 1.e5 ! mean SLP
2386  pk0 = p00**kappa
2387  t00 = 300.
2388  pt0 = t00/pk0
2389  n2 = 1.e-4
2390  s0 = grav*grav / (cp_air*n2)
2391 
2392 ! For constant N2, Given z --> p
2393  do k=1,npz+1
2394  pe1(k) = p00*( (1.-s0/t00) + s0/t00*exp(-n2*ze1(k)/grav) )**(1./kappa)
2395  enddo
2396 
2397  ptop = pe1(1)
2398  if ( is_master() ) write(*,*) 'Lee vortex testcase: model top (mb)=', ptop/100.
2399 
2400 ! Set up fake "sigma" coordinate
2401  ak(1) = pe1(1)
2402  bk(1) = 0.
2403  do k=2,npz
2404  bk(k) = (pe1(k) - pe1(1)) / (pe1(npz+1)-pe1(1)) ! bk == sigma
2405  ak(k) = pe1(1)*(1.-bk(k))
2406  enddo
2407  ak(npz+1) = 0.
2408  bk(npz+1) = 1.
2409 
2410 ! Assuming constant N
2411  do k=2,npz+1
2412  do j=js,je
2413  do i=is,ie
2414  pk(i,j,k) = pk0 - (1.-exp(-n2/grav*ze0(i,j,k))) * (grav*grav)/(n2*cp_air*pt0)
2415  pe(i,k,j) = pk(i,j,k) ** (1./kappa)
2416  peln(i,k,j) = log(pe(i,k,j))
2417  enddo
2418  enddo
2419  enddo
2420 
2421  do j=js,je
2422  do i=is,ie
2423  pe(i,1,j) = ptop
2424  peln(i,1,j) = log(pe(i,1,j))
2425  pk(i,j,1) = pe(i,1,j) ** kappa
2426  ps(i,j) = pe(i,npz+1,j)
2427  enddo
2428  enddo
2429 
2430  do k=1,npz
2431  do j=js,je
2432  do i=is,ie
2433  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2434  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
2435  pt(i,j,k) = pkz(i,j,k)*grav*delz(i,j,k) / ( cp_air*(pk(i,j,k)-pk(i,j,k+1)) )
2436  enddo
2437  enddo
2438  enddo
2439 
2440  else if (test_case == 51) then
2441 
2442  alpha = 0.
2443  t00 = 300.
2444 
2445 
2446  if (.not.hydrostatic) w(:,:,:)= 0.0
2447 
2448 
2449  select case (tracer_test)
2450  case (1) !DCMIP 11
2451 
2452  !Need to set up pressure arrays
2453 !!$ p00 = 1.e5
2454 !!$ ps = p00
2455 !!$ phis = 0.
2456 
2457  !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
2458 
2459  dz = 12000./real(npz)
2460 
2461  allocate(zz0(npz+1))
2462  allocate(pz0(npz+1))
2463 
2464  zz0(1) = 12000.
2465  do k=2,npz
2466  zz0(k) = zz0(k-1) - dz
2467  enddo
2468  zz0(npz+1) = 0.
2469 
2470  if (is_master()) print*, 'TRACER ADVECTION TEST CASE'
2471  if (is_master()) print*, 'INITIAL LEVELS'
2472  !This gets interface pressure from input z-levels
2473  do k=1,npz+1
2474  !call test1_advection_deformation(agrid(is,js,1), agrid(is,js,2), pz0(k), zz0(k), 1, &
2475  ! ua(is,js,1), va(is,js,1), dum1, pt(is,js,1), phis(is,js), &
2476  ! 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))
2477  if (is_master()) write(*,*) k, pz0(k), zz0(k)
2478  enddo
2479 
2480  !Pressure
2481  do j=js,je
2482  do k=1,npz+1
2483  do i=is,ie
2484  pe(i,k,j) = pz0(k)
2485  enddo
2486  enddo
2487  enddo
2488 
2489  do k=1,npz
2490  ptmp = 0.5*(pz0(k) + pz0(k+1))
2491  do j=js,je
2492  do i=is,ie
2493  !This gets level-mean values from input pressures
2494  !call test1_advection_deformation(agrid(i,j,1),agrid(i,j,2),ptmp,dum,0, &
2495  ! ua(i,j,k), va(i,j,k), dum4, pt(i,j,k), phis(i,j), &
2496  ! 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))
2497  delp(i,j,k) = pz0(k+1)-pz0(k)
2498  enddo
2499  enddo
2500  enddo
2501 
2502  ptop = 100000.*exp(-12000.*grav/t00/rdgas)
2503 
2504 
2505  psi(:,:) = 1.e25
2506  psi_b(:,:) = 1.e25
2507  do j=jsd,jed
2508  do i=isd,ied
2509  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
2510  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
2511  enddo
2512  enddo
2513  call mpp_update_domains( psi, domain )
2514  do j=jsd,jed+1
2515  do i=isd,ied+1
2516  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
2517  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
2518  enddo
2519  enddo
2520 
2521  k = 1
2522  do j=js,je+1
2523  do i=is,ie
2524  dist = dx(i,j)
2525  vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
2526  if (dist==0) vc(i,j,k) = 0.
2527  enddo
2528  enddo
2529  do j=js,je
2530  do i=is,ie+1
2531  dist = dy(i,j)
2532  uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
2533  if (dist==0) uc(i,j,k) = 0.
2534  enddo
2535  enddo
2536 
2537  do j=js,je
2538  do i=is,ie+1
2539  dist = dxc(i,j)
2540  v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
2541  if (dist==0) v(i,j,k) = 0.
2542  enddo
2543  enddo
2544  do j=js,je+1
2545  do i=is,ie
2546  dist = dyc(i,j)
2547  u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
2548  if (dist==0) u(i,j,k) = 0.
2549  enddo
2550  enddo
2551 
2552  do j=js,je
2553  do i=is,ie
2554  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
2555  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
2556  dist = dya(i,j)
2557  ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
2558  if (dist==0) ua(i,j,k) = 0.
2559  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
2560  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
2561  dist = dxa(i,j)
2562  va(i,j,k) = (psi2 - psi1) / (dist)
2563  if (dist==0) va(i,j,k) = 0.
2564  enddo
2565  enddo
2566 
2567  do k=2,npz
2568  u(:,:,k) = u(:,:,1)
2569  v(:,:,k) = v(:,:,1)
2570  uc(:,:,k) = uc(:,:,1)
2571  vc(:,:,k) = vc(:,:,1)
2572  ua(:,:,k) = ua(:,:,1)
2573  va(:,:,k) = va(:,:,1)
2574  enddo
2575 
2576  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
2577  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
2578  call mp_update_dwinds(u, v, npx, npy, npz, domain)
2579 
2580  case (2) !DCMIP 12
2581 
2582  case (3) !DCMIP 13
2583 
2584  case default
2585  call mpp_error(fatal, 'Value of tracer_test not implemented ')
2586  end select
2587 
2588  else if (test_case == 52) then
2589 
2590  !Orography and steady-state test: DCMIP 20
2591 
2592 
2593  f0 = 0.
2594  fc = 0.
2595 
2596  u = 0.
2597  v = 0.
2598 
2599  p00 = 1.e5
2600 
2601  wind_field = tracer_test
2602 
2603  if (.not.hydrostatic) w(:,:,:)= 0.0
2604 
2605  !Set up ak and bk
2606 
2607  dz = 12000./real(npz)
2608  t00 = 300.
2609  p00 = 1.e5
2610  h = rdgas*t00/grav
2611  gamma = 0.0065
2612  exponent = rdgas*gamma/grav
2613  px = ((t00-9000.*gamma)/t00)**(1./exponent) !p00 not multiplied in
2614 
2615 
2616  do k=1,npz+1
2617  height = 12000. - dz*real(k-1)
2618  if (height >= 9000. ) then
2619  ak(k) = p00*((t00-height*gamma)/t00)**(1./exponent)
2620  bk(k) = 0.
2621  else
2622  ak(k) = (((t00-height*gamma)/t00)**(1./exponent)-1.)/(px - 1.)*px*p00
2623  bk(k) = (((t00-height*gamma)/t00)**(1./exponent)-px)/(1.-px)
2624  endif
2625  if (is_master()) write(*,*) k, ak(k), bk(k), height, ak(k)+bk(k)*p00
2626  enddo
2627 
2628  ptop = ak(1)
2629 
2630  !Need to set up uniformly-spaced levels
2631  p1(1) = 3.*pi/2. ; p1(2) = 0.
2632  r0 = 0.75*pi
2633  zetam = pi/16.
2634 
2635  !Topography
2636  do j=js,je
2637  do i=is,ie
2638  p2(:) = agrid(i,j,1:2)
2639  r = great_circle_dist( p1, p2, one )
2640  if (r < r0) then
2641  phis(i,j) = grav*0.5*2000.*(1. + cos(pi*r/r0))*cos(pi*r/zetam)**2.
2642  pe(i,npz+1,j) = p00*(1.-gamma/t00*phis(i,j)/grav)**(1./exponent)
2643  else
2644  phis(i,j) = 0.
2645  pe(i,npz+1,j) = p00
2646  endif
2647  ps(i,j) = pe(i,npz+1,j)
2648  enddo
2649  enddo
2650 
2651  do j=js,je
2652  do k=1,npz
2653  do i=is,ie
2654  pe(i,k,j) = ak(k) + bk(k)*ps(i,j)
2655  gz(i,j,k) = t00/gamma*(1. - (pe(i,k,j)/p00)**exponent)
2656  enddo
2657  enddo
2658  enddo
2659 
2660  do k=1,npz
2661  do j=js,je
2662  do i=is,ie
2663 
2664  !call test2_steady_state_mountain(agrid(i,j,1),agrid(i,j,2),dum, dum2, 0, .true., &
2665  ! 0.5*(ak(k)+ak(k+1)), 0.5*(bk(k)+bk(k+1)), dum3, dum4, dum5, &
2666  ! pt(i,j,k), phis(i,j), ps(i,j), dum6, q(i,j,k,1))
2667  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
2668  !Analytic point-value
2669 !!$ ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
2670 !!$ pt(i,j,k) = t00*(ptmp/p00)**exponent
2671  !ANalytic layer-mean
2672  pt(i,j,k) = -grav*t00*p00/(rdgas*gamma + grav)/delp(i,j,k) * &
2673  ( (pe(i,k,j)/p00)**(exponent+1.) - (pe(i,k+1,j)/p00)**(exponent+1.) )
2674 
2675 
2676  enddo
2677  enddo
2678  enddo
2679 
2680  else if ( abs(test_case)==30 .or. abs(test_case)==31 ) then
2681 !------------------------------------
2682 ! Super-Cell; with or with rotation
2683 !------------------------------------
2684  if ( abs(test_case)==30) then
2685  f0(:,:) = 0.
2686  fc(:,:) = 0.
2687  endif
2688 
2689  zvir = rvgas/rdgas - 1.
2690  p00 = 1000.e2
2691  ps(:,:) = p00
2692  phis(:,:) = 0.
2693  do j=js,je
2694  do i=is,ie
2695  pk(i,j,1) = ptop**kappa
2696  pe(i,1,j) = ptop
2697  peln(i,1,j) = log(ptop)
2698  enddo
2699  enddo
2700 
2701  do k=1,npz
2702  do j=js,je
2703  do i=is,ie
2704  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
2705  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
2706  peln(i,k+1,j) = log(pe(i,k+1,j))
2707  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
2708  enddo
2709  enddo
2710  enddo
2711 
2712  i = is
2713  j = js
2714  do k=1,npz
2715  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
2716  enddo
2717 
2718 
2719  w(:,:,:) = 0.
2720  q(:,:,:,:) = 0.
2721 
2722  pp0(1) = 262.0/180.*pi ! OKC
2723  pp0(2) = 35.0/180.*pi
2724 
2725  do k=1,npz
2726  do j=js,je
2727  do i=is,ie
2728  pt(i,j,k) = ts1(k)
2729  q(i,j,k,1) = qs1(k)
2730  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
2731  enddo
2732  enddo
2733  enddo
2734 
2735  ze1(npz+1) = 0.
2736  do k=npz,1,-1
2737  ze1(k) = ze1(k+1) - delz(is,js,k)
2738  enddo
2739 
2740  us0 = 30.
2741  if (is_master()) then
2742  if (test_case > 0) then
2743  write(6,*) 'Toy supercell winds, piecewise approximation'
2744  else
2745  write(6,*) 'Toy supercell winds, tanh approximation'
2746  endif
2747  endif
2748  do k=1,npz
2749 
2750  zm = 0.5*(ze1(k)+ze1(k+1))
2751  ! Quarter-circle hodograph (Harris approximation)
2752 
2753  if (test_case > 0) then
2754  ! SRH = 40
2755  if ( zm .le. 2.e3 ) then
2756  utmp = 8.*(1.-cos(pi*zm/4.e3))
2757  vtmp = 8.*sin(pi*zm/4.e3)
2758  elseif (zm .le. 6.e3 ) then
2759  utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
2760  vtmp = 8.
2761  else
2762  utmp = us0
2763  vtmp = 8.
2764  endif
2765  ubar = utmp - 8.
2766  vbar = vtmp - 4.
2767  else
2768  ! SRH = 39
2769  utmp = 15.0*(1.+tanh(zm/2000. - 1.5))
2770  vtmp = 8.5*tanh(zm/1000.)
2771  ubar = utmp - 8.5
2772  vbar = vtmp - 4.25
2773 !!$ ! SRH = 45
2774 !!$ utmp = 16.0*(1.+tanh(zm/2000. - 1.4))
2775 !!$ vtmp = 8.5*tanh(zm/1000.)
2776 !!$ ubar = utmp - 10.
2777 !!$ vbar = vtmp - 4.25
2778 !!$ ! SRH = 27 (really)
2779 !!$ utmp = 0.5*us0*(1.+tanh((zm-3500.)/2000.))
2780 !!$ vtmp = 8.*tanh(zm/1000.)
2781 !!$ ubar = utmp - 10.
2782 !!$ vbar = vtmp - 4.
2783  endif
2784 
2785  if( is_master() ) then
2786  write(6,*) k, utmp, vtmp
2787  endif
2788 
2789  do j=js,je
2790  do i=is,ie+1
2791  p1(:) = grid(i ,j ,1:2)
2792  p2(:) = grid(i,j+1 ,1:2)
2793  call mid_pt_sphere(p1, p2, p3)
2794  call get_unit_vect2(p1, p2, e2)
2795  call get_latlon_vector(p3, ex, ey)
2796 ! Scaling factor is a Gaussian decay from center
2797  v(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2798  (ubar*inner_prod(e2,ex) + vbar*inner_prod(e2,ey))
2799  enddo
2800  enddo
2801  do j=js,je+1
2802  do i=is,ie
2803  p1(:) = grid(i, j,1:2)
2804  p2(:) = grid(i+1,j,1:2)
2805  call mid_pt_sphere(p1, p2, p3)
2806  call get_unit_vect2(p1, p2, e1)
2807  call get_latlon_vector(p3, ex, ey)
2808 ! Scaling factor is a Gaussian decay from center
2809  u(i,j,k) = exp(-8.*great_circle_dist(pp0,p3,radius)/radius) * &
2810  (ubar*inner_prod(e1,ex) + vbar*inner_prod(e1,ey))
2811  enddo
2812  enddo
2813  enddo
2814 
2815  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
2816  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
2817  .true., hydrostatic, nwat, domain)
2818 
2819 ! *** Add Initial perturbation ***
2820  pturb = 2.
2821  r0 = 10.e3 ! radius
2822  zc = 1.4e3 ! center of bubble from surface
2823  do k=1, npz
2824  zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
2825  ptmp = ( (zm-zc)/zc ) **2
2826  if ( ptmp < 1. ) then
2827  do j=js,je
2828  do i=is,ie
2829  dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
2830  if ( dist < 1. ) then
2831  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
2832  endif
2833  enddo
2834  enddo
2835  endif
2836  enddo
2837 
2838  elseif (test_case == 32) then
2839 
2840  call mpp_error(fatal, ' test_case 32 not yet implemented')
2841 
2842  else if ( test_case==33 .or. test_case==34 .or. test_case==35 ) then
2843 !------------------------------------
2844 ! HIWPP M0ountain waves tests
2845 !------------------------------------
2846  f0(:,:) = 0.
2847  fc(:,:) = 0.
2848 
2849  phis(:,:) = 1.e30
2850  ps(:,:) = 1.e30
2851 
2852  zvir = 0.
2853  p00 = 1000.e2
2854  t00 = 300.
2855  us0 = 20.
2856 ! Vertical shear parameter for M3 case:
2857  if ( test_case == 35 ) then
2858  cs_m3 = 2.5e-4
2859  else
2860  cs_m3 = 0.
2861  endif
2862 
2863 ! Mountain height:
2864  h0 = 250.
2865 ! Mountain center
2866  p0(1) = 60./180. * pi
2867  p0(2) = 0.
2868 ! 9-point average:
2869 ! 9 4 8
2870 !
2871 ! 5 1 3
2872 !
2873 ! 6 2 7
2874 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
2875  if ( test_case==35 ) then
2876  dum = -cs_m3/grav
2877  do j=js,je
2878  do i=is,ie
2879 ! temperature is function of latitude (due to vertical shear)
2880 #ifdef USE_CELL_AVG
2881  p2(2) = agrid(i,j,2)
2882  pt1 = exp( dum*(us0*sin(p2(2)))**2 )
2883  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2884  pt2 = exp( dum*(us0*sin(p2(2)))**2 )
2885  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2886  pt3 = exp( dum*(us0*sin(p2(2)))**2 )
2887  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
2888  pt4 = exp( dum*(us0*sin(p2(2)))**2 )
2889  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
2890  pt5 = exp( dum*(us0*sin(p2(2)))**2 )
2891  p2(2) = grid(i,j,2)
2892  pt6 = exp( dum*(us0*sin(p2(2)))**2 )
2893  p2(2) = grid(i+1,j,2)
2894  pt7 = exp( dum*(us0*sin(p2(2)))**2 )
2895  p2(2) = grid(i+1,j+1,2)
2896  pt8 = exp( dum*(us0*sin(p2(2)))**2 )
2897  p2(2) = grid(i,j+1,2)
2898  pt9 = exp( dum*(us0*sin(p2(2)))**2 )
2899  ptmp = t00*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
2900 #else
2901  ptmp = t00*exp( dum*(us0*sin(agrid(i,j,2)))**2 )
2902 #endif
2903  do k=1,npz
2904  pt(i,j,k) = ptmp
2905  enddo
2906  enddo
2907  enddo
2908  else
2909  pt(:,:,:) = t00
2910  endif
2911 
2912  if( test_case==33 ) then
2913 ! NCAR Ridge-mountain Mods:
2914  do j=js,je
2915  do i=is,ie
2916 #ifdef USE_CELL_AVG
2917  p2(1:2) = agrid(i,j,1:2)
2918  r = radius*(p2(1)-p0(1))
2919  pt1 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2920  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2921  r = radius*(p2(1)-p0(1))
2922  pt2 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2923  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2924  r = radius*(p2(1)-p0(1))
2925  pt3 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2926  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
2927  r = radius*(p2(1)-p0(1))
2928  pt4 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2929  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
2930  r = radius*(p2(1)-p0(1))
2931  pt5 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2932  p2(1:2) = grid(i,j,1:2)
2933  r = radius*(p2(1)-p0(1))
2934  pt6 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2935  p2(1:2) = grid(i+1,j,1:2)
2936  r = radius*(p2(1)-p0(1))
2937  pt7 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2938  p2(1:2) = grid(i+1,j+1,1:2)
2939  r = radius*(p2(1)-p0(1))
2940  pt8 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2941  p2(1:2) = grid(i,j+1,1:2)
2942  r = radius*(p2(1)-p0(1))
2943  pt9 = cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2944  phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
2945 #else
2946  p2(1:2) = agrid(i,j,1:2)
2947  r = radius*(p2(1)-p0(1))
2948  phis(i,j) = grav*h0*cos(p2(2))*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2949 #endif
2950  enddo
2951  enddo
2952  else
2953 ! Circular mountain:
2954  do j=js,je
2955  do i=is,ie
2956 ! 9-point average:
2957 ! 9 4 8
2958 !
2959 ! 5 1 3
2960 !
2961 ! 6 2 7
2962 ! pt = 0.25*pt1 + 0.125*(pt2+pt3+pt4+pt5) + 0.0625*(pt6+pt7+pt8+pt9)
2963 #ifdef USE_CELL_AVG
2964  r = great_circle_dist( p0, agrid(i,j,1:2), radius )
2965  pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2966  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
2967  r = great_circle_dist( p0, p2, radius )
2968  pt2 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2969  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p2)
2970  r = great_circle_dist( p0, p2, radius )
2971  pt3 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2972  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p2)
2973  r = great_circle_dist( p0, p2, radius )
2974  pt4 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2975  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
2976  r = great_circle_dist( p0, p2, radius )
2977  pt5 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2978  r = great_circle_dist( p0, grid(i,j,1:2), radius )
2979  pt6 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2980  r = great_circle_dist( p0, grid(i+1,j,1:2), radius )
2981  pt7 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2982  r = great_circle_dist( p0, grid(i+1,j+1,1:2), radius )
2983  pt8 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2984  r = great_circle_dist( p0, grid(i,j+1,1:2), radius )
2985  pt9 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2986  phis(i,j) = grav*h0*(0.25*pt1+0.125*(pt2+pt3+pt4+pt5)+0.0625*(pt6+pt7+pt8+pt9))
2987 #else
2988  r = great_circle_dist( p0, agrid(i,j,1:2), radius )
2989  pt1 = exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2990  phis(i,j) = grav*h0*exp(-(r/5.e3)**2)*cos(pi*r/4.e3)**2
2991 #endif
2992  enddo
2993  enddo
2994  endif
2995 
2996  do j=js,je
2997  do i=is,ie
2998 ! DCMIP Eq(33)
2999  ps(i,j) = p00*exp( -0.5*(us0*sin(agrid(i,j,2)))**2/(rdgas*t00)-phis(i,j)/(rdgas*pt(i,j,1)) )
3000  pe(i,1,j) = ptop
3001  peln(i,1,j) = log(ptop)
3002  pk(i,j,1) = ptop**kappa
3003  enddo
3004  enddo
3005 
3006  do k=2,npz+1
3007  do j=js,je
3008  do i=is,ie
3009  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
3010  peln(i,k,j) = log(pe(i,k,j))
3011  pk(i,j,k) = exp( kappa*peln(i,k,j) )
3012  enddo
3013  enddo
3014  enddo
3015 
3016  do k=1,npz
3017  do j=js,je
3018  do i=is,ie
3019  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3020  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(peln(i,k,j)-peln(i,k+1,j))
3021  enddo
3022  enddo
3023  enddo
3024 
3025 ! Comnpute mid-level height, using w for temp storage
3026  do j=js,je
3027  do i=is,ie
3028  ze1(npz+1) = phis(i,j)/grav
3029  do k=npz,1,-1
3030  ze1(k) = ze1(k+1) - delz(i,j,k)
3031  enddo
3032  do k=1,npz
3033  w(i,j,k) = 0.5*(ze1(k)+ze1(k+1))
3034  enddo
3035  enddo
3036  enddo
3037  call mpp_update_domains( w, domain )
3038 
3039  do k=1,npz
3040  do j=js,je
3041  do i=is,ie+1
3042  p1(:) = grid(i ,j, 1:2)
3043  p2(:) = grid(i,j+1, 1:2)
3044  call mid_pt_sphere(p1, p2, p3)
3045  call get_unit_vect2(p1, p2, e2)
3046  call get_latlon_vector(p3, ex, ey)
3047 ! Joe Klemp's mod:
3048  utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i-1,j,k)+w(i,j,k)) )
3049  v(i,j,k) = utmp*inner_prod(e2,ex)
3050  enddo
3051  enddo
3052  do j=js,je+1
3053  do i=is,ie
3054  p1(:) = grid(i, j, 1:2)
3055  p2(:) = grid(i+1,j, 1:2)
3056  call mid_pt_sphere(p1, p2, p3)
3057  call get_unit_vect2(p1, p2, e1)
3058  call get_latlon_vector(p3, ex, ey)
3059  utmp = us0*cos(p3(2))*sqrt( 1. + cs_m3*(w(i,j-1,k)+w(i,j,k)) )
3060  u(i,j,k) = utmp*inner_prod(e1,ex)
3061  enddo
3062  enddo
3063  enddo
3064 
3065  w(:,:,:) = 0. ! reset w
3066  q(:,:,:,:) = 0.
3067 
3068  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3069  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
3070  .true., hydrostatic, nwat, domain)
3071 
3072  else if ( test_case==36 .or. test_case==37 ) then
3073 !------------------------------------
3074 ! HIWPP Super-Cell
3075 !------------------------------------
3076 ! HIWPP SUPER_K;
3077  f0(:,:) = 0.
3078  fc(:,:) = 0.
3079  q(:,:,:,:) = 0.
3080  w(:,:,:) = 0.
3081 
3082  zvir = rvgas/rdgas - 1.
3083  p00 = 1000.e2
3084  pk0 = p00**kappa
3085  ps(:,:) = p00
3086  phis(:,:) = 0.
3087 !
3088 ! Set up vertical layer spacing:
3089  ztop = 20.e3
3090  ze1(1) = ztop
3091  ze1(npz+1) = 0.
3092 #ifndef USE_VAR_DZ
3093 ! Truly uniform setup:
3094  do k=npz,2,-1
3095  ze1(k) = ze1(k+1) + ztop/real(npz)
3096  enddo
3097 #else
3098 ! Lowest layer half of the size
3099 ! ze1(npz) = ztop / real(2*npz-1) ! lowest layer thickness
3100 ! zm = (ztop-ze1(npz)) / real(npz-1)
3101 ! do k=npz,2,-1
3102 ! ze1(k) = ze1(k+1) + zm
3103 ! enddo
3104  call var_dz(npz, ztop, ze1)
3105 #endif
3106  do k=1,npz
3107  zs1(k) = 0.5*(ze1(k)+ze1(k+1))
3108  enddo
3109 !-----
3110 ! Get sounding at "equator": initial storm center
3111  call superk_sounding(npz, pe1, p00, ze1, ts1, qs1)
3112 ! ts1 is FV's definition of potential temperature at EQ
3113 
3114  do k=1,npz
3115  ts1(k) = cp_air*ts1(k)*(1.+zvir*qs1(k)) ! cp*thelta_v
3116  enddo
3117 ! Initialize the fields on z-coordinate; adjust top layer mass
3118 ! Iterate then interpolate to get balanced pt & pk on the sphere
3119 ! Adjusting ptop
3120  call superk_u(npz, zs1, uz1, dudz)
3121  call balanced_k(npz, is, ie, js, je, ng, pe1(npz+1), ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
3122  delz, zvir, ptop, ak, bk, agrid)
3123  do j=js,je
3124  do i=is,ie
3125  ps(i,j) = pe(i,npz+1,j)
3126  enddo
3127  enddo
3128 
3129  do k=1,npz+1
3130  do j=js,je
3131  do i=is,ie
3132  peln(i,k,j) = log(pe(i,k,j))
3133  pk(i,j,k) = exp( kappa*peln(i,k,j) )
3134  enddo
3135  enddo
3136  enddo
3137 
3138  do k=1,npz
3139  do j=js,je
3140  do i=is,ie
3141  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
3142  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3143  q(i,j,k,1) = qs1(k)
3144  enddo
3145  enddo
3146  enddo
3147 
3148  k = 1 ! keep the same temperature but adjust the height at the top layer
3149  do j=js,je
3150  do i=is,ie
3151  delz(i,j,k) = rdgas/grav*pt(i,j,k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
3152  enddo
3153  enddo
3154 ! Adjust temperature; enforce constant dz except the top layer
3155  do k=2,npz
3156  do j=js,je
3157  do i=is,ie
3158  delz(i,j,k) = ze1(k+1) - ze1(k)
3159  pt(i,j,k) = delz(i,j,k)*grav/(rdgas*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j)))
3160  enddo
3161  enddo
3162  enddo
3163 
3164 ! Wind-profile:
3165  do k=1,npz
3166  do j=js,je
3167  do i=is,ie+1
3168  p1(:) = grid(i ,j ,1:2)
3169  p2(:) = grid(i,j+1 ,1:2)
3170  call mid_pt_sphere(p1, p2, p3)
3171  call get_unit_vect2(p1, p2, e2)
3172  call get_latlon_vector(p3, ex, ey)
3173  v(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e2,ex)
3174  enddo
3175  enddo
3176  do j=js,je+1
3177  do i=is,ie
3178  p1(:) = grid(i, j,1:2)
3179  p2(:) = grid(i+1,j,1:2)
3180  call mid_pt_sphere(p1, p2, p3)
3181  call get_unit_vect2(p1, p2, e1)
3182  call get_latlon_vector(p3, ex, ey)
3183  u(i,j,k) = uz1(k)*cos(p3(2))*inner_prod(e1,ex)
3184  enddo
3185  enddo
3186  enddo
3187 
3188 ! *** Add Initial perturbation ***
3189  if ( test_case == 37 ) then
3190  pp0(1) = pi
3191  pp0(2) = 0.
3192  if (adiabatic) then
3193  pturb = 10.
3194  else
3195  pturb = 3. ! potential temperature
3196  endif
3197  r0 = 10.e3 ! radius
3198  zc = 1.5e3 ! center of bubble from surface
3199  do k=1, npz
3200  zm = 0.5*(ze1(k)+ze1(k+1)) ! center of the layer
3201  ptmp = ( (zm-zc)/zc ) **2
3202  if ( ptmp < 1. ) then
3203  do j=js,je
3204  do i=is,ie
3205  dist = ptmp + (great_circle_dist(pp0, agrid(i,j,1:2), radius)/r0)**2
3206  dist = sqrt(dist)
3207  if ( dist < 1. ) then
3208  pt(i,j,k) = pt(i,j,k) + (pkz(i,j,k)/pk0)*pturb*cos(0.5*pi*dist)**2
3209  endif
3210  enddo
3211  enddo
3212  endif
3213  enddo
3214  endif
3215 
3216  else if (test_case == 44) then ! Lock-exchange K-H instability on a very large-scale
3217 
3218  !Background state
3219  p00 = 1000.e2
3220  ps(:,:) = p00
3221  phis = 0.0
3222  u(:,:,:) = 0.
3223  v(:,:,:) = 0.
3224  q(:,:,:,:) = 0.
3225 
3226  if (adiabatic) then
3227  zvir = 0.
3228  else
3229  zvir = rvgas/rdgas - 1.
3230  endif
3231 
3232 ! Initialize delta-P
3233  do z=1,npz
3234  do j=js,je
3235  do i=is,ie
3236  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3237  enddo
3238  enddo
3239  enddo
3240 
3241  do j=js,je
3242  do i=is,ie
3243  pe(i,1,j) = ptop
3244  peln(i,1,j) = log(pe(i,1,j))
3245  pk(i,j,1) = exp(kappa*peln(i,1,j))
3246  enddo
3247  do k=2,npz+1
3248  do i=is,ie
3249  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3250  peln(i,k,j) = log(pe(i,k,j))
3251  pk(i,j,k) = exp(kappa*peln(i,k,j))
3252  enddo
3253  enddo
3254  enddo
3255 
3256  p1(1) = pi
3257  p1(2) = 0.
3258  r0 = 1000.e3 ! hurricane size
3259 
3260  do k=1,npz
3261  do j=js,je
3262  do i=is,ie
3263  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3264  dist = great_circle_dist( p0, agrid(i,j,1:2), radius )
3265  if ( dist .le. r0 ) then
3266  pt(i,j,k) = 275.
3267  q(i,j,k,1) = 1.
3268  else
3269  pt(i,j,k) = 265.
3270  q(i,j,k,1) = 0.
3271  end if
3272 ! pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3273  enddo
3274  enddo
3275  enddo
3276 
3277  if (.not.hydrostatic) then
3278  do k=1,npz
3279  do j=js,je
3280  do i=is,ie
3281  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))
3282  w(i,j,k) = 0.0
3283  enddo
3284  enddo
3285  enddo
3286  endif
3287 
3288  else if (test_case == 45 .or. test_case == 46) then ! NGGPS test?
3289 
3290 ! Background state
3291  f0 = 0.; fc = 0.
3292  pt0 = 300. ! potentil temperature
3293  p00 = 1000.e2
3294  ps(:,:) = p00
3295  phis = 0.0
3296  u(:,:,:) = 0.
3297  v(:,:,:) = 0.
3298  q(:,:,:,:) = 0.
3299 
3300  if (adiabatic) then
3301  zvir = 0.
3302  else
3303  zvir = rvgas/rdgas - 1.
3304  endif
3305 
3306 ! Initialize delta-P
3307  do k=1,npz
3308  do j=js,je
3309  do i=is,ie
3310  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
3311  enddo
3312  enddo
3313  enddo
3314 
3315  do j=js,je
3316  do i=is,ie
3317  pe(i,1,j) = ptop
3318  peln(i,1,j) = log(pe(i,1,j))
3319  pk(i,j,1) = exp(kappa*peln(i,1,j))
3320  enddo
3321  do k=2,npz+1
3322  do i=is,ie
3323  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3324  peln(i,k,j) = log(pe(i,k,j))
3325  pk(i,j,k) = exp(kappa*peln(i,k,j))
3326  enddo
3327  enddo
3328  enddo
3329 
3330 ! Initiate the westerly-wind-burst:
3331  ubar = soliton_umax
3332  r0 = soliton_size
3333 !!$ if (test_case == 46) then
3334 !!$ ubar = 200.
3335 !!$ r0 = 250.e3
3336 !!$ else
3337 !!$ ubar = 50. ! Initial maxmium wind speed (m/s)
3338 !!$ r0 = 500.e3
3339 !!$ endif
3340  p0(1) = pi*0.5
3341  p0(2) = 0.
3342 
3343  do k=1,npz
3344  do j=js,je
3345  do i=is,ie+1
3346  p1(:) = grid(i ,j ,1:2)
3347  p2(:) = grid(i,j+1 ,1:2)
3348  call mid_pt_sphere(p1, p2, p3)
3349  r = great_circle_dist( p0, p3, radius )
3350  utmp = ubar*exp(-(r/r0)**2)
3351  call get_unit_vect2(p1, p2, e2)
3352  call get_latlon_vector(p3, ex, ey)
3353  v(i,j,k) = utmp*inner_prod(e2,ex)
3354  enddo
3355  enddo
3356  do j=js,je+1
3357  do i=is,ie
3358  p1(:) = grid(i, j,1:2)
3359  p2(:) = grid(i+1,j,1:2)
3360  call mid_pt_sphere(p1, p2, p3)
3361  r = great_circle_dist( p0, p3, radius )
3362  utmp = ubar*exp(-(r/r0)**2)
3363  call get_unit_vect2(p1, p2, e1)
3364  call get_latlon_vector(p3, ex, ey)
3365  u(i,j,k) = utmp*inner_prod(e1,ex)
3366  enddo
3367  enddo
3368 
3369  do j=js,je
3370  do i=is,ie
3371  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
3372 #ifdef USE_PT
3373  pt(i,j,k) = pt0/p00**kappa
3374 ! Convert back to temperature:
3375  pt(i,j,k) = pt(i,j,k)*pkz(i,j,k)
3376 #else
3377  pt(i,j,k) = pt0
3378 #endif
3379  q(i,j,k,1) = 0.
3380  enddo
3381  enddo
3382 
3383  enddo
3384 
3385 #ifdef NEST_TEST
3386  do k=1,npz
3387  do j=js,je
3388  do i=is,ie
3389  q(i,j,k,:) = agrid(i,j,1)*0.180/pi
3390  enddo
3391  enddo
3392  enddo
3393 #else
3394  call checker_tracers(is,ie, js,je, isd,ied, jsd,jed, &
3395  ncnst, npz, q, agrid(is:ie,js:je,1), agrid(is:ie,js:je,2), 9., 9.)
3396 #endif
3397 
3398  if ( .not. hydrostatic ) then
3399  do k=1,npz
3400  do j=js,je
3401  do i=is,ie
3402  delz(i,j,k) = rdgas*pt(i,j,k)/grav*log(pe(i,k,j)/pe(i,k+1,j))
3403  w(i,j,k) = 0.0
3404  enddo
3405  enddo
3406  enddo
3407  endif
3408  else if (test_case == 55 .or. test_case == 56 .or. test_case == 57) then
3409 
3410  !Tropical cyclone test case: DCMIP 5X
3411 
3412  !test_case 56 initializes the environment
3413  ! but no vortex
3414 
3415  !test_case 57 uses a globally-uniform f-plane
3416 
3417  ! Initialize surface Pressure
3418  !Vortex perturbation
3419  p0(1) = 180. * pi / 180.
3420  p0(2) = 10. * pi / 180.
3421 
3422  if (test_case == 56) then
3423  dp = 0.
3424  rp = 1.e25
3425  else
3426  dp = 1115.
3427  rp = 282000.
3428  endif
3429  p00 = 101500.
3430 
3431  ps = p00
3432 
3433  do j=js,je
3434  do i=is,ie
3435  p2(:) = agrid(i,j,1:2)
3436  r = great_circle_dist( p0, p2, radius )
3437  ps(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3438  phis(i,j) = 0.
3439  enddo
3440  enddo
3441 
3442  call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3443 
3444  ! Initialize delta-P
3445  do z=1,npz
3446  do j=js,je
3447  do i=is,ie
3448  delp(i,j,z) = ak(z+1)-ak(z) + ps(i,j)*(bk(z+1)-bk(z))
3449  enddo
3450  enddo
3451  enddo
3452 
3453  !Pressure
3454  do j=js,je
3455  do i=is,ie
3456  pe(i,1,j) = ptop
3457  enddo
3458  do k=2,npz+1
3459  do i=is,ie
3460  pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1)
3461  enddo
3462  enddo
3463  enddo
3464 
3465  !Pressure on v-grid and u-grid points
3466  do j=js,je
3467  do i=is,ie+1
3468  p2(:) = 0.5*(grid(i,j,1:2)+grid(i,j+1,1:2))
3469  r = great_circle_dist( p0, p2, radius )
3470  ps_v(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3471  enddo
3472  enddo
3473  do j=js,je+1
3474  do i=is,ie
3475  p2(:) = 0.5*(grid(i,j,1:2)+grid(i+1,j,1:2))
3476  r = great_circle_dist( p0, p2, radius )
3477  ps_u(i,j) = p00 - dp*exp(-(r/rp)**1.5)
3478  enddo
3479  enddo
3480 
3481  !Pressure
3482  do j=js,je
3483  do i=is,ie+1
3484  pe_v(i,1,j) = ptop
3485  enddo
3486  do k=2,npz+1
3487  do i=is,ie+1
3488  pe_v(i,k,j) = ak(k) + ps_v(i,j)*bk(k)
3489  enddo
3490  enddo
3491  enddo
3492  do j=js,je+1
3493  do i=is,ie
3494  pe_u(i,1,j) = ptop
3495  enddo
3496  do k=2,npz+1
3497  do i=is,ie
3498  pe_u(i,k,j) = ak(k) + ps_u(i,j)*bk(k)
3499  enddo
3500  enddo
3501  enddo
3502 
3503  !Everything else
3504  !if (adiabatic) then
3505  ! zvir = 0.
3506  !else
3507  zvir = rvgas/rdgas - 1.
3508  !endif
3509 
3510  p0 = (/ pi, pi/18. /)
3511 
3512  exppr = 1.5
3513  exppz = 2.
3514  gamma = 0.007
3515  ts0 = 302.15
3516  q00 = 0.021
3517  t00 = ts0*(1.+zvir*q00)
3518  exponent = rdgas*gamma/grav
3519  ztrop = 15000.
3520  zp = 7000.
3521  dp = 1115.
3522  cor = 2.*omega*sin(p0(2)) !Coriolis at vortex center
3523 
3524  !Initialize winds separately on the D-grid
3525  do j=js,je
3526  do i=is,ie+1
3527  p1(:) = grid(i ,j ,1:2)
3528  p2(:) = grid(i,j+1 ,1:2)
3529  call mid_pt_sphere(p1, p2, p3)
3530  call get_unit_vect2(p1, p2, e2)
3531  call get_latlon_vector(p3, ex, ey)
3532 
3533  d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3534  d2 = cos(p0(2))*sin(p3(1)-p0(1))
3535  d = max(1.e-15,sqrt(d1**2+d2**2))
3536 
3537  r = great_circle_dist( p0, p3, radius )
3538 
3539  do k=1,npz
3540  ptmp = 0.5*(pe_v(i,k,j)+pe_v(i,k+1,j))
3541  height = (t00/gamma)*(1.-(ptmp/ps_v(i,j))**exponent)
3542  if (height > ztrop) then
3543  v(i,j,k) = 0.
3544  else
3545  utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3546  - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3547  /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3548  +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3549  vtmp = utmp*d2
3550  utmp = utmp*d1
3551 
3552  v(i,j,k) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
3553 
3554  endif
3555  enddo
3556  enddo
3557  enddo
3558  do j=js,je+1
3559  do i=is,ie
3560  p1(:) = grid(i, j,1:2)
3561  p2(:) = grid(i+1,j,1:2)
3562  call mid_pt_sphere(p1, p2, p3)
3563  call get_unit_vect2(p1, p2, e1)
3564  call get_latlon_vector(p3, ex, ey)
3565 
3566  d1 = sin(p0(2))*cos(p3(2)) - cos(p0(2))*sin(p3(2))*cos(p3(1)-p0(1))
3567  d2 = cos(p0(2))*sin(p3(1)-p0(1))
3568  d = max(1.e-15,sqrt(d1**2+d2**2))
3569 
3570  r = great_circle_dist( p0, p3, radius )
3571 
3572  do k=1,npz
3573  ptmp = 0.5*(pe_u(i,k,j)+pe_u(i,k+1,j))
3574  height = (t00/gamma)*(1.-(ptmp/ps_u(i,j))**exponent)
3575  if (height > ztrop) then
3576  v(i,j,k) = 0.
3577  else
3578  utmp = 1.d0/d*(-cor*r/2.d0+sqrt((cor*r/2.d0)**(2.d0) &
3579  - exppr*(r/rp)**exppr*rdgas*(t00-gamma*height) &
3580  /(exppz*height*rdgas*(t00-gamma*height)/(grav*zp**exppz) &
3581  +(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz)))))
3582  vtmp = utmp*d2
3583  utmp = utmp*d1
3584 
3585  u(i,j,k) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
3586  endif
3587  enddo
3588 
3589  enddo
3590  enddo
3591 
3592  qtrop = 1.e-11
3593  ttrop = t00 - gamma*ztrop
3594  zq1 = 3000.
3595  zq2 = 8000.
3596 
3597  q(:,:,:,:) = 0.
3598 
3599  do k=1,npz
3600  do j=js,je
3601  do i=is,ie
3602  ptmp = 0.5*(pe(i,k,j)+pe(i,k+1,j))
3603  height = (t00/gamma)*(1.-(ptmp/ps(i,j))**exponent)
3604  if (height > ztrop) then
3605  q(i,j,k,1) = qtrop
3606  pt(i,j,k) = ttrop
3607  else
3608  q(i,j,k,1) = q00*exp(-height/zq1)*exp(-(height/zq2)**exppz)
3609  p2(:) = agrid(i,j,1:2)
3610  r = great_circle_dist( p0, p2, radius )
3611  pt(i,j,k) = (t00-gamma*height)/(1.d0+zvir*q(i,j,k,1))/(1.d0+exppz*rdgas*(t00-gamma*height)*height &
3612  /(grav*zp**exppz*(1.d0-p00/dp*exp((r/rp)**exppr)*exp((height/zp)**exppz))))
3613  end if
3614  enddo
3615  enddo
3616  enddo
3617 
3618  !Note that this is already the moist pressure
3619  do j=js,je
3620  do i=is,ie
3621  ps(i,j) = pe(i,npz+1,j)
3622  enddo
3623  enddo
3624 
3625  if (.not.hydrostatic) then
3626  do k=1,npz
3627  do j=js,je
3628  do i=is,ie
3629  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))
3630  w(i,j,k) = 0.0
3631  enddo
3632  enddo
3633  enddo
3634  endif
3635 
3636  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
3637 
3638  call prt_maxmin('PS', ps(is:ie,js:je), is, ie, js, je, 0, 1, 0.01)
3639 
3640  if (test_case == 57) then
3641  do j=jsd,jed+1
3642  do i=isd,ied+1
3643  fc(i,j) = cor
3644  enddo
3645  enddo
3646  do j=jsd,jed
3647  do i=isd,ied
3648  f0(i,j) = cor
3649  enddo
3650  enddo
3651  endif
3652 
3653 
3654  else if ( test_case == -55 ) then
3655 
3656  call dcmip16_tc (delp, pt, u, v, q, w, delz, &
3657  is, ie, js, je, isd, ied, jsd, jed, npz, ncnst, &
3658  ak, bk, ptop, pk, peln, pe, pkz, gz, phis, &
3659  ps, grid, agrid, hydrostatic, nwat, adiabatic)
3660 
3661  else
3662 
3663  call mpp_error(fatal, " test_case not defined" )
3664 
3665  endif !test_case
3666 
3667  call mpp_update_domains( phis, domain )
3668 
3669  ftop = g_sum(domain, phis(is:ie,js:je), is, ie, js, je, ng, area, 1)
3670  if(is_master()) write(*,*) 'mean terrain height (m)=', ftop/grav
3671 
3672 ! The flow is initially hydrostatic
3673 #ifndef SUPER_K
3674  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
3675  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., mountain, &
3676  moist_phys, hydrostatic, nwat, domain, .not.hydrostatic)
3677 #endif
3678 
3679 #ifdef COLUMN_TRACER
3680  if( ncnst>1 ) q(:,:,:,2:ncnst) = 0.0
3681  ! Initialize a dummy Column Tracer
3682  pcen(1) = pi/9.
3683  pcen(2) = 2.0*pi/9.
3684  r0 = radius/10.0
3685  do z=1,npz
3686  do j=js,je
3687  do i=is,ie
3688  p1(:) = grid(i ,j ,1:2)
3689  p2(:) = grid(i,j+1 ,1:2)
3690  call mid_pt_sphere(p1, p2, pa)
3691  call get_unit_vect2(p1, p2, e2)
3692  call get_latlon_vector(pa, ex, ey)
3693  ! Perturbation Location Case==13
3694  r = great_circle_dist( pcen, pa, radius )
3695  if (-(r/r0)**2.0 > -40.0) q(i,j,z,1) = exp(-(r/r0)**2.0)
3696  enddo
3697  enddo
3698  enddo
3699 #endif
3700 
3701 #endif
3702  call mp_update_dwinds(u, v, npx, npy, npz, domain)
3703 
3704 
3705  nullify(agrid)
3706  nullify(grid)
3707 
3708  nullify(area)
3709  nullify(rarea)
3710 
3711  nullify(fc)
3712  nullify(f0)
3713 
3714  nullify(dx)
3715  nullify(dy)
3716  nullify(dxa)
3717  nullify(dya)
3718  nullify(rdxa)
3719  nullify(rdya)
3720  nullify(dxc)
3721  nullify(dyc)
3722 
3723  nullify(ee1)
3724  nullify(ee2)
3725  nullify(ew)
3726  nullify(es)
3727  nullify(en1)
3728  nullify(en2)
3729 
3730  nullify(latlon)
3731  nullify(cubed_sphere)
3732 
3733  nullify(domain)
3734  nullify(tile)
3735 
3736  nullify(have_south_pole)
3737  nullify(have_north_pole)
3738 
3739  nullify(ntiles_g)
3740  nullify(acapn)
3741  nullify(acaps)
3742  nullify(globalarea)
3743 
3744  end subroutine init_case
3745 
3746  subroutine get_vorticity(isc, iec, jsc, jec ,isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
3747  integer isd, ied, jsd, jed, npz
3748  integer isc, iec, jsc, jec
3749  real, intent(in) :: u(isd:ied, jsd:jed+1, npz), v(isd:ied+1, jsd:jed, npz)
3750  real, intent(out) :: vort(isc:iec, jsc:jec, npz)
3751  real, intent(IN) :: dx(isd:ied,jsd:jed+1)
3752  real, intent(IN) :: dy(isd:ied+1,jsd:jed)
3753  real, intent(IN) :: rarea(isd:ied,jsd:jed)
3754 ! Local
3755  real :: utmp(isc:iec, jsc:jec+1), vtmp(isc:iec+1, jsc:jec)
3756  integer :: i,j,k
3757 
3758  do k=1,npz
3759  do j=jsc,jec+1
3760  do i=isc,iec
3761  utmp(i,j) = u(i,j,k)*dx(i,j)
3762  enddo
3763  enddo
3764  do j=jsc,jec
3765  do i=isc,iec+1
3766  vtmp(i,j) = v(i,j,k)*dy(i,j)
3767  enddo
3768  enddo
3769 
3770  do j=jsc,jec
3771  do i=isc,iec
3772  vort(i,j,k) = rarea(i,j)*(utmp(i,j)-utmp(i,j+1)-vtmp(i,j)+vtmp(i+1,j))
3773  enddo
3774  enddo
3775  enddo
3776 
3777  end subroutine get_vorticity
3778 
3779  subroutine checker_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3780  nq, km, q, lon, lat, nx, ny, rn)
3781 !--------------------------------------------------------------------
3782 ! This routine computes the checker-board tracer pattern with optional
3783 ! random pertubation (if rn/= 0)
3784 ! To get 20 (deg) by 20 (deg) checker boxes: nx=9, ny=9
3785 ! If random noises are desired, rn=0.1 is a good value
3786 ! lon: longitude (Radian)
3787 ! lat: latitude (Radian)
3788 ! Coded by S.-J. Lin for HIWPP benchmark, Oct2, 2014
3789 !--------------------------------------------------------------------
3790  integer, intent(in):: nq ! number of tracers
3791  integer, intent(in):: km ! vertical dimension
3792  integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3793  integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3794  integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3795  real, intent(in):: nx ! east-west wave number
3796  real, intent(in):: ny ! North-south wave number
3797  real, intent(in), optional:: rn ! (optional) magnitude of random perturbation
3798  real(kind=R_GRID), intent(in), dimension(i0:i1,j0:j1):: lon, lat
3799  real, intent(out):: q(ifirst:ilast,jfirst:jlast,km,nq)
3800 ! Local var:
3801  real:: qt(i0:i1,j0:j1)
3802  real:: qtmp, ftmp
3803  integer:: i,j,k,iq
3804 
3805 !$OMP parallel do default(none) shared(i0,i1,j0,j1,nx,lon,ny,lat,qt) &
3806 !$OMP private(qtmp)
3807  do j=j0,j1
3808  do i=i0,i1
3809  qtmp = sin(nx*lon(i,j))*sin(ny*lat(i,j))
3810  if ( qtmp < 0. ) then
3811  qt(i,j) = 0.
3812  else
3813  qt(i,j) = 1.
3814  endif
3815  enddo
3816  enddo
3817 
3818  if ( present(rn) ) then ! Add random noises to the set pattern
3819  do iq=1,nq
3820  call random_seed()
3821 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,rn,iq) &
3822 !$OMP private(ftmp)
3823  do k=1,km
3824  do j=j0,j1
3825  do i=i0,i1
3826  call random_number(ftmp)
3827  q(i,j,k,iq) = qt(i,j) + rn*ftmp
3828  enddo
3829  enddo
3830  enddo
3831  enddo
3832  else
3833  do iq=1,nq
3834 !$OMP parallel do default(none) shared(i0,i1,j0,j1,km,q,qt,iq) &
3835 !$OMP private(ftmp)
3836  do k=1,km
3837  do j=j0,j1
3838  do i=i0,i1
3839  q(i,j,k,iq) = qt(i,j)
3840  enddo
3841  enddo
3842  enddo
3843  enddo
3844  endif
3845 
3846  end subroutine checker_tracers
3847 
3848  subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, &
3849  km, q, delp, ncnst, lon, lat)
3850 !--------------------------------------------------------------------
3851 ! This routine implements the terminator test.
3852 ! Coded by Lucas Harris for DCMIP 2016, May 2016
3853 !--------------------------------------------------------------------
3854  integer, intent(in):: km ! vertical dimension
3855  integer, intent(in):: i0, i1 ! compute domain dimension in E-W
3856  integer, intent(in):: j0, j1 ! compute domain dimension in N-S
3857  integer, intent(in):: ifirst, ilast, jfirst, jlast ! tracer array dimensions
3858  integer, intent(in):: ncnst
3859  real(kind=R_GRID), intent(in), dimension(ifirst:ilast,jfirst:jlast):: lon, lat
3860  real, intent(inout):: q(ifirst:ilast,jfirst:jlast,km,ncnst)
3861  real, intent(in):: delp(ifirst:ilast,jfirst:jlast,km)
3862 ! Local var:
3863  real:: D, k1, r, ll, sinthc, costhc, mm
3864  integer:: i,j,k
3865  integer:: Cl, Cl2
3866 
3867  !NOTE: If you change the reaction rates, then you will have to change it both
3868  ! here and in fv_phys
3869  real, parameter :: qcly = 4.e-6
3870  real, parameter :: lc = 5.*pi/3.
3871  real, parameter :: thc = pi/9.
3872  real, parameter :: k2 = 1.
3873 
3874  sinthc = sin(thc)
3875  costhc = cos(thc)
3876 
3877  cl = get_tracer_index(model_atmos, 'Cl')
3878  cl2 = get_tracer_index(model_atmos, 'Cl2')
3879 
3880  do j=j0,j1
3881  do i=i0,i1
3882  k1 = max(0., sin(lat(i,j))*sinthc + cos(lat(i,j))*costhc*cos(lon(i,j) - lc))
3883  r = k1/k2 * 0.25
3884  d = sqrt(r*r + 2.*r*qcly)
3885  q(i,j,1,cl) = d - r
3886  q(i,j,1,cl2) = 0.5*(qcly - q(i,j,1,cl))
3887  enddo
3888  enddo
3889 
3890  do k=2,km
3891  do j=j0,j1
3892  do i=i0,i1
3893  q(i,j,k,cl) = q(i,j,1,cl)
3894  q(i,j,k,cl2) = q(i,j,1,cl2)
3895  enddo
3896  enddo
3897  enddo
3898 
3899  !Compute qcly0
3900  qcly0 = 0.
3901  if (is_master()) then
3902  i = is
3903  j = js
3904  mm = 0.
3905  do k=1,km
3906  qcly0 = qcly0 + (q(i,j,k,cl) + 2.*q(i,j,k,cl2))*delp(i,j,k)
3907  mm = mm + delp(i,j,k)
3908  enddo
3909  qcly0 = qcly0/mm
3910  endif
3911  call mpp_sum(qcly0)
3912  if (is_master()) print*, ' qcly0 = ', qcly0
3913 
3914 
3915 end subroutine terminator_tracers
3916 
3917  subroutine rankine_vortex(ubar, r0, p1, u, v, grid )
3918 !----------------------------
3919 ! Rankine vortex
3920 !----------------------------
3921  real, intent(in):: ubar ! max wind (m/s)
3922  real, intent(in):: r0 ! Radius of max wind (m)
3923  real, intent(in):: p1(2) ! center position (longitude, latitude) in radian
3924  real, intent(inout):: u(isd:ied, jsd:jed+1)
3925  real, intent(inout):: v(isd:ied+1,jsd:jed)
3926  real(kind=R_GRID), intent(IN) :: grid(isd:ied+1,jsd:jed+1,2)
3927 ! local:
3928  real(kind=R_GRID):: p2(2), p3(2), p4(2)
3929  real(kind=R_GRID):: e1(3), e2(3), ex(3), ey(3)
3930  real:: vr, r, d2, cos_p, x1, y1
3931  real:: utmp, vtmp
3932  integer i, j
3933 
3934 ! Compute u-wind
3935  do j=js,je+1
3936  do i=is,ie
3937  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
3938 ! shift:
3939  p2(1) = p2(1) - p1(1)
3940  cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
3941  r = radius*acos(cos_p) ! great circle distance
3942 ! if( r<0.) call mpp_error(FATAL, 'radius negative!')
3943  if( r<r0 ) then
3944  vr = ubar*r/r0
3945  else
3946  vr = ubar*r0/r
3947  endif
3948  x1 = cos(p2(2))*sin(p2(1))
3949  y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
3950  d2 = max(1.e-25, sqrt(x1**2 + y1**2))
3951  utmp = -vr*y1/d2
3952  vtmp = vr*x1/d2
3953  p3(1) = grid(i,j, 1) - p1(1)
3954  p3(2) = grid(i,j, 2)
3955  p4(1) = grid(i+1,j,1) - p1(1)
3956  p4(2) = grid(i+1,j,2)
3957  call get_unit_vect2(p3, p4, e1)
3958  call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
3959  u(i,j) = u(i,j) + utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
3960  enddo
3961  enddo
3962 
3963 ! Compute v-wind
3964  do j=js,je
3965  do i=is,ie+1
3966  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p2)
3967 ! shift:
3968  p2(1) = p2(1) - p1(1)
3969  cos_p = sin(p2(2))*sin(p1(2)) + cos(p2(2))*cos(p1(2))*cos(p2(1))
3970  r = radius*acos(cos_p) ! great circle distance
3971  if( r<r0 ) then
3972  vr = ubar*r/r0
3973  else
3974  vr = ubar*r0/r
3975  endif
3976  x1 = cos(p2(2))*sin(p2(1))
3977  y1 = sin(p2(2))*cos(p1(2)) - cos(p2(2))*sin(p1(2))*cos(p2(1))
3978  d2 = max(1.e-25, sqrt(x1**2 + y1**2))
3979  utmp = -vr*y1/d2
3980  vtmp = vr*x1/d2
3981  p3(1) = grid(i,j, 1) - p1(1)
3982  p3(2) = grid(i,j, 2)
3983  p4(1) = grid(i,j+1,1) - p1(1)
3984  p4(2) = grid(i,j+1,2)
3985  call get_unit_vect2(p3, p4, e2)
3986  call get_latlon_vector(p2, ex, ey) ! note: p2 shifted
3987  v(i,j) = v(i,j) + utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
3988  enddo
3989  enddo
3990  end subroutine rankine_vortex
3991 
3992 
3993 
3994  real function gh_jet(npy, lat_in)
3995  integer, intent(in):: npy
3996  real, intent(in):: lat_in
3997  real lat, lon, dp, uu
3998  real h0, ft
3999  integer j,jm
4000 
4001  jm = 4 * npy
4002 ! h0 = 10.E3
4003  h0 = 10.157946867e3
4004  dp = pi / real(jm-1)
4005 
4006  if ( .not. gh_initialized ) then
4007 ! SP:
4008  allocate(gh_table(jm))
4009  allocate(lats_table(jm))
4010  gh_table(1) = grav*h0
4011  lats_table(1) = -pi/2.
4012 ! Using only the mid-point for integration
4013  do j=2,jm
4014  lat = -pi/2. + (real(j-1)-0.5)*dp
4015  uu = u_jet(lat)
4016  ft = 2.*omega*sin(lat)
4017  gh_table(j) = gh_table(j-1) - uu*(radius*ft + tan(lat)*uu) * dp
4018  lats_table(j) = -pi/2. + real(j-1)*dp
4019  enddo
4020  gh_initialized = .true.
4021  endif
4022 
4023  if ( lat_in <= lats_table(1) ) then
4024  gh_jet = gh_table(1)
4025  return
4026  endif
4027  if ( lat_in >= lats_table(jm) ) then
4028  gh_jet = gh_table(jm)
4029  return
4030  endif
4031 
4032 ! Search:
4033  do j=1,jm-1
4034  if ( lat_in >=lats_table(j) .and. lat_in<=lats_table(j+1) ) then
4035  gh_jet = gh_table(j) + (gh_table(j+1)-gh_table(j))/dp * (lat_in-lats_table(j))
4036  return
4037  endif
4038  enddo
4039  end function gh_jet
4040 
4041  real function u_jet(lat)
4042  real lat, lon, dp
4043  real umax, en, ph0, ph1
4044 
4045  umax = 80.
4046  ph0 = pi/7.
4047  ph1 = pi/2. - ph0
4048  en = exp( -4./(ph1-ph0)**2 )
4049 
4050  if ( lat>ph0 .and. lat<ph1 ) then
4051  u_jet = (umax/en)*exp( 1./( (lat-ph0)*(lat-ph1) ) )
4052  else
4053  u_jet = 0.
4054  endif
4055  end function u_jet
4056 
4057  subroutine get_case9_b(B, agrid)
4058  real, intent(OUT) :: B(isd:ied,jsd:jed)
4059  real, intent(IN) :: agrid(isd:ied,jsd:jed,2)
4060  real :: myC,yy,myB
4061  integer :: i,j
4062 ! Generate B forcing function
4063 !
4064  gh0 = 720.*grav
4065  do j=jsd,jed
4066  do i=isd,ied
4067  if (sin(agrid(i,j,2)) > 0.) then
4068  myc = sin(agrid(i,j,1))
4069  yy = (cos(agrid(i,j,2))/sin(agrid(i,j,2)))**2
4070  myb = gh0*yy*exp(1.-yy)
4071  b(i,j) = myb*myc
4072  else
4073  b(i,j) = 0.
4074  endif
4075  enddo
4076  enddo
4077 
4078  end subroutine get_case9_b
4079 !
4080 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4081 !-------------------------------------------------------------------------------
4082 
4083 !-------------------------------------------------------------------------------
4084 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4085 !
4086  subroutine case9_forcing1(phis,time_since_start)
4087 
4088  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4089  real , intent(IN) :: time_since_start
4090  real :: tday, amean
4091  integer :: i,j
4092 !
4093 ! Generate B forcing function
4094 !
4095  tday = time_since_start/86400.0
4096  if (tday >= 20.) then
4097  aoft(2) = 0.5*(1.-cos(0.25*pi*(tday-20)))
4098  if (tday == 24) aoft(2) = 1.0
4099  elseif (tday <= 4.) then
4100  aoft(2) = 0.5*(1.-cos(0.25*pi*tday))
4101  elseif (tday <= 16.) then
4102  aoft(2) = 1.
4103  else
4104  aoft(2) = 0.5*(1.+cos(0.25*pi*(tday-16.)))
4105  endif
4106  amean = 0.5*(aoft(1)+aoft(2))
4107  do j=jsd,jed
4108  do i=isd,ied
4109  phis(i,j) = amean*case9_b(i,j)
4110  enddo
4111  enddo
4112 
4113  end subroutine case9_forcing1
4114 !
4115 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4116 !-------------------------------------------------------------------------------
4117 
4118 !-------------------------------------------------------------------------------
4119 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4120 !
4121  subroutine case9_forcing2(phis)
4122  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4123  integer :: i,j
4124 !
4125 ! Generate B forcing function
4126 !
4127  do j=jsd,jed
4128  do i=isd,ied
4129  phis(i,j) = aoft(2)*case9_b(i,j)
4130  enddo
4131  enddo
4132  aoft(1) = aoft(2)
4133 
4134  end subroutine case9_forcing2
4135 !
4136 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4137 !-------------------------------------------------------------------------------
4138 
4139  subroutine case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain)
4140 
4141  real, intent(INOUT) :: delp(isd:ied,jsd:jed,npz)
4142  real, intent(INOUT) :: uc(isd:ied+1,jsd:jed,npz)
4143  real, intent(INOUT) :: vc(isd:ied,jsd:jed+1,npz)
4144  real, intent(INOUT) :: u(isd:ied,jsd:jed+1,npz)
4145  real, intent(INOUT) :: v(isd:ied+1,jsd:jed,npz)
4146  real, intent(INOUT) :: ua(isd:ied,jsd:jed,npz)
4147  real, intent(INOUT) :: va(isd:ied,jsd:jed,npz)
4148  real, intent(INOUT) :: pe(is-1:ie+1, npz+1,js-1:je+1) ! edge pressure (pascal)
4149  real, intent(IN) :: time, dt
4150  real, intent(INOUT) :: ptop
4151  integer, intent(IN) :: npx, npy, npz
4152  type(fv_grid_type), intent(IN), target :: gridstruct
4153  type(domain2d), intent(INOUT) :: domain
4154 
4155  real :: period
4156  real :: omega0
4157 
4158  integer :: i,j,k
4159 
4160  real :: s, l, dt2, v0, phase
4161  real :: ull, vll, lonp
4162  real :: p0(2), elon(3), elat(3)
4163 
4164  real :: psi(isd:ied,jsd:jed)
4165  real :: psi_b(isd:ied+1,jsd:jed+1)
4166  real :: dist, psi1, psi2
4167 
4168  real :: k_cell = 5
4169 
4170  real :: utmp, vtmp
4171  real(kind=R_GRID) :: e1(3), e2(3), ex(3), ey(3), pt(2), p1(2), p2(2), p3(2), rperiod, timefac, t00
4172 
4173  integer :: wind_field = 1 !Should be the same as tracer_test
4174 
4175  real(kind=R_GRID), pointer, dimension(:,:,:) :: agrid, grid
4176  real, pointer, dimension(:,:) :: dx, dxa, dy, dya, dxc, dyc
4177 
4178  agrid => gridstruct%agrid_64
4179  grid => gridstruct%grid_64
4180 
4181  dx => gridstruct%dx
4182  dxa => gridstruct%dxa
4183  dxc => gridstruct%dxc
4184  dy => gridstruct%dy
4185  dya => gridstruct%dya
4186  dyc => gridstruct%dyc
4187 
4188  period = real( 12*24*3600 ) !12 days
4189 
4190  l = 2.*pi/period
4191  dt2 = dt*0.5
4192 
4193  phase = pi*time/period
4194 
4195  !call prt_maxmin('pe', pe, is, ie, js, je, 0, npz, 1.E-3)
4196 
4197  !Winds: NONDIVERGENT---just use streamfunction!
4198 
4199  psi(:,:) = 1.e25
4200  psi_b(:,:) = 1.e25
4201 
4202 
4203  select case (wind_field)
4204  case (0)
4205 
4206  omega0 = 23000.*pi/period
4207 
4208  t00 = 300.
4209  ptop = 100000.*exp(-12000.*grav/t00/rdgas)
4210 
4211  do j=js,je
4212  do k=1,npz+1
4213  do i=is,ie
4214  s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4215  pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4216  cos(period*(time+dt2))*sin(s*0.5*pi)
4217  enddo
4218  enddo
4219  enddo
4220 
4221  do k=1,npz
4222  do j=js,je
4223  do i=is,ie
4224  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4225  enddo
4226  enddo
4227  enddo
4228 
4229  v0 = 10.*radius/period !k in DCMIP document
4230  ubar = 40.
4231 
4232  do j=jsd,jed
4233  do i=isd,ied
4234  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
4235  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
4236  enddo
4237  enddo
4238  call mpp_update_domains( psi, domain )
4239  do j=jsd,jed+1
4240  do i=isd,ied+1
4241  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
4242  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
4243  enddo
4244  enddo
4245 
4246  k = 1
4247 
4248  do j=js,je+1
4249  do i=is,ie
4250  dist = dx(i,j)
4251  vc(i,j,k) = (psi_b(i+1,j)-psi_b(i,j))/dist
4252  if (dist==0) vc(i,j,k) = 0.
4253  enddo
4254  enddo
4255  do j=js,je
4256  do i=is,ie+1
4257  dist = dy(i,j)
4258  uc(i,j,k) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
4259  if (dist==0) uc(i,j,k) = 0.
4260  enddo
4261  enddo
4262 
4263  do j=js,je
4264  do i=is,ie+1
4265  dist = dxc(i,j)
4266  v(i,j,k) = (psi(i,j)-psi(i-1,j))/dist
4267  if (dist==0) v(i,j,k) = 0.
4268  enddo
4269  enddo
4270  do j=js,je+1
4271  do i=is,ie
4272  dist = dyc(i,j)
4273  u(i,j,k) = -1.0*(psi(i,j)-psi(i,j-1))/dist
4274  if (dist==0) u(i,j,k) = 0.
4275  enddo
4276  enddo
4277 
4278  do j=js,je
4279  do i=is,ie
4280  psi1 = 0.5*(psi(i,j)+psi(i,j-1))
4281  psi2 = 0.5*(psi(i,j)+psi(i,j+1))
4282  dist = dya(i,j)
4283  ua(i,j,k) = -1.0 * (psi2 - psi1) / (dist)
4284  if (dist==0) ua(i,j,k) = 0.
4285  psi1 = 0.5*(psi(i,j)+psi(i-1,j))
4286  psi2 = 0.5*(psi(i,j)+psi(i+1,j))
4287  dist = dxa(i,j)
4288  va(i,j,k) = (psi2 - psi1) / (dist)
4289  if (dist==0) va(i,j,k) = 0.
4290  enddo
4291  enddo
4292 
4293  case (1)
4294 
4295  omega0 = 23000.*pi/period
4296 
4297  do j=js,je
4298  do k=1,npz+1
4299  do i=is,ie
4300  s = min(1.,2.*sqrt(sin((pe(i,k,j)-ptop)/(pe(i,npz+1,j)-ptop)*pi)))
4301  pe(i,k,j) = pe(i,k,j) + dt*omega0*sin(agrid(i,j,1)-period*(time+dt2))*cos(agrid(i,j,2))* &
4302  cos(period*(time+dt2))*sin(s*0.5*pi)
4303  enddo
4304  enddo
4305  enddo
4306 
4307  do k=1,npz
4308  do j=js,je
4309  do i=is,ie
4310  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4311  enddo
4312  enddo
4313  enddo
4314 
4315  ubar = 10.*radius/period !k in DCMIP document
4316 
4317 
4318  do j=js,je
4319  do i=is,ie+1
4320  p1(:) = grid(i ,j ,1:2)
4321  p2(:) = grid(i,j+1 ,1:2)
4322  call mid_pt_sphere(p1, p2, p3)
4323  call get_unit_vect2(p1, p2, e2) !! e2 is WRONG in halo??
4324  call get_latlon_vector(p3, ex, ey)
4325  l = p3(1) - 2.*pi*time/period
4326  utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*radius/period*cos(p3(2))
4327  vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4328  v(i,j,1) = utmp*inner_prod(e2,ex) + vtmp*inner_prod(e2,ey)
4329  enddo
4330  enddo
4331  do j=js,je+1
4332  do i=is,ie
4333  p1(:) = grid(i, j,1:2)
4334  p2(:) = grid(i+1,j,1:2)
4335  call mid_pt_sphere(p1, p2, p3)
4336  call get_unit_vect2(p1, p2, e1)
4337  call get_latlon_vector(p3, ex, ey)
4338  l = p3(1) - 2.*pi*time/period
4339  utmp = ubar * sin(l)**2 * sin(2.*p3(2)) * cos(pi*time/period) + 2.*pi*radius/period*cos(p3(2))
4340  vtmp = ubar * sin(2.*l) * cos(p3(2)) * cos(pi*time/period)
4341  u(i,j,1) = utmp*inner_prod(e1,ex) + vtmp*inner_prod(e1,ey)
4342  enddo
4343  enddo
4344 
4345  call mp_update_dwinds(u(:,:,1), v(:,:,1), npx, npy, domain)
4346 
4347 ! copy vertically; no wind shear
4348  do k=2,npz
4349  do j=jsd,jed+1
4350  do i=isd,ied
4351  u(i,j,k) = u(i,j,1)
4352  enddo
4353  enddo
4354  do j=jsd,jed
4355  do i=isd,ied+1
4356  v(i,j,k) = v(i,j,1)
4357  enddo
4358  enddo
4359  enddo
4360 
4361  call mp_update_dwinds(u, v, npx, npy, npz, domain)
4362 
4363  call dtoa( u(:,:,1), v(:,:,1),ua(:,:,1),va(:,:,1),dx,dy,dxa,dya,dxc,dyc,npx,npy,ng)
4364  call mpp_update_domains( ua, va, domain, gridtype=agrid_param) !! ABSOLUTELY NECESSARY!!
4365  call atoc(ua(:,:,1),va(:,:,1),uc(:,:,1),vc(:,:,1),dx,dy,dxa,dya,npx,npy,ng, gridstruct%nested, domain)
4366 
4367  do k=2,npz
4368  do j=js,je
4369  do i=is,ie
4370  ua(i,j,k) = ua(i,j,1)
4371  enddo
4372  enddo
4373  do j=js,je
4374  do i=is,ie
4375  va(i,j,k) = va(i,j,1)
4376  enddo
4377  enddo
4378  enddo
4379 
4380  do k=2,npz
4381  do j=js,je+1
4382  do i=is,ie
4383  vc(i,j,k) = vc(i,j,1)
4384  enddo
4385  enddo
4386  do j=js,je
4387  do i=is,ie+1
4388  uc(i,j,k) = uc(i,j,1)
4389  enddo
4390  enddo
4391  enddo
4392 
4393  !cases 2 and 3 are not nondivergent so we cannot use a streamfunction.
4394  case (2)
4395 
4396  omega0 = 0.25
4397 
4398  do j=js,je
4399  do k=1,npz+1
4400  do i=is,ie
4401  pe(i,k,j) = pe(i,k,j) + dt*omega0*grav*pe(i,k,j)/rdgas/300./k_cell* &
4402  (-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)))* &
4403  sin(pi*zz0(k)/12000.)*cos(phase)
4404  enddo
4405  enddo
4406  enddo
4407 
4408  do k=1,npz
4409  do j=js,je
4410  do i=is,ie
4411  delp(i,j,k) = pe(i,k+1,j) - pe(i,k,j)
4412  enddo
4413  enddo
4414  enddo
4415 
4416  ubar = 40.
4417 
4418  !Set lat-lon A-grid winds
4419  k = 1
4420  do j=js,je
4421  do i=is,ie
4422  utmp = ubar*cos(agrid(i,j,2))
4423  vtmp = - radius * omega0 * pi / k_cell / 12000. * &
4424  cos(agrid(i,j,2)) * sin(k_cell * agrid(i,j,2)) * &
4425  sin(pi*zz0(k)/12000.)*cos(phase)
4426  enddo
4427  enddo
4428 
4429  end select
4430 
4431  do k=2,npz
4432  u(:,:,k) = u(:,:,1)
4433  v(:,:,k) = v(:,:,1)
4434  uc(:,:,k) = uc(:,:,1)
4435  vc(:,:,k) = vc(:,:,1)
4436  ua(:,:,k) = ua(:,:,1)
4437  va(:,:,k) = va(:,:,1)
4438  enddo
4439 
4440  call mpp_update_domains( uc, vc, domain, gridtype=cgrid_ne_param)
4441  call fill_corners(uc, vc, npx, npy, npz, vector=.true., cgrid=.true.)
4442  call mp_update_dwinds(u, v, npx, npy, npz, domain)
4443 
4444  nullify(agrid)
4445  nullify(grid)
4446 
4447  nullify(dx)
4448  nullify(dxa)
4449  nullify(dy)
4450  nullify(dya)
4451 
4452  end subroutine case51_forcing
4453 
4454 !-------------------------------------------------------------------------------
4455 !
4456 ! get_stats :: get L-1, L-2, and L-inf norms and other stats as defined
4457 ! in Williamson, 1994 (p.16)
4458  subroutine get_stats(dt, dtout, nt, maxnt, ndays, u,v,pt,delp,q,phis, ps, &
4459  uc,vc, ua,va, npx, npy, npz, ncnst, ndims, nregions, &
4460  gridstruct, stats_lun, consv_lun, monitorFreq, tile, &
4461  domain, nested)
4462  integer, intent(IN) :: nt, maxnt
4463  real , intent(IN) :: dt, dtout, ndays
4464  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
4465  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
4466  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
4467  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
4468  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
4469  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
4470  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
4471  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
4472  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
4473  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
4474  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
4475  integer, intent(IN) :: npx, npy, npz, ncnst, tile
4476  integer, intent(IN) :: ndims
4477  integer, intent(IN) :: nregions
4478  integer, intent(IN) :: stats_lun
4479  integer, intent(IN) :: consv_lun
4480  integer, intent(IN) :: monitorfreq
4481  type(fv_grid_type), target :: gridstruct
4482  type(domain2d), intent(INOUT) :: domain
4483  logical, intent(IN) :: nested
4484 
4485  real :: l1_norm
4486  real :: l2_norm
4487  real :: linf_norm
4488  real :: pmin, pmin1, uamin1, vamin1
4489  real :: pmax, pmax1, uamax1, vamax1
4490  real(kind=4) :: arr_r4(5)
4491  real :: tmass0, tvort0, tener0, tke0
4492  real :: tmass, tvort, tener, tke
4493  real :: temp(is:ie,js:je)
4494  integer :: i0, j0, k0, n0
4495  integer :: i, j, k, n, iq
4496 
4497  real :: psmo, vtx, p, w_p, p0
4498  real :: x1,y1,z1,x2,y2,z2,ang
4499 
4500  real :: p1(2), p2(2), p3(2), r, r0, dist, heading
4501 
4502  real :: uc0(isd:ied+1,jsd:jed ,npz)
4503  real :: vc0(isd:ied ,jsd:jed+1,npz)
4504 
4505  real :: myday
4506  integer :: myrec
4507 
4508  real, save, allocatable, dimension(:,:,:) :: u0, v0
4509  real :: up(isd:ied ,jsd:jed+1,npz)
4510  real :: vp(isd:ied+1,jsd:jed ,npz)
4511 
4512  real, dimension(:,:,:), pointer :: grid, agrid
4513  real, dimension(:,:), pointer :: area, f0, dx, dy, dxa, dya, dxc, dyc
4514 
4515  grid => gridstruct%grid
4516  agrid=> gridstruct%agrid
4517 
4518  area => gridstruct%area
4519  f0 => gridstruct%f0
4520 
4521  dx => gridstruct%dx
4522  dy => gridstruct%dy
4523  dxa => gridstruct%dxa
4524  dya => gridstruct%dya
4525  dxc => gridstruct%dxc
4526  dyc => gridstruct%dyc
4527 
4528  !!! DEBUG CODE
4529  if (nt == 0 .and. is_master()) print*, 'INITIALIZING GET_STATS'
4530  !!! END DEBUG CODE
4531 
4532  myday = ndays*((float(nt)/float(maxnt)))
4533 
4534 #if defined(SW_DYNAMICS)
4535  if (test_case==0) then
4536  phi0 = 0.0
4537  do j=js,je
4538  do i=is,ie
4539  x1 = agrid(i,j,1)
4540  y1 = agrid(i,j,2)
4541  z1 = radius
4542  p = p0_c0 * cos(y1)
4543  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
4544  w_p = 0.0
4545  if (p /= 0.0) w_p = vtx/p
4546  ! delp(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4547  phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
4548  enddo
4549  enddo
4550  elseif (test_case==1) then
4551 ! Get Current Height Field "Truth"
4552  p1(1) = pi/2. + pi_shift
4553  p1(2) = 0.
4554  p2(1) = 3.*pi/2. + pi_shift
4555  p2(2) = 0.
4556  r0 = radius/3. !RADIUS 3.
4557  dist = 2.0*pi*radius* ((float(nt)/float(maxnt)))
4558  heading = 3.0*pi/2.0 - alpha !5.0*pi/2.0 - alpha
4559  call get_pt_on_great_circle( p1, p2, dist, heading, p3)
4560  phi0 = 0.0
4561  do j=js,je
4562  do i=is,ie
4563  p2(1) = agrid(i,j,1)
4564  p2(2) = agrid(i,j,2)
4565  r = great_circle_dist( p3, p2, radius )
4566  if (r < r0) then
4567  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
4568  else
4569  phi0(i,j,1) = phis(i,j)
4570  endif
4571  enddo
4572  enddo
4573  endif
4574 
4575 ! Get Height Field Stats
4576  call pmxn(delp(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4577  pmin1=pmin1/grav
4578  pmax1=pmax1/grav
4579  if (test_case <= 2) then
4580  call get_scalar_stats( delp(:,:,1), phi0(:,:,1), npx, npy, ndims, nregions, &
4581  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
4582  pmin=pmin/grav
4583  pmax=pmax/grav
4584  arr_r4(1) = pmin1
4585  arr_r4(2) = pmax1
4586  arr_r4(3) = l1_norm
4587  arr_r4(4) = l2_norm
4588  arr_r4(5) = linf_norm
4589  !if (is_master()) write(stats_lun,rec=(nt)*2 + 1) arr_r4
4590  else
4591  arr_r4(1) = pmin1
4592  arr_r4(2) = pmax1
4593  arr_r4(3:5) = 0.
4594  pmin = 0.
4595  pmax = 0.
4596  l1_norm = 0.
4597  l2_norm = 0.
4598  linf_norm = 0.
4599  endif
4600 
4601  200 format(i6.6,a,i6.6,a,e21.14)
4602  201 format(' ',a,e21.14,' ',e21.14)
4603  202 format(' ',a,i4.4,'x',i4.4,'x',i4.4)
4604 
4605  if ( (is_master()) .and. mod(nt,monitorfreq)==0 ) then
4606  write(*,200) nt, ' step of ', maxnt, ' DAY ', myday
4607  write(*,201) 'Height MAX : ', pmax1
4608  write(*,201) 'Height MIN : ', pmin1
4609  write(*,202) 'HGT MAX location : ', i0, j0, n0
4610  if (test_case <= 2) then
4611  write(*,201) 'Height L1_norm : ', l1_norm
4612  write(*,201) 'Height L2_norm : ', l2_norm
4613  write(*,201) 'Height Linf_norm : ', linf_norm
4614  endif
4615  endif
4616 
4617 ! Get UV Stats
4618  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
4619  call pmxn(ua(:,:,1), npx, npy, nregions, tile, gridstruct, pmin1, pmax1, i0, j0, n0)
4620  if (test_case <= 2) then
4621  call get_vector_stats( ua(:,:,1), ua0(:,:,1), va(:,:,1), va0(:,:,1), npx, npy, ndims, nregions, &
4622  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
4623  endif
4624  arr_r4(1) = pmin1
4625  arr_r4(2) = pmax1
4626  arr_r4(3) = l1_norm
4627  arr_r4(4) = l2_norm
4628  arr_r4(5) = linf_norm
4629  !if (is_master()) write(stats_lun,rec=(nt)*2 + 2) arr_r4
4630  if ( (is_master()) .and. mod(nt,monitorfreq)==0) then
4631  write(*,201) 'UV MAX : ', pmax1
4632  write(*,201) 'UV MIN : ', pmin1
4633  write(*,202) 'UV MAX location : ', i0, j0, n0
4634  if (test_case <= 2) then
4635  write(*,201) 'UV L1_norm : ', l1_norm
4636  write(*,201) 'UV L2_norm : ', l2_norm
4637  write(*,201) 'UV Linf_norm : ', linf_norm
4638  endif
4639  endif
4640 #else
4641 
4642  200 format(i6.6,a,i6.6,a,e10.4)
4643  201 format(' ',a,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4644  202 format(' ',a,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4,' ',e10.4)
4645  203 format(' ',a,i3.3,a,e10.4,' ',e10.4,' ',i4.4,'x',i4.4,'x',i4.4,'x',i4.4)
4646 
4647  if(is_master()) write(*,200) nt, ' step of ', maxnt, ' DAY ', myday
4648 
4649 ! Surface Pressure
4650  psmo = globalsum(ps(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4651  if(is_master()) write(*,*) ' Total surface pressure =', 0.01*psmo
4652  call pmxn(ps, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4653  if (is_master()) then
4654  write(*,201) 'PS MAX|MIN : ', 0.01*pmax, 0.01*pmin, i0, j0, n0
4655  endif
4656 
4657 ! Get PT Stats
4658  pmax1 = -1.e25
4659  pmin1 = 1.e25
4660  i0=-999
4661  j0=-999
4662  k0=-999
4663  n0=-999
4664  do k=1,npz
4665  call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4666  pmin1 = min(pmin, pmin1)
4667  pmax1 = max(pmax, pmax1)
4668  if (pmax1 == pmax) k0 = k
4669  enddo
4670  if (is_master()) then
4671  write(*,201) 'PT MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4672  endif
4673 
4674 #if defined(DEBUG_TEST_CASES)
4675  if(is_master()) write(*,*) ' '
4676  do k=1,npz
4677  pmax1 = -1.e25
4678  pmin1 = 1.e25
4679  i0=-999
4680  j0=-999
4681  k0=-999
4682  n0=-999
4683  call pmxn(pt(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4684  pmin1 = min(pmin, pmin1)
4685  pmax1 = max(pmax, pmax1)
4686  if (is_master()) then
4687  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) )
4688  endif
4689  enddo
4690  if(is_master()) write(*,*) ' '
4691 #endif
4692 
4693 ! Get DELP Stats
4694  pmax1 = -1.e25
4695  pmin1 = 1.e25
4696  i0=-999
4697  j0=-999
4698  k0=-999
4699  n0=-999
4700  do k=1,npz
4701  call pmxn(delp(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4702  pmin1 = min(pmin, pmin1)
4703  pmax1 = max(pmax, pmax1)
4704  if (pmax1 == pmax) k0 = k
4705  enddo
4706  if (is_master()) then
4707  write(*,201) 'Delp MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4708  endif
4709 
4710 ! Get UV Stats
4711  uamax1 = -1.e25
4712  uamin1 = 1.e25
4713  i0=-999
4714  j0=-999
4715  k0=-999
4716  n0=-999
4717  do k=1,npz
4718  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)
4719  call pmxn(ua(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4720  uamin1 = min(pmin, uamin1)
4721  uamax1 = max(pmax, uamax1)
4722  if (uamax1 == pmax) k0 = k
4723  enddo
4724  if (is_master()) then
4725  write(*,201) 'U MAX|MIN : ', uamax1, uamin1, i0, j0, k0, n0
4726  endif
4727 
4728  vamax1 = -1.e25
4729  vamin1 = 1.e25
4730  i0=-999
4731  j0=-999
4732  k0=-999
4733  n0=-999
4734  do k=1,npz
4735  call pmxn(va(:,:,k), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4736  vamin1 = min(pmin, vamin1)
4737  vamax1 = max(pmax, vamax1)
4738  if (vamax1 == pmax) k0 = k
4739  enddo
4740  if (is_master()) then
4741  write(*,201) 'V MAX|MIN : ', vamax1, vamin1, i0, j0, k0, n0
4742  endif
4743 
4744 ! Get Q Stats
4745  pmax1 = -1.e25
4746  pmin1 = 1.e25
4747  i0=-999
4748  j0=-999
4749  k0=-999
4750  n0=-999
4751  do k=1,npz
4752  call pmxn(q(isd,jsd,k,1), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4753  pmin1 = min(pmin, pmin1)
4754  pmax1 = max(pmax, pmax1)
4755  if (pmax1 == pmax) k0 = k
4756  enddo
4757  if (is_master()) then
4758  write(*,201) 'Q MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4759  endif
4760 
4761 ! Get tracer Stats
4762  do iq=2,ncnst
4763  pmax1 = -1.e25
4764  pmin1 = 1.e25
4765  i0=-999
4766  j0=-999
4767  k0=-999
4768  n0=-999
4769  do k=1,npz
4770  call pmxn(q(isd,jsd,k,iq), npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
4771  pmin1 = min(pmin, pmin1)
4772  pmax1 = max(pmax, pmax1)
4773  if (pmax1 == pmax) k0 = k
4774  enddo
4775  if (is_master()) then
4776  write(*,203) 'TR',iq-1,' MAX|MIN : ', pmax1, pmin1, i0, j0, k0, n0
4777  endif
4778  enddo
4779 
4780 #endif
4781 
4782  if (test_case == 12) then
4783 ! Get UV Stats
4784  call get_vector_stats( ua(:,:,22), ua0(:,:,22), va(:,:,22), va0(:,:,22), npx, npy, ndims, nregions, &
4785  pmin, pmax, l1_norm, l2_norm, linf_norm, gridstruct, tile)
4786  if (is_master()) then
4787  write(*,201) 'UV(850) L1_norm : ', l1_norm
4788  write(*,201) 'UV(850) L2_norm : ', l2_norm
4789  write(*,201) 'UV(850) Linf_norm : ', linf_norm
4790  endif
4791  endif
4792 
4793  tmass = 0.0
4794  tke = 0.0
4795  tener = 0.0
4796  tvort = 0.0
4797 #if defined(SW_DYNAMICS)
4798  do k=1,1
4799 #else
4800  do k=1,npz
4801 #endif
4802 ! Get conservation Stats
4803 
4804 ! Conservation of Mass
4805  temp(:,:) = delp(is:ie,js:je,k)
4806  tmass0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4807  tmass = tmass + tmass0
4808 
4809  !if (.not. allocated(u0, v0)) then
4810  if (nt == 0) then
4811  allocate(u0(isd:ied,jsd:jed+1,npz))
4812  allocate(v0(isd:ied+1,jsd:jed,npz))
4813  u0 = u
4814  v0 = v
4815  endif
4816 
4817  !! UA is the PERTURBATION now
4818  up = u - u0
4819  vp = v - v0
4820 
4821  call dtoa(up(isd,jsd,k), vp(isd,jsd,k), ua, va, dx,dy, dxa, dya, dxc, dyc, npx, npy, ng)
4822  call atoc(ua(isd,jsd,k),va(isd,jsd,k),uc0(isd,jsd,k),vc0(isd,jsd,k),dx,dy,dxa,dya,npx,npy,ng,nested, domain, nocomm=.true.)
4823 ! Conservation of Kinetic Energy
4824  do j=js,je
4825  do i=is,ie
4826  temp(i,j) = ( uc0(i,j,k)*uc0(i,j,k) + uc0(i+1,j,k)*uc0(i+1,j,k) + &
4827  vc0(i,j,k)*vc0(i,j,k) + vc0(i,j+1,k)*vc0(i,j+1,k) )
4828  enddo
4829  enddo
4830  tke0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4831  tke = tke + tke0
4832 
4833 ! Conservation of Energy
4834  do j=js,je
4835  do i=is,ie
4836  temp(i,j) = 0.5 * (delp(i,j,k)/grav) * temp(i,j) ! Include Previously calcullated KE
4837  temp(i,j) = temp(i,j) + &
4838  grav*((delp(i,j,k)/grav + phis(i,j))*(delp(i,j,k)/grav + phis(i,j))) - &
4839  phis(i,j)*phis(i,j)
4840  enddo
4841  enddo
4842  tener0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4843  tener = tener + tener0
4844 
4845 ! Conservation of Potential Enstrophy
4846  if (test_case>1) then
4847  do j=js,je
4848  do i=is,ie
4849  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)) - &
4850  (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
4851  temp(i,j) = ( grav*(temp(i,j)*temp(i,j))/delp(i,j,k) )
4852  enddo
4853  enddo
4854  tvort0 = globalsum(temp, npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4855  tvort = tvort + tvort0
4856  else
4857  tvort=1.
4858  endif
4859  enddo
4860 
4861  if (nt == 0) then
4862  tmass_orig = tmass
4863  tener_orig = tener
4864  tvort_orig = tvort
4865  endif
4866  arr_r4(1) = (tmass-tmass_orig)/tmass_orig
4867  arr_r4(2) = (tener-tener_orig)/tener_orig
4868  arr_r4(3) = (tvort-tvort_orig)/tvort_orig
4869  arr_r4(4) = tke
4870  if (test_case==12) arr_r4(4) = l2_norm
4871 #if defined(SW_DYNAMICS)
4872  myrec = nt+1
4873 #else
4874  myrec = myday*86400.0/dtout + 1
4875 #endif
4876  if (is_master()) write(consv_lun,rec=myrec) arr_r4(1:4)
4877 #if defined(SW_DYNAMICS)
4878  if ( (is_master()) .and. mod(nt,monitorfreq)==0) then
4879 #else
4880  if ( (is_master()) ) then
4881 #endif
4882  write(*,201) 'MASS TOTAL : ', tmass
4883  write(*,201) 'NORMALIZED MASS : ', (tmass-tmass_orig)/tmass_orig
4884  if (test_case >= 2) then
4885  write(*,201) 'Kinetic Energy KE : ', tke
4886  write(*,201) 'ENERGY TOTAL : ', tener
4887  write(*,201) 'NORMALIZED ENERGY : ', (tener-tener_orig)/tener_orig
4888  write(*,201) 'ENSTR TOTAL : ', tvort
4889  write(*,201) 'NORMALIZED ENSTR : ', (tvort-tvort_orig)/tvort_orig
4890  endif
4891  write(*,*) ' '
4892  endif
4893 
4894  nullify(grid)
4895  nullify(agrid)
4896  nullify(area)
4897  nullify(f0)
4898  nullify(dx)
4899  nullify(dy)
4900 
4901  end subroutine get_stats
4902 
4903 
4904 
4905  subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
4906 ! get_pt_on_great_circle :: Get the mid-point on a great circle given:
4907 ! -2 points (Lon/Lat) to define a great circle
4908 ! -Great Cirle distance between 2 defining points
4909 ! -Heading
4910 ! compute:
4911 ! Arrival Point (Lon/Lat)
4912 
4913  real , intent(IN) :: p1(2), p2(2)
4914  real , intent(IN) :: dist
4915  real , intent(IN) :: heading
4916  real , intent(OUT) :: p3(2)
4917 
4918  real pha, dp
4919 
4920  pha = dist/radius
4921 
4922  p3(2) = asin( (cos(heading)*cos(p1(2))*sin(pha)) + (sin(p1(2))*cos(pha)) )
4923  dp = atan2( sin(heading)*sin(pha)*cos(p1(2)) , cos(pha) - sin(p1(2))*sin(p3(2)) )
4924  p3(1) = mod( (p1(1)-pi)-dp+pi , 2.*pi ) !- pi Leave at 0 to 360
4925 
4926  end subroutine get_pt_on_great_circle
4927 
4928 
4929 !
4930 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
4931 !-------------------------------------------------------------------------------
4932 
4933 !-------------------------------------------------------------------------------
4934 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
4935 !
4936 ! get_scalar_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
4937 ! in Williamson, 1994 (p.16)
4938 ! for any var
4939 
4940  subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, &
4941  vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
4942  integer, intent(IN) :: npx, npy
4943  integer, intent(IN) :: ndims
4944  integer, intent(IN) :: nregions, tile
4945  real , intent(IN) :: var(isd:ied,jsd:jed)
4946  real , intent(IN) :: varT(isd:ied,jsd:jed)
4947  real , intent(OUT) :: vmin
4948  real , intent(OUT) :: vmax
4949  real , intent(OUT) :: L1_norm
4950  real , intent(OUT) :: L2_norm
4951  real , intent(OUT) :: Linf_norm
4952 
4953  type(fv_grid_type), target :: gridstruct
4954 
4955  real :: vmean
4956  real :: vvar
4957  real :: vmin1
4958  real :: vmax1
4959  real :: pdiffmn
4960  real :: pdiffmx
4961 
4962  real :: varSUM, varSUM2, varMAX
4963  real :: gsum
4964  real :: vminT, vmaxT, vmeanT, vvarT
4965  integer :: i0, j0, n0
4966 
4967  real, dimension(:,:,:), pointer :: grid, agrid
4968  real, dimension(:,:), pointer :: area
4969 
4970  grid => gridstruct%grid
4971  agrid=> gridstruct%agrid
4972 
4973  area => gridstruct%area
4974 
4975  varsum = 0.
4976  varsum2 = 0.
4977  varmax = 0.
4978  l1_norm = 0.
4979  l2_norm = 0.
4980  linf_norm = 0.
4981  vmean = 0.
4982  vvar = 0.
4983  vmax = 0.
4984  vmin = 0.
4985  pdiffmn= 0.
4986  pdiffmx= 0.
4987  vmeant = 0.
4988  vvart = 0.
4989  vmaxt = 0.
4990  vmint = 0.
4991 
4992  vmean = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4993  vmeant = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
4994  vmean = vmean / (4.0*pi)
4995  vmeant = vmeant / (4.0*pi)
4996 
4997  call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin , vmax , i0, j0, n0)
4998  call pmxn(vart, npx, npy, nregions, tile, gridstruct, vmint, vmaxt, i0, j0, n0)
4999  call pmxn(var-vart, npx, npy, nregions, tile, gridstruct, pdiffmn, pdiffmx, i0, j0, n0)
5000 
5001  vmax = (vmax - vmaxt) / (vmaxt-vmint)
5002  vmin = (vmin - vmint) / (vmaxt-vmint)
5003 
5004  varsum = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5005  varsum2 = globalsum(vart(is:ie,js:je)**2., npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5006  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)
5007  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)
5008  l1_norm = l1_norm/varsum
5009  l2_norm = sqrt(l2_norm)/sqrt(varsum2)
5010 
5011  call pmxn(abs(vart), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5012  varmax = vmax
5013  call pmxn(abs(var-vart), npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5014  linf_norm = vmax/varmax
5015 
5016  end subroutine get_scalar_stats
5017 !
5018 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5019 !-------------------------------------------------------------------------------
5020 
5021 !-------------------------------------------------------------------------------
5022 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5023 !
5024 ! get_vector_stats: get L-1, L-2, and L-inf norms and min/max stats as defined
5025 ! in Williamson, 1994 (p.16)
5026 ! for any var
5027 
5028  subroutine get_vector_stats(varU, varUT, varV, varVT, &
5029  npx, npy, ndims, nregions, &
5030  vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
5031  integer, intent(IN) :: npx, npy
5032  integer, intent(IN) :: ndims
5033  integer, intent(IN) :: nregions, tile
5034  real , intent(IN) :: varU(isd:ied,jsd:jed)
5035  real , intent(IN) :: varUT(isd:ied,jsd:jed)
5036  real , intent(IN) :: varV(isd:ied,jsd:jed)
5037  real , intent(IN) :: varVT(isd:ied,jsd:jed)
5038  real , intent(OUT) :: vmin
5039  real , intent(OUT) :: vmax
5040  real , intent(OUT) :: L1_norm
5041  real , intent(OUT) :: L2_norm
5042  real , intent(OUT) :: Linf_norm
5043 
5044  real :: var(isd:ied,jsd:jed)
5045  real :: varT(isd:ied,jsd:jed)
5046  real :: vmean
5047  real :: vvar
5048  real :: vmin1
5049  real :: vmax1
5050  real :: pdiffmn
5051  real :: pdiffmx
5052 
5053  real :: varSUM, varSUM2, varMAX
5054  real :: gsum
5055  real :: vminT, vmaxT, vmeanT, vvarT
5056  integer :: i,j,n
5057  integer :: i0, j0, n0
5058 
5059  type(fv_grid_type), target :: gridstruct
5060 
5061  real, dimension(:,:,:), pointer :: grid, agrid
5062  real, dimension(:,:), pointer :: area
5063 
5064  grid => gridstruct%grid
5065  agrid=> gridstruct%agrid
5066 
5067  area => gridstruct%area
5068 
5069  varsum = 0.
5070  varsum2 = 0.
5071  varmax = 0.
5072  l1_norm = 0.
5073  l2_norm = 0.
5074  linf_norm = 0.
5075  vmean = 0.
5076  vvar = 0.
5077  vmax = 0.
5078  vmin = 0.
5079  pdiffmn= 0.
5080  pdiffmx= 0.
5081  vmeant = 0.
5082  vvart = 0.
5083  vmaxt = 0.
5084  vmint = 0.
5085 
5086  do j=js,je
5087  do i=is,ie
5088  var(i,j) = sqrt( (varu(i,j)-varut(i,j))**2. + &
5089  (varv(i,j)-varvt(i,j))**2. )
5090  vart(i,j) = sqrt( varut(i,j)*varut(i,j) + &
5091  varvt(i,j)*varvt(i,j) )
5092  enddo
5093  enddo
5094  varsum = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5095  l1_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5096  l1_norm = l1_norm/varsum
5097 
5098  call pmxn(vart, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5099  varmax = vmax
5100  call pmxn(var, npx, npy, nregions, tile, gridstruct, vmin, vmax, i0, j0, n0)
5101  linf_norm = vmax/varmax
5102 
5103  do j=js,je
5104  do i=is,ie
5105  var(i,j) = ( (varu(i,j)-varut(i,j))**2. + &
5106  (varv(i,j)-varvt(i,j))**2. )
5107  vart(i,j) = ( varut(i,j)*varut(i,j) + &
5108  varvt(i,j)*varvt(i,j) )
5109  enddo
5110  enddo
5111  varsum = globalsum(vart(is:ie,js:je), npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5112  l2_norm = globalsum(var(is:ie,js:je) , npx, npy, is,ie, js,je, isd, ied, jsd, jed, gridstruct, tile)
5113  l2_norm = sqrt(l2_norm)/sqrt(varsum)
5114 
5115  end subroutine get_vector_stats
5116 !
5117 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5118 !-------------------------------------------------------------------------------
5119 
5120 !-------------------------------------------------------------------------------
5121 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5122 !
5123 ! check_courant_numbers ::
5124 !
5125  subroutine check_courant_numbers(uc,vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint)
5126 
5127  real, intent(IN) :: ndt
5128  integer, intent(IN) :: n_split
5129  integer, intent(IN) :: npx, npy, npz, tile
5130  logical, OPTIONAL, intent(IN) :: noprint
5131  real , intent(IN) :: uc(isd:ied+1,jsd:jed ,npz)
5132  real , intent(IN) :: vc(isd:ied ,jsd:jed+1,npz)
5133 
5134  real :: ideal_c=0.06
5135  real :: tolerance= 1.e-3
5136  real :: dt_inc, dt_orig
5137  real :: meancy, mincy, maxcy, meancx, mincx, maxcx
5138 
5139  real :: counter
5140  logical :: ideal
5141 
5142  integer :: i,j,k
5143  real :: dt
5144 
5145  type(fv_grid_type), intent(IN), target :: gridstruct
5146  real, dimension(:,:), pointer :: dxc, dyc
5147 
5148  dxc => gridstruct%dxc
5149  dyc => gridstruct%dyc
5150 
5151  dt = ndt/real(n_split)
5152 
5153  300 format(i4.4,' ',i4.4,' ',i4.4,' ',i4.4,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14,' ',e21.14)
5154 
5155  dt_orig = dt
5156  dt_inc = 1
5157  ideal = .false.
5158 
5159  do while(.not. ideal)
5160 
5161  counter = 0
5162  mincy = missing
5163  maxcy = -1.*missing
5164  mincx = missing
5165  maxcx = -1.*missing
5166  meancx = 0
5167  meancy = 0
5168  do k=1,npz
5169  do j=js,je
5170  do i=is,ie+1
5171  mincx = min(mincx, abs( (dt/dxc(i,j))*uc(i,j,k) ))
5172  maxcx = max(maxcx, abs( (dt/dxc(i,j))*uc(i,j,k) ))
5173  meancx = meancx + abs( (dt/dxc(i,j))*uc(i,j,k) )
5174 
5175  if (abs( (dt/dxc(i,j))*uc(i,j,k) ) > 1.0) then
5176  counter = counter+1
5177  write(*,300) i,j,k,tile, abs( (dt/dxc(i,j))*uc(i,j,k) ), dt, dxc(i,j), uc(i,j,k), counter
5178  call exit(1)
5179  endif
5180 
5181  enddo
5182  enddo
5183  do j=js,je+1
5184  do i=is,ie
5185  mincy = min(mincy, abs( (dt/dyc(i,j))*vc(i,j,k) ))
5186  maxcy = max(maxcy, abs( (dt/dyc(i,j))*vc(i,j,k) ))
5187  meancy = meancy + abs( (dt/dyc(i,j))*vc(i,j,k) )
5188 
5189  if (abs( (dt/dyc(i,j))*vc(i,j,k) ) > 1.0) then
5190  counter = counter+1
5191  write(*,300) i,j,k,tile, abs( (dt/dyc(i,j))*vc(i,j,k) ), dt, dyc(i,j), vc(i,j,k), counter
5192  call exit(1)
5193  endif
5194 
5195  enddo
5196  enddo
5197  enddo
5198 
5199  call mp_reduce_max(maxcx)
5200  call mp_reduce_max(maxcy)
5201  mincx = -mincx
5202  mincy = -mincy
5203  call mp_reduce_max(mincx)
5204  call mp_reduce_max(mincy)
5205  mincx = -mincx
5206  mincy = -mincy
5207  call mp_reduce_sum(meancx)
5208  call mp_reduce_sum(meancy)
5209  meancx = meancx/(6.0*dble(npx)*dble(npy-1))
5210  meancy = meancy/(6.0*dble(npx-1)*dble(npy))
5211 
5212  !if ( (ABS(maxCy-ideal_c) <= tolerance) .and. (ABS(maxCx-ideal_c) <= tolerance) ) then
5213  ideal = .true.
5214  !elseif (maxCy-ideal_c > 0) then
5215  ! dt = dt - dt_inc
5216  !else
5217  ! dt = dt + dt_inc
5218  !endif
5219 
5220  enddo
5221 
5222  if ( (.not. present(noprint)) .and. (is_master()) ) then
5223  print*, ''
5224  print*, '--------------------------------------------'
5225  print*, 'Y-dir Courant number MIN : ', mincy
5226  print*, 'Y-dir Courant number MAX : ', maxcy
5227  print*, ''
5228  print*, 'X-dir Courant number MIN : ', mincx
5229  print*, 'X-dir Courant number MAX : ', maxcx
5230  print*, ''
5231  print*, 'X-dir Courant number MEAN : ', meancx
5232  print*, 'Y-dir Courant number MEAN : ', meancy
5233  print*, ''
5234  print*, 'NDT: ', ndt
5235  print*, 'n_split: ', n_split
5236  print*, 'DT: ', dt
5237  print*, ''
5238  print*, '--------------------------------------------'
5239  print*, ''
5240  endif
5241 
5242  end subroutine check_courant_numbers
5243 !
5244 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5245 !-------------------------------------------------------------------------------
5246 
5247 !-------------------------------------------------------------------------------
5248 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5249 !
5250 ! pmxn :: find max and min of field p
5251 !
5252  subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
5253  integer, intent(IN) :: npx
5254  integer, intent(IN) :: npy
5255  integer, intent(IN) :: nregions, tile
5256  real , intent(IN) :: p(isd:ied,jsd:jed)
5257  type(fv_grid_type), intent(IN), target :: gridstruct
5258  real , intent(OUT) :: pmin
5259  real , intent(OUT) :: pmax
5260  integer, intent(OUT) :: i0
5261  integer, intent(OUT) :: j0
5262  integer, intent(OUT) :: n0
5263 
5264  real :: temp
5265  integer :: i,j,n
5266 
5267 
5268  real, pointer, dimension(:,:,:) :: agrid, grid
5269  real, pointer, dimension(:,:) :: area, rarea, fC, f0
5270  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
5271  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
5272  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5273 
5274  logical, pointer :: cubed_sphere, latlon
5275 
5276  logical, pointer :: have_south_pole, have_north_pole
5277 
5278  integer, pointer :: ntiles_g
5279  real, pointer :: acapN, acapS, globalarea
5280 
5281  grid => gridstruct%grid
5282  agrid=> gridstruct%agrid
5283 
5284  area => gridstruct%area
5285  rarea => gridstruct%rarea
5286 
5287  fc => gridstruct%fC
5288  f0 => gridstruct%f0
5289 
5290  ee1 => gridstruct%ee1
5291  ee2 => gridstruct%ee2
5292  ew => gridstruct%ew
5293  es => gridstruct%es
5294  en1 => gridstruct%en1
5295  en2 => gridstruct%en2
5296 
5297  dx => gridstruct%dx
5298  dy => gridstruct%dy
5299  dxa => gridstruct%dxa
5300  dya => gridstruct%dya
5301  rdxa => gridstruct%rdxa
5302  rdya => gridstruct%rdya
5303  dxc => gridstruct%dxc
5304  dyc => gridstruct%dyc
5305 
5306  cubed_sphere => gridstruct%cubed_sphere
5307  latlon => gridstruct%latlon
5308 
5309  have_south_pole => gridstruct%have_south_pole
5310  have_north_pole => gridstruct%have_north_pole
5311 
5312  ntiles_g => gridstruct%ntiles_g
5313  acapn => gridstruct%acapN
5314  acaps => gridstruct%acapS
5315  globalarea => gridstruct%globalarea
5316 
5317  pmax = -1.e25
5318  pmin = 1.e25
5319  i0 = -999
5320  j0 = -999
5321  n0 = tile
5322 
5323  do j=js,je
5324  do i=is,ie
5325  temp = p(i,j)
5326  if (temp > pmax) then
5327  pmax = temp
5328  i0 = i
5329  j0 = j
5330  elseif (temp < pmin) then
5331  pmin = temp
5332  endif
5333  enddo
5334  enddo
5335 
5336  temp = pmax
5337  call mp_reduce_max(temp)
5338  if (temp /= pmax) then
5339  i0 = -999
5340  j0 = -999
5341  n0 = -999
5342  endif
5343  pmax = temp
5344  call mp_reduce_max(i0)
5345  call mp_reduce_max(j0)
5346  call mp_reduce_max(n0)
5347 
5348  pmin = -pmin
5349  call mp_reduce_max(pmin)
5350  pmin = -pmin
5351 
5352  end subroutine pmxn
5353 !
5354 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5355 !-------------------------------------------------------------------------------
5356 
5357 !! These routines are no longer used
5358 #ifdef NCDF_OUTPUT
5359 
5360 !-------------------------------------------------------------------------------
5361 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5362 !
5363 ! output_ncdf :: write out NETCDF fields
5364 !
5365  subroutine output_ncdf(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5366  omga, npx, npy, npz, ng, ncnst, ndims, nregions, ncid, &
5367  npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ntiles_id, ncnst_id, nt_id, &
5368  phis_id, delp_id, ps_id, pt_id, pv_id, om_id, u_id, v_id, q_id, tracers_ids, &
5369  lats_id, lons_id, gridstruct, flagstruct)
5370  real, intent(IN) :: dt
5371  integer, intent(IN) :: nt, maxnt
5372  integer, intent(INOUT) :: nout
5373 
5374  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5375  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5376  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5377  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5378  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5379 
5380  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5381  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5382 
5383  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5384  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5385  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5386  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5387  real , intent(INOUT) :: omga(isd:ied ,jsd:jed ,npz)
5388 
5389  integer, intent(IN) :: npx, npy, npz
5390  integer, intent(IN) :: ng, ncnst
5391  integer, intent(IN) :: ndims
5392  integer, intent(IN) :: nregions
5393  integer, intent(IN) :: ncid
5394  integer, intent(IN) :: npx_p1_id, npy_p1_id, npx_id, npy_id, npz_id, ncnst_id
5395  integer, intent(IN) :: ntiles_id, nt_id
5396  integer, intent(IN) :: phis_id, delp_id, ps_id, pt_id, pv_id, u_id, v_id, q_id
5397  integer, intent(IN) :: om_id ! omega (dp/dt)
5398  integer, intent(IN) :: tracers_ids(ncnst-1)
5399  integer, intent(IN) :: lats_id, lons_id
5400 
5401  type(fv_grid_type), target :: gridstruct
5402  type(fv_flags_type), intent(IN) :: flagstruct
5403 
5404  real, allocatable :: tmp(:,:,:)
5405  real, allocatable :: tmpA(:,:,:)
5406 #if defined(SW_DYNAMICS)
5407  real, allocatable :: ut(:,:,:)
5408  real, allocatable :: vt(:,:,:)
5409 #else
5410  real, allocatable :: ut(:,:,:,:)
5411  real, allocatable :: vt(:,:,:,:)
5412  real, allocatable :: tmpA_3d(:,:,:,:)
5413 #endif
5414  real, allocatable :: vort(:,:)
5415 
5416  real :: p1(2) ! Temporary Point
5417  real :: p2(2) ! Temporary Point
5418  real :: p3(2) ! Temporary Point
5419  real :: p4(2) ! Temporary Point
5420  real :: pa(2) ! Temporary Point
5421  real :: utmp, vtmp, r, r0, dist, heading
5422  integer :: i,j,k,n,iq,nreg
5423 
5424  real :: Vtx, p, w_p
5425  real :: x1,y1,z1,x2,y2,z2,ang
5426 
5427  real, pointer, dimension(:,:,:) :: agrid, grid
5428  real, pointer, dimension(:,:) :: area, rarea
5429  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5430 
5431  grid => gridstruct%grid
5432  agrid => gridstruct%agrid
5433 
5434  area => gridstruct%area
5435  rarea => gridstruct%rarea
5436 
5437  dx => gridstruct%dx
5438  dy => gridstruct%dy
5439  dxa => gridstruct%dxa
5440  dya => gridstruct%dya
5441  rdxa => gridstruct%rdxa
5442  rdya => gridstruct%rdya
5443  dxc => gridstruct%dxc
5444  dyc => gridstruct%dyc
5445 
5446  allocate( tmp(npx ,npy ,nregions) )
5447  allocate( tmpa(npx-1,npy-1,nregions) )
5448 #if defined(SW_DYNAMICS)
5449  allocate( ut(npx-1,npy-1,nregions) )
5450  allocate( vt(npx-1,npy-1,nregions) )
5451 #else
5452  allocate( ut(npx-1,npy-1,npz,nregions) )
5453  allocate( vt(npx-1,npy-1,npz,nregions) )
5454  allocate( tmpa_3d(npx-1,npy-1,npz,nregions) )
5455 #endif
5456  allocate( vort(isd:ied,jsd:jed) )
5457 
5458  nout = nout + 1
5459 
5460  if (nt==0) then
5461  tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,2)
5462  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)
5463  tmp(is:ie+1,js:je+1,tile) = grid(is:ie+1,js:je+1,1)
5464  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)
5465  endif
5466 
5467 #if defined(SW_DYNAMICS)
5468  if (test_case > 1) then
5469  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)/grav
5470 
5471  if ((nt==0) .and. (test_case==2)) then
5472  ubar = (2.0*pi*radius)/(12.0*86400.0)
5473  gh0 = 2.94e4
5474  phis = 0.0
5475  do j=js,je+1
5476  do i=is,ie+1
5477  tmp(i,j,tile) = (gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
5478  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5479  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / grav
5480  enddo
5481  enddo
5482  endif
5483 
5484  else
5485 
5486  if (test_case==1) then
5487 ! Get Current Height Field "Truth"
5488  p1(1) = pi/2. + pi_shift
5489  p1(2) = 0.
5490  p2(1) = 3.*pi/2. + pi_shift
5491  p2(2) = 0.
5492  r0 = radius/3. !RADIUS /3.
5493  dist = 2.0*pi*radius* ((float(nt)/float(maxnt)))
5494  heading = 5.0*pi/2.0 - alpha
5495  call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5496  do j=jsd,jed
5497  do i=isd,ied
5498  p2(1) = agrid(i,j,1)
5499  p2(2) = agrid(i,j,2)
5500  r = great_circle_dist( p3, p2, radius )
5501  if (r < r0) then
5502  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
5503  else
5504  phi0(i,j,1) = phis(i,j)
5505  endif
5506  enddo
5507  enddo
5508  elseif (test_case == 0) then
5509  phi0 = 0.0
5510  do j=jsd,jed
5511  do i=isd,ied
5512  x1 = agrid(i,j,1)
5513  y1 = agrid(i,j,2)
5514  z1 = radius
5515  p = p0_c0 * cos(y1)
5516  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5517  w_p = 0.0
5518  if (p /= 0.0) w_p = vtx/p
5519  phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5520  enddo
5521  enddo
5522  endif
5523 
5524  tmpa(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5525  call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5526  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5527  endif
5528  call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5529 
5530  if (test_case == 9) then
5531 ! Calc Vorticity
5532  do j=jsd,jed
5533  do i=isd,ied
5534  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)) - &
5535  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5536  vort(i,j) = grav*vort(i,j)/delp(i,j,1)
5537  enddo
5538  enddo
5539  tmpa(is:ie,js:je,tile) = vort(is:ie,js:je)
5540  call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5541  endif
5542 
5543  call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, 1, 1, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord, bd)
5544  do j=js,je
5545  do i=is,ie
5546  ut(i,j,tile) = ua(i,j,1)
5547  vt(i,j,tile) = va(i,j,1)
5548  enddo
5549  enddo
5550 
5551  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)
5552  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)
5553 
5554  if ((test_case >= 2) .and. (nt==0) ) then
5555  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5556  call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa, 3)
5557  endif
5558 #else
5559 
5560 ! Write Moisture Data
5561  tmpa_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,1)
5562  call wrtvar_ncdf(ncid, q_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5563 
5564 ! Write Tracer Data
5565  do iq=2,ncnst
5566  tmpa_3d(is:ie,js:je,1:npz,tile) = q(is:ie,js:je,1:npz,iq)
5567  call wrtvar_ncdf(ncid, tracers_ids(iq-1), nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5568  enddo
5569 
5570 ! Write Surface height data
5571  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5572  call wrtvar_ncdf(ncid, phis_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpa, 3)
5573 
5574 ! Write Pressure Data
5575  tmpa(is:ie,js:je,tile) = ps(is:ie,js:je)
5576  call wrtvar_ncdf(ncid, ps_id, nout, is,ie, js,je, npx, npy, 1, nregions, tmpa, 3)
5577  do k=1,npz
5578  tmpa_3d(is:ie,js:je,k,tile) = delp(is:ie,js:je,k)/grav
5579  enddo
5580  call wrtvar_ncdf(ncid, delp_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5581 
5582 ! Write PT Data
5583  do k=1,npz
5584  tmpa_3d(is:ie,js:je,k,tile) = pt(is:ie,js:je,k)
5585  enddo
5586  call wrtvar_ncdf(ncid, pt_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5587 
5588 ! Write U,V Data
5589  call cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, npz, gridstruct%grid_type, gridstruct%nested, flagstruct%c2l_ord)
5590  do k=1,npz
5591  do j=js,je
5592  do i=is,ie
5593  ut(i,j,k,tile) = ua(i,j,k)
5594  vt(i,j,k,tile) = va(i,j,k)
5595  enddo
5596  enddo
5597  enddo
5598  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)
5599  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)
5600 
5601 
5602 ! Calc Vorticity
5603  do k=1,npz
5604  do j=js,je
5605  do i=is,ie
5606  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)) - &
5607  (u(i,j+1,k)*dx(i,j+1) - u(i,j,k)*dx(i,j)) )
5608  enddo
5609  enddo
5610  enddo
5611  call wrtvar_ncdf(ncid, pv_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5612 !
5613 ! Output omega (dp/dt):
5614  do k=1,npz
5615  do j=js,je
5616  do i=is,ie
5617  tmpa_3d(i,j,k,tile) = omga(i,j,k)
5618  enddo
5619  enddo
5620  enddo
5621  call wrtvar_ncdf(ncid, om_id, nout, is,ie, js,je, npx, npy, npz, nregions, tmpa_3d, 4)
5622 
5623 #endif
5624 
5625  deallocate( tmp )
5626  deallocate( tmpa )
5627 #if defined(SW_DYNAMICS)
5628  deallocate( ut )
5629  deallocate( vt )
5630 #else
5631  deallocate( ut )
5632  deallocate( vt )
5633  deallocate( tmpa_3d )
5634 #endif
5635  deallocate( vort )
5636 
5637  nullify(grid)
5638  nullify(agrid)
5639 
5640  nullify(area)
5641 
5642  nullify(dx)
5643  nullify(dy)
5644  nullify(dxa)
5645  nullify(dya)
5646  nullify(rdxa)
5647  nullify(rdya)
5648  nullify(dxc)
5649  nullify(dyc)
5650 
5651  end subroutine output_ncdf
5652 
5653 !
5654 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5655 !-------------------------------------------------------------------------------
5656 
5657 !-------------------------------------------------------------------------------
5658 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5659 !
5660 ! output :: write out fields
5661 !
5662  subroutine output(dt, nt, maxnt, nout, u,v,pt,delp,q,phis,ps, uc,vc, ua,va, &
5663  npx, npy, npz, ng, ncnst, ndims, nregions, phis_lun, phi_lun, &
5664  pt_lun, pv_lun, uv_lun, gridstruct)
5665 
5666  real, intent(IN) :: dt
5667  integer, intent(IN) :: nt, maxnt
5668  integer, intent(INOUT) :: nout
5669 
5670  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
5671  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
5672  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
5673  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
5674  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
5675 
5676  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
5677  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
5678 
5679  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
5680  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
5681  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
5682  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
5683 
5684  integer, intent(IN) :: npx, npy, npz
5685  integer, intent(IN) :: ng, ncnst
5686  integer, intent(IN) :: ndims
5687  integer, intent(IN) :: nregions
5688  integer, intent(IN) :: phis_lun, phi_lun, pt_lun, pv_lun, uv_lun
5689 
5690  type(fv_grid_type), target :: gridstruct
5691 
5692  real :: tmp(1-ng:npx +ng,1-ng:npy +ng,1:nregions)
5693  real :: tmpA(1-ng:npx-1+ng,1-ng:npy-1+ng,1:nregions)
5694  real :: p1(2) ! Temporary Point
5695  real :: p2(2) ! Temporary Point
5696  real :: p3(2) ! Temporary Point
5697  real :: p4(2) ! Temporary Point
5698  real :: pa(2) ! Temporary Point
5699  real :: ut(1:npx,1:npy,1:nregions)
5700  real :: vt(1:npx,1:npy,1:nregions)
5701  real :: utmp, vtmp, r, r0, dist, heading
5702  integer :: i,j,k,n,nreg
5703  real :: vort(isd:ied,jsd:jed)
5704 
5705  real :: Vtx, p, w_p
5706  real :: x1,y1,z1,x2,y2,z2,ang
5707 
5708  real, pointer, dimension(:,:,:) :: agrid, grid
5709  real, pointer, dimension(:,:) :: area, rarea
5710  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
5711 
5712  grid => gridstruct%grid
5713  agrid => gridstruct%agrid
5714 
5715  area => gridstruct%area
5716 
5717  dx => gridstruct%dx
5718  dy => gridstruct%dy
5719  dxa => gridstruct%dxa
5720  dya => gridstruct%dya
5721  rdxa => gridstruct%rdxa
5722  rdya => gridstruct%rdya
5723  dxc => gridstruct%dxc
5724  dyc => gridstruct%dyc
5725 
5726  cubed_sphere => gridstruct%cubed_sphere
5727 
5728  nout = nout + 1
5729 
5730 #if defined(SW_DYNAMICS)
5731  if (test_case > 1) then
5732  call atob_s(delp(:,:,1)/grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5733  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)/grav
5734 
5735  if ((nt==0) .and. (test_case==2)) then
5736  ubar = (2.0*pi*radius)/(12.0*86400.0)
5737  gh0 = 2.94e4
5738  phis = 0.0
5739  do j=js,je+1
5740  do i=is,ie+1
5741  tmp(i,j,tile) = (gh0 - (radius*omega*ubar + (ubar*ubar)/2.) * &
5742  ( -1.*cos(grid(i ,j ,1))*cos(grid(i ,j ,2))*sin(alpha) + &
5743  sin(grid(i ,j ,2))*cos(alpha) ) ** 2.0) / grav
5744  enddo
5745  enddo
5746  endif
5747 
5748  else
5749 
5750  if (test_case==1) then
5751 ! Get Current Height Field "Truth"
5752  p1(1) = pi/2. + pi_shift
5753  p1(2) = 0.
5754  p2(1) = 3.*pi/2. + pi_shift
5755  p2(2) = 0.
5756  r0 = radius/3. !RADIUS /3.
5757  dist = 2.0*pi*radius* ((float(nt)/float(maxnt)))
5758  heading = 5.0*pi/2.0 - alpha
5759  call get_pt_on_great_circle( p1, p2, dist, heading, p3)
5760  do j=jsd,jed
5761  do i=isd,ied
5762  p2(1) = agrid(i,j,1)
5763  p2(2) = agrid(i,j,2)
5764  r = great_circle_dist( p3, p2, radius )
5765  if (r < r0) then
5766  phi0(i,j,1) = phis(i,j) + gh0*0.5*(1.0+cos(pi*r/r0))
5767  else
5768  phi0(i,j,1) = phis(i,j)
5769  endif
5770  enddo
5771  enddo
5772  elseif (test_case == 0) then
5773  phi0 = 0.0
5774  do j=jsd,jed
5775  do i=isd,ied
5776  x1 = agrid(i,j,1)
5777  y1 = agrid(i,j,2)
5778  z1 = radius
5779  p = p0_c0 * cos(y1)
5780  vtx = ((3.0*sqrt(2.0))/2.0) * (( 1.0/cosh(p) )**2.0) * tanh(p)
5781  w_p = 0.0
5782  if (p /= 0.0) w_p = vtx/p
5783  phi0(i,j,1) = 1.0 - tanh( (p/rgamma) * sin(x1 - w_p*(nt*dt/86400.0)) )
5784  enddo
5785  enddo
5786  endif
5787 
5788  call atob_s(phi0(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5789  tmpa(is:ie,js:je,tile) = phi0(is:ie,js:je,1)
5790  call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5791  call atob_s(delp(:,:,1), tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5792  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,1)
5793  endif
5794  ! call wrt2d(phi_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5795  call wrt2d(phi_lun, nout, is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5796 
5797  if (test_case == 9) then
5798 ! Calc Vorticity
5799  do j=jsd,jed
5800  do i=isd,ied
5801  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)) - &
5802  (u(i,j+1,1)*dx(i,j+1) - u(i,j,1)*dx(i,j)) )
5803  vort(i,j) = grav*vort(i,j)/delp(i,j,1)
5804  enddo
5805  enddo
5806  call atob_s(vort, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5807  call wrt2d(pv_lun, nout, is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5808  endif
5809 
5810  call dtoa(u , v , ua, va, dx,dy,dxa,dya,dxc,dyc,npx, npy, ng)
5811 ! Rotate winds to standard Lat-Lon orientation
5812  if (cubed_sphere) then
5813  do j=js,je
5814  do i=is,ie
5815  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5816  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5817  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5818  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5819  utmp = ua(i,j,1)
5820  vtmp = va(i,j,1)
5821  if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5822  ut(i,j,tile) = utmp
5823  vt(i,j,tile) = vtmp
5824  enddo
5825  enddo
5826  endif
5827 
5828  call wrt2d(uv_lun, 2*(nout-1) + 1, is,ie, js,je, npx, npy, nregions, ut(1:npx-1,1:npy-1,1:nregions))
5829  call wrt2d(uv_lun, 2*(nout-1) + 2, is,ie, js,je, npx, npy, nregions, vt(1:npx-1,1:npy-1,1:nregions))
5830 
5831  if ((test_case >= 2) .and. (nt==0) ) then
5832  call atob_s(phis/grav, tmp(isd:ied+1,jsd:jed+1,tile), npx,npy, dxa, dya, gridstruct%nested) !, altInterp=1)
5833  ! call wrt2d(phis_lun, nout , is,ie+1, js,je+1, npx+1, npy+1, nregions, tmp(1:npx,1:npy,1:nregions))
5834  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5835  call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5836  endif
5837 #else
5838 
5839 ! Write Surface height data
5840  if (nt==0) then
5841  tmpa(is:ie,js:je,tile) = phis(is:ie,js:je)/grav
5842  call wrt2d(phis_lun, nout , is,ie, js,je, npx, npy, nregions, tmpa(1:npx-1,1:npy-1,1:nregions))
5843  endif
5844 
5845 ! Write Pressure Data
5846 
5847  !if (tile==2) then
5848  ! do i=is,ie
5849  ! print*, i, ps(i,35)
5850  ! enddo
5851  !endif
5852  tmpa(is:ie,js:je,tile) = ps(is:ie,js:je)
5853  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))
5854  do k=1,npz
5855  tmpa(is:ie,js:je,tile) = delp(is:ie,js:je,k)/grav
5856  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))
5857  enddo
5858 
5859 ! Write PT Data
5860  do k=1,npz
5861  tmpa(is:ie,js:je,tile) = pt(is:ie,js:je,k)
5862  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))
5863  enddo
5864 
5865 ! Write U,V Data
5866  do k=1,npz
5867  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)
5868 ! Rotate winds to standard Lat-Lon orientation
5869  if (cubed_sphere) then
5870  do j=js,je
5871  do i=is,ie
5872  call mid_pt_sphere(grid(i,j,1:2), grid(i,j+1,1:2), p1)
5873  call mid_pt_sphere(grid(i,j,1:2), grid(i+1,j,1:2), p2)
5874  call mid_pt_sphere(grid(i+1,j,1:2), grid(i+1,j+1,1:2), p3)
5875  call mid_pt_sphere(grid(i,j+1,1:2), grid(i+1,j+1,1:2), p4)
5876  utmp = ua(i,j,k)
5877  vtmp = va(i,j,k)
5878  if (cubed_sphere) call rotate_winds(utmp,vtmp, p1,p2,p3,p4, agrid(i,j,1:2), 2, 2)
5879  ut(i,j,tile) = utmp
5880  vt(i,j,tile) = vtmp
5881  enddo
5882  enddo
5883  endif
5884  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))
5885  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))
5886  enddo
5887 #endif
5888 
5889  nullify(grid)
5890  nullify(agrid)
5891 
5892  nullify(area)
5893 
5894  nullify(dx)
5895  nullify(dy)
5896  nullify(dxa)
5897  nullify(dya)
5898  nullify(rdxa)
5899  nullify(rdya)
5900  nullify(dxc)
5901  nullify(dyc)
5902 
5903  nullify(cubed_sphere)
5904 
5905  end subroutine output
5906 !
5907 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5908 !-------------------------------------------------------------------------------
5909 
5910 !-------------------------------------------------------------------------------
5911 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5912 ! wrt2d_ncdf :: write out a 2d field
5913 !
5914  subroutine wrtvar_ncdf(ncid, varid, nrec, i1,i2, j1,j2, npx, npy, npz, ntiles, p, ndims)
5915 #include <netcdf.inc>
5916  integer, intent(IN) :: ncid, varid
5917  integer, intent(IN) :: nrec
5918  integer, intent(IN) :: i1,i2,j1,j2
5919  integer, intent(IN) :: npx
5920  integer, intent(IN) :: npy
5921  integer, intent(IN) :: npz
5922  integer, intent(IN) :: ntiles
5923  real , intent(IN) :: p(npx-1,npy-1,npz,ntiles)
5924  integer, intent(IN) :: ndims
5925 
5926  integer :: error
5927  real(kind=4), allocatable :: p_R4(:,:,:,:)
5928  integer :: i,j,k,n
5929  integer :: istart(ndims+1), icount(ndims+1)
5930 
5931  allocate( p_r4(npx-1,npy-1,npz,ntiles) )
5932 
5933  p_r4(:,:,:,:) = missing
5934  p_r4(i1:i2,j1:j2,1:npz,tile) = p(i1:i2,j1:j2,1:npz,tile)
5935  call mp_gather(p_r4, i1,i2, j1,j2, npx-1, npy-1, npz, ntiles)
5936 
5937  istart(:) = 1
5938  istart(ndims+1) = nrec
5939  icount(1) = npx-1
5940  icount(2) = npy-1
5941  icount(3) = npz
5942  if (ndims == 3) icount(3) = ntiles
5943  if (ndims == 4) icount(4) = ntiles
5944  icount(ndims+1) = 1
5945 
5946  if (is_master()) then
5947  error = nf_put_vara_real(ncid, varid, istart, icount, p_r4)
5948  endif ! masterproc
5949 
5950  deallocate( p_r4 )
5951 
5952  end subroutine wrtvar_ncdf
5953 !
5954 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5955 !-------------------------------------------------------------------------------
5956 
5957 !-------------------------------------------------------------------------------
5958 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5959 ! wrt2d :: write out a 2d field
5960 !
5961  subroutine wrt2d(iout, nrec, i1,i2, j1,j2, npx, npy, nregions, p)
5962  integer, intent(IN) :: iout
5963  integer, intent(IN) :: nrec
5964  integer, intent(IN) :: i1,i2,j1,j2
5965  integer, intent(IN) :: npx
5966  integer, intent(IN) :: npy
5967  integer, intent(IN) :: nregions
5968  real , intent(IN) :: p(npx-1,npy-1,nregions)
5969 
5970  real(kind=4) :: p_R4(npx-1,npy-1,nregions)
5971  integer :: i,j,n
5972 
5973  do n=tile,tile
5974  do j=j1,j2
5975  do i=i1,i2
5976  p_r4(i,j,n) = p(i,j,n)
5977  enddo
5978  enddo
5979  enddo
5980 
5981  call mp_gather(p_r4, i1,i2, j1,j2, npx-1, npy-1, nregions)
5982 
5983  if (is_master()) then
5984  write(iout,rec=nrec) p_r4(1:npx-1,1:npy-1,1:nregions)
5985  endif ! masterproc
5986 
5987  end subroutine wrt2d
5988 !
5989 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
5990 !-------------------------------------------------------------------------------
5991 #endif
5992 !-------------------------------------------------------------------------------
5993 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
5994 ! init_double_periodic
5995 !
5996  subroutine init_double_periodic(u,v,w,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
5997  gridstruct, flagstruct, npx, npy, npz, ng, ncnst, nwat, ndims, nregions, dry_mass, &
5998  mountain, moist_phys, hydrostatic, hybrid_z, delz, ze0, ks, ptop, domain_in, tile_in, bd)
5999 
6000 
6001  type(fv_grid_bounds_type), intent(IN) :: bd
6002  real , intent(INOUT) :: u(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6003  real , intent(INOUT) :: v(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6004  real , intent(INOUT) :: w(bd%isd: ,bd%jsd: ,1:)
6005  real , intent(INOUT) :: pt(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6006  real , intent(INOUT) :: delp(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6007  real , intent(INOUT) :: q(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz, ncnst)
6008 
6009  real , intent(INOUT) :: phis(bd%isd:bd%ied ,bd%jsd:bd%jed )
6010 
6011  real , intent(INOUT) :: ps(bd%isd:bd%ied ,bd%jsd:bd%jed )
6012  real , intent(INOUT) :: pe(bd%is-1:bd%ie+1,npz+1,bd%js-1:bd%je+1)
6013  real , intent(INOUT) :: pk(bd%is:bd%ie ,bd%js:bd%je ,npz+1)
6014  real , intent(INOUT) :: peln(bd%is :bd%ie ,npz+1 ,bd%js:bd%je)
6015  real , intent(INOUT) :: pkz(bd%is:bd%ie ,bd%js:bd%je ,npz )
6016  real , intent(INOUT) :: uc(bd%isd:bd%ied+1,bd%jsd:bd%jed ,npz)
6017  real , intent(INOUT) :: vc(bd%isd:bd%ied ,bd%jsd:bd%jed+1,npz)
6018  real , intent(INOUT) :: ua(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6019  real , intent(INOUT) :: va(bd%isd:bd%ied ,bd%jsd:bd%jed ,npz)
6020  real , intent(inout) :: delz(bd%isd:,bd%jsd:,1:)
6021  real , intent(inout) :: ze0(bd%is:,bd%js:,1:)
6022 
6023  real , intent(inout) :: ak(npz+1)
6024  real , intent(inout) :: bk(npz+1)
6025 
6026  integer, intent(IN) :: npx, npy, npz
6027  integer, intent(IN) :: ng, ncnst, nwat
6028  integer, intent(IN) :: ndims
6029  integer, intent(IN) :: nregions
6030 
6031  real, intent(IN) :: dry_mass
6032  logical, intent(IN) :: mountain
6033  logical, intent(IN) :: moist_phys
6034  logical, intent(IN) :: hydrostatic, hybrid_z
6035  integer, intent(INOUT) :: ks
6036  integer, intent(INOUT), target :: tile_in
6037  real, intent(INOUT) :: ptop
6038 
6039  type(domain2d), intent(IN), target :: domain_in
6040 
6041  type(fv_grid_type), target :: gridstruct
6042  type(fv_flags_type), target :: flagstruct
6043 
6044  real, dimension(bd%is:bd%ie):: pm, qs
6045  real, dimension(1:npz):: pk1, ts1, qs1
6046  real :: us0 = 30.
6047  real :: dist, r0, f0_const, prf, rgrav
6048  real :: ptmp, ze, zc, zm, utmp, vtmp
6049  real :: t00, p00, xmax, xc, xx, yy, pk0, pturb, ztop
6050  real :: ze1(npz+1)
6051  real:: dz1(npz)
6052  real:: zvir
6053  integer :: i, j, k, m, icenter, jcenter
6054 
6055  real, pointer, dimension(:,:,:) :: agrid, grid
6056  real(kind=R_GRID), pointer, dimension(:,:) :: area
6057  real, pointer, dimension(:,:) :: rarea, fc, f0
6058  real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
6059  real, pointer, dimension(:,:,:,:) :: ew, es
6060  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
6061 
6062  logical, pointer :: cubed_sphere, latlon
6063 
6064  type(domain2d), pointer :: domain
6065  integer, pointer :: tile
6066 
6067  logical, pointer :: have_south_pole, have_north_pole
6068 
6069  integer, pointer :: ntiles_g
6070  real, pointer :: acapn, acaps, globalarea
6071 
6072  real(kind=R_GRID), pointer :: dx_const, dy_const
6073 
6074  integer :: is, ie, js, je
6075  integer :: isd, ied, jsd, jed
6076 
6077  is = bd%is
6078  ie = bd%ie
6079  js = bd%js
6080  je = bd%je
6081  isd = bd%isd
6082  ied = bd%ied
6083  jsd = bd%jsd
6084  jed = bd%jed
6085 
6086  agrid => gridstruct%agrid
6087  grid => gridstruct%grid
6088 
6089  area => gridstruct%area_64
6090 
6091  dx => gridstruct%dx
6092  dy => gridstruct%dy
6093  dxa => gridstruct%dxa
6094  dya => gridstruct%dya
6095  rdxa => gridstruct%rdxa
6096  rdya => gridstruct%rdya
6097  dxc => gridstruct%dxc
6098  dyc => gridstruct%dyc
6099 
6100  fc => gridstruct%fC
6101  f0 => gridstruct%f0
6102 
6103  !These are frequently used and so have pointers set up for them
6104  dx_const => flagstruct%dx_const
6105  dy_const => flagstruct%dy_const
6106 
6107  domain => domain_in
6108  tile => tile_in
6109 
6110  have_south_pole => gridstruct%have_south_pole
6111  have_north_pole => gridstruct%have_north_pole
6112 
6113  ntiles_g => gridstruct%ntiles_g
6114  acapn => gridstruct%acapN
6115  acaps => gridstruct%acapS
6116  globalarea => gridstruct%globalarea
6117 
6118  f0_const = 2.*omega*sin(flagstruct%deglat/180.*pi)
6119  f0(:,:) = f0_const
6120  fc(:,:) = f0_const
6121 
6122  q = 0.
6123 
6124  select case (test_case)
6125  case ( 1 )
6126 
6127  phis(:,:)=0.
6128 
6129  u(:,:,:)=10.
6130  v(:,:,:)=10.
6131  ua(:,:,:)=10.
6132  va(:,:,:)=10.
6133  uc(:,:,:)=10.
6134  vc(:,:,:)=10.
6135  pt(:,:,:)=1.
6136  delp(:,:,:)=0.
6137 
6138  do j=js,je
6139  if (j>0 .and. j<5) then
6140  do i=is,ie
6141  if (i>0 .and. i<5) then
6142  delp(i,j,:)=1.
6143  endif
6144  enddo
6145  endif
6146  enddo
6147  call mpp_update_domains( delp, domain )
6148 
6149  case ( 2 )
6150 
6151  phis(:,:) = 0.
6152 
6153 ! r0 = 5000.
6154  r0 = 5.*sqrt(dx_const**2 + dy_const**2)
6155  icenter = npx/2
6156  jcenter = npy/2
6157  do j=jsd,jed
6158  do i=isd,ied
6159  dist=(i-icenter)*dx_const*(i-icenter)*dx_const &
6160  +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6161  dist=min(r0,sqrt(dist))
6162  phis(i,j)=1500.*(1. - (dist/r0))
6163  enddo
6164  enddo
6165 
6166  u(:,:,:)=0.
6167  v(:,:,:)=0.
6168  ua(:,:,:)=0.
6169  va(:,:,:)=0.
6170  uc(:,:,:)=0.
6171  vc(:,:,:)=0.
6172  pt(:,:,:)=1.
6173  delp(:,:,:)=1500.
6174 
6175  case ( 14 )
6176 !---------------------------
6177 ! Doubly periodic Aqua-plane
6178 !---------------------------
6179  u(:,:,:) = 0.
6180  v(:,:,:) = 0.
6181  phis(:,:) = 0.
6182 
6183  call hydro_eq(npz, is, ie, js, je, ps, phis, dry_mass, &
6184  delp, ak, bk, pt, delz, area, ng, .false., hydrostatic, hybrid_z, domain)
6185 
6186  ! *** Add Initial perturbation ***
6187  if (bubble_do) then
6188  r0 = 100.*sqrt(dx_const**2 + dy_const**2)
6189  icenter = npx/2
6190  jcenter = npy/2
6191 
6192  do j=js,je
6193  do i=is,ie
6194  dist = (i-icenter)*dx_const*(i-icenter)*dx_const &
6195  +(j-jcenter)*dy_const*(j-jcenter)*dy_const
6196  dist = min(r0, sqrt(dist))
6197  do k=1,npz
6198  prf = ak(k) + ps(i,j)*bk(k)
6199  if ( prf > 100.e2 ) then
6200  pt(i,j,k) = pt(i,j,k) + 0.01*(1. - (dist/r0)) * prf/ps(i,j)
6201  endif
6202  enddo
6203  enddo
6204  enddo
6205  endif
6206  if ( hydrostatic ) then
6207  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6208  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6209  moist_phys, .true., nwat , domain)
6210  else
6211  w(:,:,:) = 0.
6212  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6213  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6214  moist_phys, hydrostatic, nwat, domain, .true. )
6215  endif
6216 
6217  q = 0.
6218  do k=1,npz
6219  do j=js,je
6220  do i=is,ie
6221  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6222  enddo
6223  call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6224  do i=is,ie
6225  q(i,j,k,1) = max(2.e-6, 0.8*pm(i)/ps(i,j)*qs(i) )
6226  enddo
6227  enddo
6228  enddo
6229 
6230  case ( 15 )
6231 !---------------------------
6232 ! Doubly periodic bubble
6233 !---------------------------
6234  t00 = 250.
6235 
6236  u(:,:,:) = 0.
6237  v(:,:,:) = 0.
6238  pt(:,:,:) = t00
6239  q(:,:,:,:) = 1.e-6
6240 
6241  if ( .not. hydrostatic ) w(:,:,:) = 0.
6242 
6243  do j=jsd,jed
6244  do i=isd,ied
6245  phis(i,j) = 0.
6246  ps(i,j) = 1000.e2
6247  enddo
6248  enddo
6249 
6250  do k=1,npz
6251  do j=jsd,jed
6252  do i=isd,ied
6253  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6254  enddo
6255  enddo
6256  enddo
6257 
6258 
6259  do k=1,npz
6260  do j=jsd,jed
6261  do i=isd,ied
6262  ptmp = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6263 ! pt(i,j,k) = t00
6264  enddo
6265  enddo
6266  enddo
6267 
6268  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6269  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6270  moist_phys, .false., nwat, domain)
6271 
6272 ! *** Add Initial perturbation ***
6273  r0 = 5.*max(dx_const, dy_const)
6274  zc = 0.5e3 ! center of bubble from surface
6275  icenter = npx/2
6276  jcenter = npy/2
6277 
6278  do j=js,je
6279  do i=is,ie
6280  ze = 0.
6281  do k=npz,1,-1
6282  zm = ze - 0.5*delz(i,j,k) ! layer center
6283  ze = ze - delz(i,j,k)
6284  dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + &
6285  (zm-zc)**2
6286  dist = sqrt(dist)
6287  if ( dist <= r0 ) then
6288  pt(i,j,k) = pt(i,j,k) + 5.*(1.-dist/r0)
6289  endif
6290  enddo
6291  enddo
6292  enddo
6293 
6294  case ( 16 )
6295 !------------------------------------
6296 ! Non-hydrostatic 3D density current:
6297 !------------------------------------
6298  phis = 0.
6299  u = 0.
6300  v = 0.
6301  w = 0.
6302  t00 = 300.
6303  p00 = 1.e5
6304  pk0 = p00**kappa
6305 ! Set up vertical coordinare with constant del-z spacing:
6306 ! Control: npz=64; dx = 100 m; dt = 1; n_split=10
6307  ztop = 6.4e3
6308  ze1( 1) = ztop
6309  ze1(npz+1) = 0.
6310  do k=npz,2,-1
6311  ze1(k) = ze1(k+1) + ztop/real(npz)
6312  enddo
6313 
6314  do j=js,je
6315  do i=is,ie
6316  ps(i,j) = p00
6317  pe(i,npz+1,j) = p00
6318  pk(i,j,npz+1) = pk0
6319  enddo
6320  enddo
6321 
6322  do k=npz,1,-1
6323  do j=js,je
6324  do i=is,ie
6325  delz(i,j,k) = ze1(k+1) - ze1(k)
6326  pk(i,j,k) = pk(i,j,k+1) + grav*delz(i,j,k)/(cp_air*t00)*pk0
6327  pe(i,k,j) = pk(i,j,k)**(1./kappa)
6328  enddo
6329  enddo
6330  enddo
6331 
6332  ptop = pe(is,1,js)
6333  if ( is_master() ) write(*,*) 'Density curent testcase: model top (mb)=', ptop/100.
6334 
6335  do k=1,npz+1
6336  do j=js,je
6337  do i=is,ie
6338  peln(i,k,j) = log(pe(i,k,j))
6339  ze0(i,j,k) = ze1(k)
6340  enddo
6341  enddo
6342  enddo
6343 
6344  do k=1,npz
6345  do j=js,je
6346  do i=is,ie
6347  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6348  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6349  pt(i,j,k) = t00/pk0 ! potential temp
6350  enddo
6351  enddo
6352  enddo
6353 
6354  pturb = 15.
6355  xmax = 51.2e3
6356  xc = xmax / 2.
6357 
6358  do k=1,npz
6359  zm = (0.5*(ze1(k)+ze1(k+1))-3.e3) / 2.e3
6360  do j=js,je
6361  do i=is,ie
6362 ! Impose perturbation in potential temperature: pturb
6363  xx = (dx_const * (0.5+real(i-1)) - xc) / 4.e3
6364  yy = (dy_const * (0.5+real(j-1)) - xc) / 4.e3
6365  dist = sqrt( xx**2 + yy**2 + zm**2 )
6366  if ( dist<=1. ) then
6367  pt(i,j,k) = pt(i,j,k) - pturb/pkz(i,j,k)*(cos(pi*dist)+1.)/2.
6368  endif
6369 ! Transform back to temperature:
6370  pt(i,j,k) = pt(i,j,k) * pkz(i,j,k)
6371  enddo
6372  enddo
6373  enddo
6374 
6375  case ( 17 )
6376 !---------------------------
6377 ! Doubly periodic SuperCell, straight wind (v==0)
6378 !--------------------------
6379  zvir = rvgas/rdgas - 1.
6380  p00 = 1000.e2
6381  ps(:,:) = p00
6382  phis(:,:) = 0.
6383  do j=js,je
6384  do i=is,ie
6385  pk(i,j,1) = ptop**kappa
6386  pe(i,1,j) = ptop
6387  peln(i,1,j) = log(ptop)
6388  enddo
6389  enddo
6390 
6391  do k=1,npz
6392  do j=js,je
6393  do i=is,ie
6394  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6395  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6396  peln(i,k+1,j) = log(pe(i,k+1,j))
6397  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6398  enddo
6399  enddo
6400  enddo
6401 
6402  i = is
6403  j = js
6404  do k=1,npz
6405  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6406  enddo
6407 
6408 
6409  v(:,:,:) = 0.
6410  w(:,:,:) = 0.
6411  q(:,:,:,:) = 0.
6412 
6413  do k=1,npz
6414  do j=js,je
6415  do i=is,ie
6416  pt(i,j,k) = ts1(k)
6417  q(i,j,k,1) = qs1(k)
6418  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6419  enddo
6420  enddo
6421  enddo
6422 
6423  ze1(npz+1) = 0.
6424  do k=npz,1,-1
6425  ze1(k) = ze1(k+1) - delz(is,js,k)
6426  enddo
6427 
6428  do k=1,npz
6429  zm = 0.5*(ze1(k)+ze1(k+1))
6430  utmp = us0*tanh(zm/3.e3)
6431  do j=js,je+1
6432  do i=is,ie
6433  u(i,j,k) = utmp
6434  enddo
6435  enddo
6436  enddo
6437 
6438  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6439  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6440  .true., hydrostatic, nwat, domain)
6441 
6442 ! *** Add Initial perturbation ***
6443  pturb = 2.
6444  r0 = 10.e3
6445  zc = 1.4e3 ! center of bubble from surface
6446  icenter = (npx-1)/3 + 1
6447  jcenter = (npy-1)/2 + 1
6448  do k=1, npz
6449  zm = 0.5*(ze1(k)+ze1(k+1))
6450  ptmp = ( (zm-zc)/zc ) **2
6451  if ( ptmp < 1. ) then
6452  do j=js,je
6453  do i=is,ie
6454  dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6455  if ( dist < 1. ) then
6456  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6457  endif
6458  enddo
6459  enddo
6460  endif
6461  enddo
6462 
6463  case ( 18 )
6464 !---------------------------
6465 ! Doubly periodic SuperCell, quarter circle hodograph
6466 ! M. Toy, Apr 2013, MWR
6467  pturb = 2.5
6468  zvir = rvgas/rdgas - 1.
6469  p00 = 1000.e2
6470  ps(:,:) = p00
6471  phis(:,:) = 0.
6472  do j=js,je
6473  do i=is,ie
6474  pk(i,j,1) = ptop**kappa
6475  pe(i,1,j) = ptop
6476  peln(i,1,j) = log(ptop)
6477  enddo
6478  enddo
6479 
6480  do k=1,npz
6481  do j=js,je
6482  do i=is,ie
6483  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
6484  pe(i,k+1,j) = ak(k+1) + ps(i,j)*bk(k+1)
6485  peln(i,k+1,j) = log(pe(i,k+1,j))
6486  pk(i,j,k+1) = exp( kappa*peln(i,k+1,j) )
6487  enddo
6488  enddo
6489  enddo
6490 
6491  i = is
6492  j = js
6493  do k=1,npz
6494  pk1(k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6495  enddo
6496 
6497 
6498  w(:,:,:) = 0.
6499  q(:,:,:,:) = 0.
6500 
6501  do k=1,npz
6502  do j=js,je
6503  do i=is,ie
6504  pt(i,j,k) = ts1(k)
6505  q(i,j,k,1) = qs1(k)
6506  delz(i,j,k) = rdgas/grav*ts1(k)*(1.+zvir*qs1(k))*(peln(i,k,j)-peln(i,k+1,j))
6507  enddo
6508  enddo
6509  enddo
6510 
6511  ze1(npz+1) = 0.
6512  do k=npz,1,-1
6513  ze1(k) = ze1(k+1) - delz(is,js,k)
6514  enddo
6515 
6516 ! Quarter-circle hodograph (Harris approximation)
6517  us0 = 30.
6518  do k=1,npz
6519  zm = 0.5*(ze1(k)+ze1(k+1))
6520  if ( zm .le. 2.e3 ) then
6521  utmp = 8.*(1.-cos(pi*zm/4.e3))
6522  vtmp = 8.*sin(pi*zm/4.e3)
6523  elseif (zm .le. 6.e3 ) then
6524  utmp = 8. + (us0-8.)*(zm-2.e3)/4.e3
6525  vtmp = 8.
6526  else
6527  utmp = us0
6528  vtmp = 8.
6529  endif
6530 ! u-wind
6531  do j=js,je+1
6532  do i=is,ie
6533  u(i,j,k) = utmp - 8.
6534  enddo
6535  enddo
6536 ! v-wind
6537  do j=js,je
6538  do i=is,ie+1
6539  v(i,j,k) = vtmp - 4.
6540  enddo
6541  enddo
6542  enddo
6543 
6544 
6545  call p_var(npz, is, ie, js, je, ptop, ptop_min, delp, delz, pt, ps, &
6546  pe, peln, pk, pkz, kappa, q, ng, ncnst, area, dry_mass, .false., .false., &
6547  .true., hydrostatic, nwat, domain)
6548 
6549 ! *** Add Initial perturbation ***
6550  if (bubble_do) then
6551  r0 = 10.e3
6552  zc = 1.4e3 ! center of bubble from surface
6553  icenter = (npx-1)/2 + 1
6554  jcenter = (npy-1)/2 + 1
6555  do k=1, npz
6556  zm = 0.5*(ze1(k)+ze1(k+1))
6557  ptmp = ( (zm-zc)/zc ) **2
6558  if ( ptmp < 1. ) then
6559  do j=js,je
6560  do i=is,ie
6561  dist = ptmp+((i-icenter)*dx_const/r0)**2+((j-jcenter)*dy_const/r0)**2
6562  if ( dist < 1. ) then
6563  pt(i,j,k) = pt(i,j,k) + pturb*(1.-sqrt(dist))
6564  endif
6565  enddo
6566  enddo
6567  endif
6568  enddo
6569  endif
6570 
6571  case ( 101 )
6572 
6573 ! IC for LES
6574  t00 = 250. ! constant temp
6575  p00 = 1.e5
6576  pk0 = p00**kappa
6577 
6578  phis = 0.
6579  u = 0.
6580  v = 0.
6581  w = 0.
6582  pt(:,:,:) = t00
6583  q(:,:,:,1) = 0.
6584 
6585  if (.not.hybrid_z) call mpp_error(fatal, 'hybrid_z must be .TRUE.')
6586 
6587  rgrav = 1./ grav
6588 
6589  if ( npz/=101) then
6590  call mpp_error(fatal, 'npz must be == 101 ')
6591  else
6592  call compute_dz_l101( npz, ztop, dz1 )
6593  endif
6594 
6595  call set_hybrid_z(is, ie, js, je, ng, npz, ztop, dz1, rgrav, &
6596  phis, ze0, delz)
6597 
6598  do j=js,je
6599  do i=is,ie
6600  ps(i,j) = p00
6601  pe(i,npz+1,j) = p00
6602  pk(i,j,npz+1) = pk0
6603  peln(i,npz+1,j) = log(p00)
6604  enddo
6605  enddo
6606 
6607  do k=npz,1,-1
6608  do j=js,je
6609  do i=is,ie
6610  peln(i,k,j) = peln(i,k+1,j) + grav*delz(i,j,k)/(rdgas*t00)
6611  pe(i,k,j) = exp(peln(i,k,j))
6612  pk(i,j,k) = pe(i,k,j)**kappa
6613  enddo
6614  enddo
6615  enddo
6616 
6617 
6618 ! Set up fake "sigma" coordinate
6619  call make_eta_level(npz, pe, area, ks, ak, bk, ptop, domain, bd)
6620 
6621  if ( is_master() ) write(*,*) 'LES testcase: computed model top (mb)=', ptop/100.
6622 
6623  do k=1,npz
6624  do j=js,je
6625  do i=is,ie
6626  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
6627  delp(i,j,k) = pe(i,k+1,j)-pe(i,k,j)
6628  enddo
6629  enddo
6630  enddo
6631 
6632  do k=1,npz
6633  do j=js,je
6634  do i=is,ie
6635  pm(i) = delp(i,j,k)/(peln(i,k+1,j)-peln(i,k,j))
6636  enddo
6637  call qsmith(ie-is+1, 1, 1, pt(is:ie,j,k), pm, q(is:ie,j,k,1), qs)
6638  do i=is,ie
6639  if ( pm(i) > 100.e2 ) then
6640  q(i,j,k,1) = 0.9*qs(i)
6641  else
6642  q(i,j,k,1) = 2.e-6
6643  endif
6644  enddo
6645  enddo
6646  enddo
6647 
6648 ! *** Add perturbation ***
6649  r0 = 1.0e3 ! radius (m)
6650  zc = 1.0e3 ! center of bubble
6651  icenter = npx/2
6652  jcenter = npy/2
6653 
6654  do k=1,npz
6655  do j=js,je
6656  do i=is,ie
6657  zm = 0.5*(ze0(i,j,k)+ze0(i,j,k+1))
6658  dist = ((i-icenter)*dx_const)**2 + ((j-jcenter)*dy_const)**2 + (zm-zc)**2
6659  dist = sqrt(dist)
6660  if ( dist <= r0 ) then
6661  pt(i,j,k) = pt(i,j,k) + 2.0*(1.-dist/r0)
6662  endif
6663  enddo
6664  enddo
6665  enddo
6666 
6667  end select
6668 
6669  nullify(grid)
6670  nullify(agrid)
6671 
6672  nullify(area)
6673 
6674  nullify(fc)
6675  nullify(f0)
6676 
6677  nullify(ee1)
6678  nullify(ee2)
6679  nullify(ew)
6680  nullify(es)
6681  nullify(en1)
6682  nullify(en2)
6683 
6684  nullify(dx)
6685  nullify(dy)
6686  nullify(dxa)
6687  nullify(dya)
6688  nullify(rdxa)
6689  nullify(rdya)
6690  nullify(dxc)
6691  nullify(dyc)
6692 
6693  nullify(dx_const)
6694  nullify(dy_const)
6695 
6696  nullify(domain)
6697  nullify(tile)
6698 
6699  nullify(have_south_pole)
6700  nullify(have_north_pole)
6701 
6702  nullify(ntiles_g)
6703  nullify(acapn)
6704  nullify(acaps)
6705  nullify(globalarea)
6706 
6707  end subroutine init_double_periodic
6708 
6709  subroutine superk_sounding(km, pe, p00, ze, pt, qz)
6710 ! This is the z-ccordinate version:
6711 ! Morris Weisman & J. Klemp 2002 sounding
6712  integer, intent(in):: km
6713  real, intent(in):: p00
6714  real, intent(inout), dimension(km+1):: pe
6715  real, intent(in), dimension(km+1):: ze
6716 ! pt: potential temperature / pk0
6717 ! qz: specific humidity (mixing ratio)
6718  real, intent(out), dimension(km):: pt, qz
6719 ! Local:
6720  integer, parameter:: nx = 5
6721  real, parameter:: qst = 1.0e-6
6722  real, parameter:: qv0 = 1.4e-2
6723  real, parameter:: ztr = 12.e3
6724  real, parameter:: ttr = 213.
6725  real, parameter:: ptr = 343. ! Tropopause potential temp.
6726  real, parameter:: pt0 = 300. ! surface potential temperature
6727  real, dimension(km):: zs, rh, temp, dp, dp0
6728  real, dimension(km+1):: peln, pk
6729  real:: qs, zvir, fac_z, pk0, temp1, pm
6730  integer:: k, n, kk
6731 
6732  zvir = rvgas/rdgas - 1.
6733  pk0 = p00**kappa
6734  if ( (is_master()) ) then
6735  write(*,*) 'Computing sounding for HIWPP super-cell test using p00=', p00
6736  endif
6737 
6738  qz(:) = qst
6739  rh(:) = 0.25
6740 
6741  do k=1, km
6742  zs(k) = 0.5*(ze(k)+ze(k+1))
6743 ! Potential temperature
6744  if ( zs(k) .gt. ztr ) then
6745 ! Stratosphere:
6746  pt(k) = ptr*exp(grav*(zs(k)-ztr)/(cp_air*ttr))
6747  else
6748 ! Troposphere:
6749  fac_z = (zs(k)/ztr)**1.25
6750  pt(k) = pt0 + (ptr-pt0)* fac_z
6751  rh(k) = 1. - 0.75 * fac_z
6752 ! First guess on q:
6753  qz(k) = qv0 - (qv0-qst)*fac_z
6754  endif
6755  if ( is_master() ) write(*,*) zs(k), pt(k), qz(k)
6756 ! Convert to FV's definition of potential temperature
6757  pt(k) = pt(k) / pk0
6758  enddo
6759 
6760 #ifdef USE_MOIST_P00
6761 !--------------------------------------
6762 ! Iterate nx times with virtual effect:
6763 !--------------------------------------
6764 ! pt & height remain unchanged
6765  pk(km+1) = pk0
6766  pe(km+1) = p00 ! Dry
6767  peln(km+1) = log(p00)
6768 
6769  do n=1, nx
6770 ! Derive pressure fields from hydrostatic balance:
6771  do k=km,1,-1
6772  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6773  peln(k) = log(pk(k)) / kappa
6774  pe(k) = exp(peln(k))
6775  enddo
6776  do k=1, km
6777  pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
6778  temp(k) = pt(k)*pm**kappa
6779 ! NCAR form:
6780  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6781  qz(k) = min( qv0, rh(k)*qs )
6782  if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
6783  enddo
6784  enddo
6785 #else
6786 ! pt & height remain unchanged
6787  pk(km+1) = pk0
6788  pe(km+1) = p00 ! Dry
6789  peln(km+1) = log(p00)
6790 
6791 ! Derive "dry" pressure fields from hydrostatic balance:
6792  do k=km,1,-1
6793  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k))
6794  peln(k) = log(pk(k)) / kappa
6795  pe(k) = exp(peln(k))
6796  enddo
6797  do k=1, km
6798  dp0(k) = pe(k+1) - pe(k)
6799  pm = dp0(k)/(peln(k+1)-peln(k))
6800  temp(k) = pt(k)*pm**kappa
6801 ! NCAR form:
6802  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6803  qz(k) = min( qv0, rh(k)*qs )
6804  enddo
6805 
6806  do n=1, nx
6807 
6808  do k=1, km
6809  dp(k) = dp0(k)*(1. + qz(k)) ! moist air
6810  pe(k+1) = pe(k) + dp(k)
6811  enddo
6812 ! dry pressure, pt & height remain unchanged
6813  pk(km+1) = pe(km+1)**kappa
6814  peln(km+1) = log(pe(km+1))
6815 
6816 ! Derive pressure fields from hydrostatic balance:
6817  do k=km,1,-1
6818  pk(k) = pk(k+1) - grav*(ze(k)-ze(k+1))/(cp_air*pt(k)*(1.+zvir*qz(k)))
6819  peln(k) = log(pk(k)) / kappa
6820  pe(k) = exp(peln(k))
6821  enddo
6822  do k=1, km
6823  pm = (pe(k+1)-pe(k))/(peln(k+1)-peln(k))
6824  temp(k) = pt(k)*pm**kappa
6825 ! NCAR form:
6826  qs = 380./pm*exp(17.27*(temp(k)-273.)/(temp(k)-36.))
6827  qz(k) = min( qv0, rh(k)*qs )
6828  if ( n==nx .and. is_master() ) write(*,*) 0.01*pm, temp(k), qz(k), qs
6829  enddo
6830  enddo
6831 #endif
6832 
6833  if ( is_master() ) then
6834  write(*,*) 'Super_K: computed ptop (mb)=', 0.01*pe(1), ' PS=', 0.01*pe(km+1)
6835  call prt_m1('1D Sounding T0', temp, 1, km, 1, 1, 0, 1, 1.)
6836  endif
6837 
6838  end subroutine superk_sounding
6839 
6840  subroutine balanced_k(km, is, ie, js, je, ng, ps0, ze1, ts1, qs1, uz1, dudz, pe, pk, pt, &
6841  delz, zvir, ptop, ak, bk, agrid)
6842  integer, intent(in):: is, ie, js, je, ng, km
6843  real, intent(in), dimension(km ):: ts1, qs1, uz1, dudz
6844  real, intent(in), dimension(km+1):: ze1
6845  real, intent(in):: zvir, ps0
6846  real, intent(inout):: ptop
6847  real(kind=R_GRID), intent(in):: agrid(is-ng:ie+ng,js-ng:je+ng,2)
6848  real, intent(inout), dimension(km+1):: ak, bk
6849  real, intent(inout), dimension(is-ng:ie+ng,js-ng:je+ng,km):: pt, delz
6850  real, intent(out), dimension(is:ie,js:je,km+1):: pk
6851 ! pt is FV's cp*thelta_v
6852  real, intent(inout), dimension(is-1:ie+1,km+1,js-1:je+1):: pe
6853 ! Local
6854  integer, parameter:: nt=5
6855  integer, parameter:: nlat=1001
6856  real, dimension(nlat,km):: pt2, pky, dzc
6857  real, dimension(nlat,km+1):: pk2, pe2, peln2, pte
6858  real, dimension(km+1):: pe1
6859  real:: lat(nlat), latc(nlat-1)
6860  real:: fac_y, dlat, dz0, pk0, tmp1, tmp2, tmp3, pint
6861  integer::i,j,k,n, jj, k1
6862  real:: p00=1.e5
6863 
6864  pk0 = p00**kappa
6865  dz0 = ze1(km) - ze1(km+1)
6866 !!! dzc(:,:) =dz0
6867 
6868  dlat = 0.5*pi/real(nlat-1)
6869  do j=1,nlat
6870  lat(j) = dlat*real(j-1)
6871  do k=1,km
6872  dzc(j,k) = ze1(k) - ze1(k+1)
6873  enddo
6874  enddo
6875  do j=1,nlat-1
6876  latc(j) = 0.5*(lat(j)+lat(j+1))
6877  enddo
6878 
6879 ! Initialize pt2
6880  do k=1,km
6881  do j=1,nlat
6882  pt2(j,k) = ts1(k)
6883  enddo
6884  enddo
6885  if ( is_master() ) then
6886  tmp1 = pk0/cp_air
6887  call prt_m1('Super_K PT0', pt2, 1, nlat, 1, km, 0, 1, tmp1)
6888  endif
6889 
6890 ! pt2 defined from Eq to NP
6891 ! Check NP
6892  do n=1, nt
6893 ! Compute edge values
6894  call ppme(pt2, pte, dzc, nlat, km)
6895  do k=1,km
6896  do j=2,nlat
6897  tmp1 = 0.5*(pte(j-1,k ) + pte(j,k ))
6898  tmp3 = 0.5*(pte(j-1,k+1) + pte(j,k+1))
6899  pt2(j,k) = pt2(j-1,k) + dlat/(2.*grav)*sin(2.*latc(j-1))*uz1(k)* &
6900  ( uz1(k)*(tmp1-tmp3)/dzc(j,k) - (pt2(j-1,k)+pt2(j,k))*dudz(k) )
6901  enddo
6902  enddo
6903  if ( is_master() ) then
6904  call prt_m1('Super_K PT', pt2, 1, nlat, 1, km, 0, 1, pk0/cp_air)
6905  endif
6906  enddo
6907 !
6908 ! Compute surface pressure using gradient-wind balance:
6909 !!! pk2(1,km+1) = pk0
6910  pk2(1,km+1) = ps0**kappa ! fixed at equator
6911  do j=2,nlat
6912  pk2(j,km+1) = pk2(j-1,km+1) - dlat*uz1(km)*uz1(km)*sin(2.*latc(j-1)) &
6913  / (pt2(j-1,km) + pt2(j,km))
6914  enddo
6915 ! Compute pressure using hydrostatic balance:
6916  do j=1,nlat
6917  do k=km,1,-1
6918  pk2(j,k) = pk2(j,k+1) - grav*dzc(j,k)/pt2(j,k)
6919  enddo
6920  enddo
6921 
6922  do k=1,km+1
6923  do j=1,nlat
6924  peln2(j,k) = log(pk2(j,k)) / kappa
6925  pe2(j,k) = exp(peln2(j,k))
6926  enddo
6927  enddo
6928 ! Convert pt2 to temperature
6929  do k=1,km
6930  do j=1,nlat
6931  pky(j,k) = (pk2(j,k+1)-pk2(j,k))/(kappa*(peln2(j,k+1)-peln2(j,k)))
6932  pt2(j,k) = pt2(j,k)*pky(j,k)/(cp_air*(1.+zvir*qs1(k)))
6933  enddo
6934  enddo
6935 
6936  do k=1,km+1
6937  pe1(k) = pe2(1,k)
6938  enddo
6939 
6940  if ( is_master() ) then
6941  write(*,*) 'SuperK ptop at EQ=', 0.01*pe1(1), 'new ptop=', 0.01*ptop
6942  call prt_m1('Super_K pe', pe2, 1, nlat, 1, km+1, 0, 1, 0.01)
6943  call prt_m1('Super_K Temp', pt2, 1, nlat, 1, km, 0, 1, 1.)
6944  endif
6945 
6946 ! Interpolate (pt2, pk2) from lat-dir to cubed-sphere
6947  do j=js, je
6948  do i=is, ie
6949  do jj=1,nlat-1
6950  if (abs(agrid(i,j,2))>=lat(jj) .and. abs(agrid(i,j,2))<=lat(jj+1) ) then
6951 ! found it !
6952  fac_y = (abs(agrid(i,j,2))-lat(jj)) / dlat
6953  do k=1,km
6954  pt(i, j,k) = pt2(jj, k) + fac_y*(pt2(jj+1, k)-pt2(jj,k))
6955  enddo
6956  do k=1,km+1
6957  pe(i,k,j) = pe2(jj,k) + fac_y*(pe2(jj+1,k)-pe2(jj,k))
6958  enddo
6959 ! k = km+1
6960 ! pk(i,j,k) = pk2(jj,k) + fac_y*(pk2(jj+1,k)-pk2(jj,k))
6961  goto 123
6962  endif
6963  enddo
6964 123 continue
6965  enddo
6966  enddo
6967 
6968 ! Adjust pk
6969 ! ak & bk
6970 ! Adjusting model top to be a constant pressure surface, assuming isothermal atmosphere
6971 ! pe = ak + bk*ps
6972 ! One pressure layer
6973  pe1(1) = ptop
6974  ak(1) = ptop
6975  pint = pe1(2)
6976  bk(1) = 0.
6977  ak(2) = pint
6978  bk(2) = 0.
6979  do k=3,km+1
6980  bk(k) = (pe1(k) - pint) / (pe1(km+1)-pint) ! bk == sigma
6981  ak(k) = pe1(k) - bk(k) * pe1(km+1)
6982  if ( is_master() ) write(*,*) k, ak(k), bk(k)
6983  enddo
6984  ak(km+1) = 0.
6985  bk(km+1) = 1.
6986  do j=js, je
6987  do i=is, ie
6988  pe(i,1,j) = ptop
6989  enddo
6990  enddo
6991 
6992 
6993  end subroutine balanced_k
6994 
6995  subroutine superk_u(km, zz, um, dudz)
6996  integer, intent(in):: km
6997  real, intent(in):: zz(km)
6998  real, intent(out):: um(km), dudz(km)
6999 ! Local
7000  real, parameter:: zs = 5.e3
7001  real, parameter:: us = 30.
7002  real:: uc = 15.
7003  integer k
7004 
7005  do k=1, km
7006 #ifndef TEST_TANHP
7007 ! MPAS specification:
7008  if ( zz(k) .gt. zs+1.e3 ) then
7009  um(k) = us
7010  dudz(k) = 0.
7011  elseif ( abs(zz(k)-zs) .le. 1.e3 ) then
7012  um(k) = us*(-4./5. + 3.*zz(k)/zs - 5./4.*(zz(k)/zs)**2)
7013  dudz(k) = us/zs*(3. - 5./2.*zz(k)/zs)
7014  else
7015  um(k) = us*zz(k)/zs
7016  dudz(k) = us/zs
7017  endif
7018 ! constant wind so as to make the storm relatively stationary
7019  um(k) = um(k) - uc
7020 #else
7021  uc = 12. ! this gives near stationary (in longitude) storms
7022  um(k) = us*tanh( zz(k)/zs ) - uc
7023  dudz(k) = (us/zs)/cosh(zz(k)/zs)**2
7024 #endif
7025  enddo
7026 
7027  end subroutine superk_u
7028 
7029 
7030  subroutine dcmip16_bc(delp,pt,u,v,q,w,delz,&
7031  is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7032  pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7033  hydrostatic, nwat, adiabatic, do_pert, domain)
7034 
7035  integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7036  real, intent(IN) :: ptop
7037  real, intent(IN), dimension(npz+1) :: ak, bk
7038  real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7039  real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz
7040  real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7041  real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7042  real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7043  real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7044  real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7045  real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7046  real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7047  real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7048  real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7049  real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7050  logical, intent(IN) :: hydrostatic,adiabatic,do_pert
7051  type(domain2d), intent(INOUT) :: domain
7052 
7053  real, parameter :: p0 = 1.e5
7054  real, parameter :: u0 = 35.
7055  real, parameter :: b = 2.
7056  real, parameter :: KK = 3.
7057  real, parameter :: Te = 310.
7058  real, parameter :: Tp = 240.
7059  real, parameter :: T0 = 0.5*(te + tp) !!WRONG in document
7060  real, parameter :: up = 1.
7061  real, parameter :: zp = 1.5e4
7062  real(kind=R_GRID), parameter :: lamp = pi/9.
7063  real(kind=R_GRID), parameter :: phip = 2.*lamp
7064  real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7065  real, parameter :: Rp = radius/10.
7066  real, parameter :: lapse = 5.e-3
7067  real, parameter :: dT = 4.8e5
7068  real, parameter :: phiW = 2.*pi/9.
7069  real, parameter :: pW = 34000.
7070  real, parameter :: q0 = .018
7071  real, parameter :: qt = 1.e-12
7072  real, parameter :: ptrop = 1.e4
7073 
7074  real, parameter :: zconv = 1.e-6
7075  real, parameter :: rdgrav = rdgas/grav
7076  real, parameter :: zvir = rvgas/rdgas - 1.
7077  real, parameter :: rrdgrav = grav/rdgas
7078 
7079  integer :: i,j,k,iter, sphum, cl, cl2, n
7080  real :: p,z,z0,ziter,piter,titer,uu,vv,pl,pt_u,pt_v
7081  real(kind=R_GRID), dimension(2) :: pa
7082  real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7083  real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2
7084  real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7085  real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2
7086  real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7087 
7088  !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7089  ! (with or without perturbation), moisture, Terminator tracer, w, delz
7090 
7091  !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7092  ! and meridional winds on both grids, and rotate as needed
7093 
7094  !PS
7095  do j=js,je
7096  do i=is,ie
7097  ps(i,j) = p0
7098  enddo
7099  enddo
7100 
7101  !delp
7102  do k=1,npz
7103  do j=js,je
7104  do i=is,ie
7105  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7106  enddo
7107  enddo
7108  enddo
7109 
7110  !Pressure variables
7111  do j=js,je
7112  do i=is,ie
7113  pe(i,1,j) = ptop
7114  enddo
7115  do i=is,ie
7116  peln(i,1,j) = log(ptop)
7117  pk(i,j,1) = ptop**kappa
7118  enddo
7119  do k=2,npz+1
7120  do i=is,ie
7121  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
7122  enddo
7123  do i=is,ie
7124  pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7125  peln(i,k,j) = log(pe(i,k,j))
7126  enddo
7127  enddo
7128  enddo
7129 
7130  do k=1,npz
7131  do j=js,je
7132  do i=is,ie
7133  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7134  enddo
7135  enddo
7136  enddo
7137 
7138  !Height: Use Newton's method
7139  !Cell centered
7140  do j=js,je
7141  do i=is,ie
7142  phis(i,j) = 0.
7143  gz(i,j,npz+1) = 0.
7144  enddo
7145  enddo
7146  do k=npz,1,-1
7147  do j=js,je
7148  do i=is,ie
7149  p = pe(i,k,j)
7150  z = gz(i,j,k+1)
7151  do iter=1,30
7152  ziter = z
7153  piter = dcmip16_bc_pressure(ziter,agrid(i,j,2))
7154  titer = dcmip16_bc_temperature(ziter,agrid(i,j,2))
7155  z = ziter + (piter - p)*rdgrav*titer/piter
7156 !!$ !!! DEBUG CODE
7157 !!$ if (is_master() .and. i == is .and. j == js) then
7158 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7159 !!$ endif
7160 !!$ !!! END DEBUG CODE
7161  if (abs(z - ziter) < zconv) exit
7162  enddo
7163  gz(i,j,k) = z
7164  enddo
7165  enddo
7166  enddo
7167 
7168  !Temperature: Compute from hydro balance
7169  do k=1,npz
7170  do j=js,je
7171  do i=is,ie
7172  pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7173  enddo
7174  enddo
7175  enddo
7176 
7177  !Compute height and temperature for u and v points also, to be able to compute the local winds
7178  !Use temporary 2d arrays for this purpose
7179  do j=js,je+1
7180  do i=is,ie
7181  gz_u(i,j) = 0.
7182  p_u(i,j) = p0
7183  peln_u(i,j) = log(p0)
7184  ps_u(i,j) = p0
7185  call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7186  lat_u(i,j) = pa(2)
7187  lon_u(i,j) = pa(1)
7188  call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7189  call get_latlon_vector(pa,ex,ey)
7190  u1(i,j) = inner_prod(e1,ex) !u components
7191  u2(i,j) = inner_prod(e1,ey)
7192  enddo
7193  enddo
7194  do k=npz,1,-1
7195  do j=js,je+1
7196  do i=is,ie
7197  !Pressure (Top of interface)
7198  p = ak(k) + ps_u(i,j)*bk(k)
7199  pl = log(p)
7200  !Height (top of interface); use newton's method
7201  z = gz_u(i,j) !first guess, height of lower level
7202  z0 = z
7203  do iter=1,30
7204  ziter = z
7205  piter = dcmip16_bc_pressure(ziter,lat_u(i,j))
7206  titer = dcmip16_bc_temperature(ziter,lat_u(i,j))
7207  z = ziter + (piter - p)*rdgrav*titer/piter
7208  if (abs(z - ziter) < zconv) exit
7209  enddo
7210  !Temperature, compute from hydro balance
7211  pt_u = rrdgrav * ( z - gz_u(i,j) ) / (peln_u(i,j) - pl)
7212  !Now compute winds. Note no meridional winds
7213  !!!NOTE: do we need to use LAYER-mean z?
7214  uu = dcmip16_bc_uwind(0.5*(z+z0),pt_u,lat_u(i,j))
7215  if (do_pert) then
7216  uu = uu + dcmip16_bc_uwind_pert(0.5*(z+z0),lat_u(i,j),lon_u(i,j))
7217  endif
7218  u(i,j,k) = u1(i,j)*uu
7219 
7220  gz_u(i,j) = z
7221  p_u(i,j) = p
7222  peln_u(i,j) = pl
7223  enddo
7224  enddo
7225  enddo
7226 
7227  do j=js,je
7228  do i=is,ie+1
7229  gz_v(i,j) = 0.
7230  p_v(i,j) = p0
7231  peln_v(i,j) = log(p0)
7232  ps_v(i,j) = p0
7233  call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7234  lat_v(i,j) = pa(2)
7235  lon_v(i,j) = pa(1)
7236  call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7237  call get_latlon_vector(pa,ex,ey)
7238  v1(i,j) = inner_prod(e2,ex) !v components
7239  v2(i,j) = inner_prod(e2,ey)
7240  enddo
7241  enddo
7242  do k=npz,1,-1
7243  do j=js,je
7244  do i=is,ie+1
7245  !Pressure (Top of interface)
7246  p = ak(k) + ps_v(i,j)*bk(k)
7247  pl = log(p)
7248  !Height (top of interface); use newton's method
7249  z = gz_v(i,j) !first guess, height of lower level
7250  z0 = z
7251  do iter=1,30
7252  ziter = z
7253  piter = dcmip16_bc_pressure(ziter,lat_v(i,j))
7254  titer = dcmip16_bc_temperature(ziter,lat_v(i,j))
7255  z = ziter + (piter - p)*rdgrav*titer/piter
7256  if (abs(z - ziter) < zconv) exit
7257  enddo
7258  !Temperature, compute from hydro balance
7259  pt_v = rrdgrav * ( z - gz_v(i,j) ) / (peln_v(i,j) - pl)
7260  !Now compute winds
7261  uu = dcmip16_bc_uwind(0.5*(z+z0),pt_v,lat_v(i,j))
7262  if (do_pert) then
7263  uu = uu + dcmip16_bc_uwind_pert(0.5*(z+z0),lat_v(i,j),lon_v(i,j))
7264  endif
7265  v(i,j,k) = v1(i,j)*uu
7266  gz_v(i,j) = z
7267  p_v(i,j) = p
7268  peln_v(i,j) = pl
7269  enddo
7270  enddo
7271  enddo
7272 
7273  !Compute moisture and other tracer fields, as desired
7274  do n=1,nq
7275  do k=1,npz
7276  do j=jsd,jed
7277  do i=isd,ied
7278  q(i,j,k,n) = 0.
7279  enddo
7280  enddo
7281  enddo
7282  enddo
7283  if (.not. adiabatic) then
7284  sphum = get_tracer_index(model_atmos, 'sphum')
7285  do k=1,npz
7286  do j=js,je
7287  do i=is,ie
7288  p = delp(i,j,k)/(peln(i,k+1,j) - peln(i,k,j))
7289  q(i,j,k,sphum) = dcmip16_bc_sphum(p,ps(i,j),agrid(i,j,2),agrid(i,j,1))
7290  !Convert pt to non-virtual temperature
7291  pt(i,j,k) = pt(i,j,k) / ( 1. + zvir*q(i,j,k,sphum))
7292  enddo
7293  enddo
7294  enddo
7295  endif
7296 
7297  cl = get_tracer_index(model_atmos, 'cl')
7298  cl2 = get_tracer_index(model_atmos, 'cl2')
7299  if (cl > 0 .and. cl2 > 0) then
7300  call terminator_tracers(is,ie,js,je,isd,ied,jsd,jed,npz, &
7301  q, delp,nq,agrid(isd,jsd,1),agrid(isd,jsd,2))
7302  call mpp_update_domains(q,domain)
7303  endif
7304 
7305  !Compute nonhydrostatic variables, if needed
7306  if (.not. hydrostatic) then
7307  do k=1,npz
7308  do j=js,je
7309  do i=is,ie
7310  w(i,j,k) = 0.
7311  delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7312  enddo
7313  enddo
7314  enddo
7315  endif
7316 
7317  contains
7318 
7319 
7320  real function dcmip16_bc_temperature(z, lat)
7321 
7322  real, intent(IN) :: z
7323  real(kind=R_GRID), intent(IN) :: lat
7324  real :: it, t1, t2, tr, zsc
7325 
7326  it = exp(kk * log(cos(lat))) - kk/(kk+2.)*exp((kk+2.)*log(cos(lat)))
7327  zsc = z*grav/(b*rdgas*t0)
7328  tr = ( 1. - 2.*zsc**2.) * exp(-zsc**2. )
7329 
7330  t1 = (1./t0)*exp(lapse*z/t0) + (t0 - tp)/(t0*tp) * tr
7331  t2 = 0.5* ( kk + 2.) * (te - tp)/(te*tp) * tr
7332 
7333  dcmip16_bc_temperature = 1./(t1 - t2*it)
7334 
7335  end function dcmip16_bc_temperature
7336 
7337  real function dcmip16_bc_pressure(z,lat)
7338 
7339  real, intent(IN) :: z
7340  real(kind=R_GRID), intent(IN) :: lat
7341  real :: it, ti1, ti2, tir
7342 
7343  it = exp(kk * log(cos(lat))) - kk/(kk+2.)*exp((kk+2.)*log(cos(lat)))
7344  tir = z*exp(-(z*grav/(b*rdgas*t0))*(z*grav/(b*rdgas*t0)) )
7345 
7346  ti1 = 1./lapse* (exp(lapse*z/t0) - 1.) + tir*(t0-tp)/(t0*tp)
7347  ti2 = 0.5*(kk+2.)*(te-tp)/(te*tp) * tir
7348 
7349  dcmip16_bc_pressure = p0*exp(-grav/rdgas * ( ti1 - ti2*it))
7350 
7351  end function dcmip16_bc_pressure
7352 
7353  real function dcmip16_bc_uwind(z,T,lat)
7354 
7355  real, intent(IN) :: z, t
7356  real(kind=R_GRID), intent(IN) :: lat
7357  real :: tir, ti2, uu, ur
7358 
7359  tir = z*exp(-(z*grav/(b*rdgas*t0))*(z*grav/(b*rdgas*t0)) )
7360  ti2 = 0.5*(kk+2.)*(te-tp)/(te*tp) * tir
7361 
7362  uu = grav*kk/radius * ti2 * ( cos(lat)**(int(kk)-1) - cos(lat)**(int(kk)+1) ) * t
7363  ur = - omega * radius * cos(lat) + sqrt( (omega*radius*cos(lat))**2 + radius*cos(lat)*uu)
7364 
7365  dcmip16_bc_uwind = ur
7366 
7367  end function dcmip16_bc_uwind
7368 
7369  real function dcmip16_bc_uwind_pert(z,lat,lon)
7370 
7371  real, intent(IN) :: z
7372  real(kind=R_GRID), intent(IN) :: lat, lon
7373  real :: zz, zrat
7374  real(kind=R_GRID) :: dst, pphere(2)
7375 
7376  zrat = z/zp
7377  zz = max(1. - 3.*zrat*zrat + 2.*zrat*zrat*zrat, 0.)
7378 
7379  pphere = (/ lon, lat /)
7380  dst = great_circle_dist(pphere, ppcenter, radius)
7381 
7382  dcmip16_bc_uwind_pert = max(0., up*zz*exp(-(dst/rp)**2) )
7383 
7384  end function dcmip16_bc_uwind_pert
7385 
7386  real function dcmip16_bc_sphum(p,ps,lat, lon)
7387 
7388  real, intent(IN) :: p, ps
7389  real(kind=R_GRID), intent(IN) :: lat, lon
7390  real :: eta
7391 
7392  eta = p/ps
7393 
7394  dcmip16_bc_sphum = qt
7395  if (p > ptrop) then
7396  dcmip16_bc_sphum = q0 * exp(-(lat/phiw)**4) * exp(-( (eta-1.)*p0/pw)**2)
7397  endif
7398 
7399  end function dcmip16_bc_sphum
7400 
7401  end subroutine dcmip16_bc
7402 
7403  subroutine dcmip16_tc(delp,pt,u,v,q,w,delz,&
7404  is,ie,js,je,isd,ied,jsd,jed,npz,nq,ak,bk,ptop, &
7405  pk,peln,pe,pkz,gz,phis,ps,grid,agrid, &
7406  hydrostatic, nwat, adiabatic)
7407 
7408  integer, intent(IN) :: is,ie,js,je,isd,ied,jsd,jed,npz,nq, nwat
7409  real, intent(IN) :: ptop
7410  real, intent(IN), dimension(npz+1) :: ak, bk
7411  real, intent(INOUT), dimension(isd:ied,jsd:jed,npz,nq) :: q
7412  real, intent(OUT), dimension(isd:ied,jsd:jed,npz) :: delp, pt, w, delz
7413  real, intent(OUT), dimension(isd:ied,jsd:jed+1,npz) :: u
7414  real, intent(OUT), dimension(isd:ied+1,jsd:jed,npz) :: v
7415  real, intent(OUT), dimension(is:ie,js:je,npz+1) :: pk
7416  real, intent(OUT), dimension(is:ie,npz+1,js:je) :: peln
7417  real, intent(OUT), dimension(is-1:ie+1,npz+1,js-1:je+1) :: pe
7418  real, intent(OUT), dimension(is:ie,js:je,npz) :: pkz
7419  real, intent(OUT), dimension(isd:ied,jsd:jed) :: phis,ps
7420  real(kind=R_GRID), intent(IN), dimension(isd:ied,jsd:jed,2) :: agrid
7421  real(kind=R_GRID), intent(IN), dimension(isd:ied+1,jsd:jed+1,2) :: grid
7422  real, intent(OUT), dimension(isd:ied,jsd:jed,npz+1) :: gz
7423  logical, intent(IN) :: hydrostatic,adiabatic
7424 
7425  real, parameter :: zt = 15000 ! m
7426  real, parameter :: q0 = 0.021 ! kg/kg
7427  real, parameter :: qt = 1.e-11 ! kg/kg
7428  real, parameter :: T0 = 302.15 ! K
7429  real, parameter :: Tv0 = 302.15*(1.+0.608*q0) ! K
7430  real, parameter :: Ts = 302.15 ! K
7431  real, parameter :: zq1 = 3000. ! m
7432  real, parameter :: zq2 = 8000. ! m
7433  real, parameter :: lapse = 7.e-3 ! K/m
7434  real, parameter :: Tvt = tv0 - lapse*zt ! K
7435  real, parameter :: pb = 101500. ! Pa
7436  real, parameter :: ptt = pb*(tvt/tv0)**(grav/rdgas/lapse)
7437  real(kind=R_GRID), parameter :: lamp = pi
7438  real(kind=R_GRID), parameter :: phip = pi/18.
7439  real(kind=R_GRID), parameter :: ppcenter(2) = (/ lamp, phip /)
7440  real, parameter :: dp = 1115. ! Pa
7441  real, parameter :: rp = 282000. ! m
7442  real, parameter :: zp = 7000. ! m
7443  real, parameter :: fc = 2.*omega*sin(phip)
7444 
7445  real, parameter :: zconv = 1.e-6
7446  real, parameter :: rdgrav = rdgas/grav
7447  real, parameter :: rrdgrav = grav/rdgas
7448 
7449  integer :: i,j,k,iter, sphum, cl, cl2, n
7450  real :: p,z,z0,ziter,piter,titer,uu,vv,pl, r
7451  real(kind=R_GRID), dimension(2) :: pa
7452  real(kind=R_GRID), dimension(3) :: e1,e2,ex,ey
7453  real, dimension(is:ie,js:je) :: rc
7454  real, dimension(is:ie,js:je+1) :: gz_u,p_u,peln_u,ps_u,u1,u2, rc_u
7455  real(kind=R_GRID), dimension(is:ie,js:je+1) :: lat_u,lon_u
7456  real, dimension(is:ie+1,js:je) :: gz_v,p_v,peln_v,ps_v,v1,v2, rc_v
7457  real(kind=R_GRID), dimension(is:ie+1,js:je) :: lat_v,lon_v
7458 
7459  !Compute ps, phis, delp, aux pressure variables, Temperature, winds
7460  ! (with or without perturbation), moisture, w, delz
7461 
7462  !Compute p, z, T on both the staggered and unstaggered grids. Then compute the zonal
7463  ! and meridional winds on both grids, and rotate as needed
7464 
7465  !Save r for easy use
7466  do j=js,je
7467  do i=is,ie
7468  rc(i,j) = great_circle_dist(agrid(i,j,:), ppcenter, radius)
7469  enddo
7470  enddo
7471 
7472  !PS
7473  do j=js,je
7474  do i=is,ie
7475  ps(i,j) = pb - dp*exp( -sqrt((rc(i,j)/rp)**3) )
7476  enddo
7477  enddo
7478 
7479  !delp
7480  do k=1,npz
7481  do j=js,je
7482  do i=is,ie
7483  delp(i,j,k) = ak(k+1)-ak(k) + ps(i,j)*(bk(k+1)-bk(k))
7484  enddo
7485  enddo
7486  enddo
7487 
7488  !Pressure variables
7489  do j=js,je
7490  do i=is,ie
7491  pe(i,1,j) = ptop
7492  enddo
7493  do i=is,ie
7494  peln(i,1,j) = log(ptop)
7495  pk(i,j,1) = ptop**kappa
7496  enddo
7497  do k=2,npz+1
7498  do i=is,ie
7499  pe(i,k,j) = ak(k) + ps(i,j)*bk(k)
7500  enddo
7501  do i=is,ie
7502  pk(i,j,k) = exp(kappa*log(pe(i,k,j)))
7503  peln(i,k,j) = log(pe(i,k,j))
7504  enddo
7505  enddo
7506  enddo
7507 
7508  do k=1,npz
7509  do j=js,je
7510  do i=is,ie
7511  pkz(i,j,k) = (pk(i,j,k+1)-pk(i,j,k))/(kappa*(peln(i,k+1,j)-peln(i,k,j)))
7512  enddo
7513  enddo
7514  enddo
7515 
7516  !Height: Use Newton's method
7517  !Cell centered
7518  do j=js,je
7519  do i=is,ie
7520  phis(i,j) = 0.
7521  gz(i,j,npz+1) = 0.
7522  enddo
7523  enddo
7524  do k=npz,1,-1
7525  do j=js,je
7526  do i=is,ie
7527  p = pe(i,k,j)
7528  z = gz(i,j,k+1)
7529  do iter=1,30
7530  ziter = z
7531  piter = dcmip16_tc_pressure(ziter,rc(i,j))
7532  titer = dcmip16_tc_temperature(ziter,rc(i,j))
7533  z = ziter + (piter - p)*rdgrav*titer/piter
7534 !!$ !!! DEBUG CODE
7535 !!$ if (is_master() .and. i == is .and. j == js) then
7536 !!$ write(*,'(A,I,2x,I, 4(2x,F10.3), 2x, F7.3)') ' NEWTON: ' , k, iter, piter, p, ziter, z, titer
7537 !!$ endif
7538 !!$ !!! END DEBUG CODE
7539  if (abs(z - ziter) < zconv) exit
7540  enddo
7541  gz(i,j,k) = z
7542  enddo
7543  enddo
7544  enddo
7545 
7546  !Temperature: Compute from hydro balance
7547  do k=1,npz
7548  do j=js,je
7549  do i=is,ie
7550  pt(i,j,k) = rrdgrav * ( gz(i,j,k) - gz(i,j,k+1) ) / ( peln(i,k+1,j) - peln(i,k,j))
7551  enddo
7552  enddo
7553  enddo
7554 
7555  !Compute height and temperature for u and v points also, to be able to compute the local winds
7556  !Use temporary 2d arrays for this purpose
7557  do j=js,je+1
7558  do i=is,ie
7559  call mid_pt_sphere(grid(i,j,:),grid(i+1,j,:),pa)
7560  lat_u(i,j) = pa(2)
7561  lon_u(i,j) = pa(1)
7562  call get_unit_vect2(grid(i,j,:),grid(i+1,j,:),e1)
7563  call get_latlon_vector(pa,ex,ey)
7564  u1(i,j) = inner_prod(e1,ex) !u components
7565  u2(i,j) = inner_prod(e1,ey)
7566  rc_u(i,j) = great_circle_dist(pa, ppcenter, radius)
7567  gz_u(i,j) = 0.
7568  p_u(i,j) = pb - dp*exp( -sqrt((rc_u(i,j)/rp)**3) )
7569  peln_u(i,j) = log(p_u(i,j))
7570  ps_u(i,j) = p_u(i,j)
7571  enddo
7572  enddo
7573  do k=npz,1,-1
7574  do j=js,je+1
7575  do i=is,ie
7576  !Pressure (Top of interface)
7577  p = ak(k) + ps_u(i,j)*bk(k)
7578  pl = log(p)
7579  !Height (top of interface); use newton's method
7580  z = gz_u(i,j) !first guess, height of lower level
7581  z0 = z
7582  do iter=1,30
7583  ziter = z
7584  piter = dcmip16_tc_pressure(ziter,rc_u(i,j))
7585  titer = dcmip16_tc_temperature(ziter,rc_u(i,j))
7586  z = ziter + (piter - p)*rdgrav*titer/piter
7587  if (abs(z - ziter) < zconv) exit
7588  enddo
7589  !Now compute winds
7590  call dcmip16_tc_uwind_pert(0.5*(z+z0),rc_u(i,j),lon_u(i,j),lat_u(i,j), uu, vv)
7591  u(i,j,k) = u1(i,j)*uu + u2(i,j)*vv
7592 
7593  gz_u(i,j) = z
7594  p_u(i,j) = p
7595  peln_u(i,j) = pl
7596  enddo
7597  enddo
7598  enddo
7599 
7600  do j=js,je
7601  do i=is,ie+1
7602  call mid_pt_sphere(grid(i,j,:),grid(i,j+1,:),pa)
7603  lat_v(i,j) = pa(2)
7604  lon_v(i,j) = pa(1)
7605  call get_unit_vect2(grid(i,j,:),grid(i,j+1,:),e2)
7606  call get_latlon_vector(pa,ex,ey)
7607  v1(i,j) = inner_prod(e2,ex) !v components
7608  v2(i,j) = inner_prod(e2,ey)
7609  rc_v(i,j) = great_circle_dist(pa, ppcenter, radius)
7610  gz_v(i,j) = 0.
7611  p_v(i,j) = pb - dp*exp( - sqrt((rc_v(i,j)/rp)**3) )
7612  peln_v(i,j) = log(p_v(i,j))
7613  ps_v(i,j) = p_v(i,j)
7614  enddo
7615  enddo
7616  do k=npz,1,-1
7617  do j=js,je
7618  do i=is,ie+1
7619  !Pressure (Top of interface)
7620  p = ak(k) + ps_v(i,j)*bk(k)
7621  pl = log(p)
7622  !Height (top of interface); use newton's method
7623  z = gz_v(i,j) !first guess, height of lower level
7624  z0 = z
7625  do iter=1,30
7626  ziter = z
7627  piter = dcmip16_tc_pressure(ziter,rc_v(i,j))
7628  titer = dcmip16_tc_temperature(ziter,rc_v(i,j))
7629  z = ziter + (piter - p)*rdgrav*titer/piter
7630  if (abs(z - ziter) < zconv) exit
7631  enddo
7632  !Now compute winds
7633  call dcmip16_tc_uwind_pert(0.5*(z+z0),rc_v(i,j),lon_v(i,j),lat_v(i,j), uu, vv)
7634  v(i,j,k) = v1(i,j)*uu + v2(i,j)*vv
7635  gz_v(i,j) = z
7636  p_v(i,j) = p
7637  peln_v(i,j) = pl
7638  enddo
7639  enddo
7640  enddo
7641 
7642  !Compute moisture and other tracer fields, as desired
7643  do n=1,nq
7644  do k=1,npz
7645  do j=jsd,jed
7646  do i=isd,ied
7647  q(i,j,k,n) = 0.
7648  enddo
7649  enddo
7650  enddo
7651  enddo
7652  if (.not. adiabatic) then
7653  sphum = get_tracer_index(model_atmos, 'sphum')
7654  do k=1,npz
7655  do j=js,je
7656  do i=is,ie
7657  z = 0.5*(gz(i,j,k) + gz(i,j,k+1))
7658  q(i,j,k,sphum) = dcmip16_tc_sphum(z)
7659  enddo
7660  enddo
7661  enddo
7662  endif
7663 
7664  !Compute nonhydrostatic variables, if needed
7665  if (.not. hydrostatic) then
7666  do k=1,npz
7667  do j=js,je
7668  do i=is,ie
7669  w(i,j,k) = 0.
7670  delz(i,j,k) = gz(i,j,k) - gz(i,j,k+1)
7671  enddo
7672  enddo
7673  enddo
7674  endif
7675 
7676  contains
7677 
7678  !Initialize with virtual temperature
7679  real function dcmip16_tc_temperature(z, r)
7680 
7681  real, intent(IN) :: z, r
7682  real :: tv, term1, term2
7683 
7684  if (z > zt) then
7685  dcmip16_tc_temperature = tvt
7686  return
7687  endif
7688 
7689  tv = tv0 - lapse*z
7690  term1 = grav*zp*zp* ( 1. - pb/dp * exp( sqrt(r/rp)**3 + (z/zp)**2 ) )
7691  term2 = 2*rdgas*tv*z
7692  dcmip16_tc_temperature = tv + tv*( 1./(1 + term2/term1) - 1.)
7693 
7694  end function dcmip16_tc_temperature
7695 
7696  !Initialize with moist air mass
7697  real function dcmip16_tc_pressure(z, r)
7698 
7699  real, intent(IN) :: z, r
7700 
7701  if (z <= zt) then
7702  dcmip16_tc_pressure = pb*exp(grav/(rdgas*lapse) * log( (tv0-lapse*z)/tv0) ) -dp* exp(-sqrt((r/rp)**3) - (z/zp)**2) * &
7703  exp( grav/(rdgas*lapse) * log( (tv0-lapse*z)/tv0) )
7704  else
7705  dcmip16_tc_pressure = ptt*exp(grav*(zt-z)/(rdgas*tvt))
7706  endif
7707 
7708  end function dcmip16_tc_pressure
7709 
7710  subroutine dcmip16_tc_uwind_pert(z,r,lon,lat,uu,vv)
7711 
7712  real, intent(IN) :: z, r
7713  real(kind=R_GRID), intent(IN) :: lon, lat
7714  real, intent(OUT) :: uu, vv
7715  real :: rfac, Tvrd, vt, fr5, d1, d2, d
7716  real(kind=R_GRID) :: dst, pphere(2)
7717 
7718  if (z > zt) then
7719  uu = 0.
7720  vv = 0.
7721  return
7722  endif
7723 
7724  rfac = sqrt(r/rp)**3
7725 
7726  fr5 = 0.5*fc*r
7727  tvrd = (tv0 - lapse*z)*rdgas
7728 
7729  vt = -fr5 + sqrt( fr5**2 - (1.5 * rfac * tvrd) / &
7730  ( 1. + 2*tvrd*z/(grav*zp**2) - pb/dp*exp( rfac + (z/zp)**2) ) )
7731 
7732  d1 = sin(phip)*cos(lat) - cos(phip)*sin(lat)*cos(lon - lamp)
7733  d2 = cos(phip)*sin(lon - lamp)
7734  d = max(1.e-25,sqrt(d1*d1 + d2*d2))
7735 
7736  uu = vt * d1/d
7737  vv = vt * d2/d
7738 
7739  end subroutine dcmip16_tc_uwind_pert
7740 
7741  real function dcmip16_tc_sphum(z)
7742 
7743  real, intent(IN) :: z
7744 
7745  dcmip16_tc_sphum = qt
7746  if (z < zt) then
7747  dcmip16_tc_sphum = q0 * exp(-z/zq1) * exp(-(z/zq2 )**2)
7748  endif
7749 
7750  end function dcmip16_tc_sphum
7751 
7752  end subroutine dcmip16_tc
7753 
7754  subroutine init_latlon(u,v,pt,delp,q,phis, ps,pe,peln,pk,pkz, uc,vc, ua,va, ak, bk, &
7755  gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, &
7756  mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in)
7757 
7758  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz)
7759  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz)
7760  real , intent(INOUT) :: pt(isd:ied ,jsd:jed ,npz)
7761  real , intent(INOUT) :: delp(isd:ied ,jsd:jed ,npz)
7762  real , intent(INOUT) :: q(isd:ied ,jsd:jed ,npz, ncnst)
7763 
7764  real , intent(INOUT) :: phis(isd:ied ,jsd:jed )
7765 
7766  real , intent(INOUT) :: ps(isd:ied ,jsd:jed )
7767  real , intent(INOUT) :: pe(is-1:ie+1,npz+1,js-1:je+1)
7768  real , intent(INOUT) :: pk(is:ie ,js:je ,npz+1)
7769  real , intent(INOUT) :: peln(is :ie ,npz+1 ,js:je)
7770  real , intent(INOUT) :: pkz(is:ie ,js:je ,npz )
7771  real , intent(INOUT) :: uc(isd:ied+1,jsd:jed ,npz)
7772  real , intent(INOUT) :: vc(isd:ied ,jsd:jed+1,npz)
7773  real , intent(INOUT) :: ua(isd:ied ,jsd:jed ,npz)
7774  real , intent(INOUT) :: va(isd:ied ,jsd:jed ,npz)
7775  real , intent(inout) :: delz(isd:,jsd:,1:)
7776  real , intent(inout) :: ze0(is:,js:,1:)
7777 
7778  real , intent(IN) :: ak(npz+1)
7779  real , intent(IN) :: bk(npz+1)
7780 
7781  integer, intent(IN) :: npx, npy, npz
7782  integer, intent(IN) :: ng, ncnst
7783  integer, intent(IN) :: ndims
7784  integer, intent(IN) :: nregions
7785  integer,target,intent(IN):: tile_in
7786 
7787  real, intent(IN) :: dry_mass
7788  logical, intent(IN) :: mountain
7789  logical, intent(IN) :: moist_phys
7790  logical, intent(IN) :: hybrid_z
7791 
7792  type(fv_grid_type), intent(IN), target :: gridstruct
7793  type(domain2d), intent(IN), target :: domain_in
7794 
7795  real, pointer, dimension(:,:,:) :: agrid, grid
7796  real, pointer, dimension(:,:) :: area, rarea, fc, f0
7797  real, pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
7798  real, pointer, dimension(:,:,:,:) :: ew, es
7799  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
7800 
7801  logical, pointer :: cubed_sphere, latlon
7802 
7803  type(domain2d), pointer :: domain
7804  integer, pointer :: tile
7805 
7806  logical, pointer :: have_south_pole, have_north_pole
7807 
7808  integer, pointer :: ntiles_g
7809  real, pointer :: acapn, acaps, globalarea
7810 
7811  real(kind=R_GRID) :: p1(2), p2(2)
7812  real :: r, r0
7813  integer :: i,j
7814 
7815  agrid => gridstruct%agrid
7816  grid => gridstruct%grid
7817 
7818  area => gridstruct%area
7819 
7820  dx => gridstruct%dx
7821  dy => gridstruct%dy
7822  dxa => gridstruct%dxa
7823  dya => gridstruct%dya
7824  rdxa => gridstruct%rdxa
7825  rdya => gridstruct%rdya
7826  dxc => gridstruct%dxc
7827  dyc => gridstruct%dyc
7828 
7829  fc => gridstruct%fC
7830  f0 => gridstruct%f0
7831 
7832  ntiles_g => gridstruct%ntiles_g
7833  acapn => gridstruct%acapN
7834  acaps => gridstruct%acapS
7835  globalarea => gridstruct%globalarea
7836 
7837  domain => domain_in
7838  tile => tile_in
7839 
7840  have_south_pole => gridstruct%have_south_pole
7841  have_north_pole => gridstruct%have_north_pole
7842 
7843  do j=jsd,jed+1
7844  do i=isd,ied+1
7845  fc(i,j) = 2.*omega*( -cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) &
7846  +sin(grid(i,j,2))*cos(alpha) )
7847  enddo
7848  enddo
7849  do j=jsd,jed
7850  do i=isd,ied
7851  f0(i,j) = 2.*omega*( -cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) &
7852  +sin(agrid(i,j,2))*cos(alpha) )
7853  enddo
7854  enddo
7855 
7856  select case (test_case)
7857  case ( 1 )
7858 
7859  ubar = (2.0*pi*radius)/(12.0*86400.0)
7860  phis = 0.0
7861  r0 = radius/3. !RADIUS radius/3.
7862 !!$ p1(1) = 0.
7863  p1(1) = pi/2. + pi_shift
7864  p1(2) = 0.
7865  do j=jsd,jed
7866  do i=isd,ied
7867  p2(1) = agrid(i,j,1)
7868  p2(2) = agrid(i,j,2)
7869  r = great_circle_dist( p1, p2, radius )
7870  if (r < r0) then
7871  delp(i,j,1) = phis(i,j) + 0.5*(1.0+cos(pi*r/r0))
7872  else
7873  delp(i,j,1) = phis(i,j)
7874  endif
7875  enddo
7876  enddo
7877  call init_latlon_winds(ubar, u, v, ua, va, uc, vc, 1, gridstruct)
7878 
7879 
7880 !!$ phis(:,:)=0.
7881 !!$
7882 !!$ u (:,:,:)=10.
7883 !!$ v (:,:,:)=10.
7884 !!$ ua(:,:,:)=10.
7885 !!$ va(:,:,:)=10.
7886 !!$ uc(:,:,:)=10.
7887 !!$ vc(:,:,:)=10.
7888 !!$ pt(:,:,:)=1.
7889 !!$ delp(:,:,:)=0.
7890 !!$
7891 !!$ do j=js,je
7892 !!$ if (j>10 .and. j<15) then
7893 !!$ do i=is,ie
7894 !!$ if (i>10 .and. i<15) then
7895 !!$ delp(i,j,:)=1.
7896 !!$ endif
7897 !!$ enddo
7898 !!$ endif
7899 !!$ enddo
7900 !!$ call mpp_update_domains( delp, domain )
7901 
7902  end select
7903 
7904  nullify(grid)
7905  nullify(agrid)
7906 
7907  nullify(area)
7908 
7909  nullify(fc)
7910  nullify(f0)
7911 
7912  nullify(dx)
7913  nullify(dy)
7914  nullify(dxa)
7915  nullify(dya)
7916  nullify(rdxa)
7917  nullify(rdya)
7918  nullify(dxc)
7919  nullify(dyc)
7920 
7921  nullify(domain)
7922  nullify(tile)
7923 
7924  nullify(have_south_pole)
7925  nullify(have_north_pole)
7926 
7927  nullify(ntiles_g)
7928  nullify(acapn)
7929  nullify(acaps)
7930  nullify(globalarea)
7931 
7932  end subroutine init_latlon
7933 
7934  subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct)
7935 
7936  ! 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
7937 
7938  real, intent(INOUT) :: UBar
7939  real, intent(INOUT) :: u(isd:ied ,jsd:jed+1)
7940  real, intent(INOUT) :: v(isd:ied+1,jsd:jed )
7941  real, intent(INOUT) :: uc(isd:ied+1,jsd:jed )
7942  real, intent(INOUT) :: vc(isd:ied ,jsd:jed+1)
7943  real, intent(INOUT) :: ua(isd:ied ,jsd:jed )
7944  real, intent(INOUT) :: va(isd:ied ,jsd:jed )
7945  integer, intent(IN) :: defOnGrid
7946  type(fv_grid_type), intent(IN), target :: gridstruct
7947 
7948  real :: p1(2),p2(2),p3(2),p4(2), pt(2)
7949  real :: e1(3), e2(3), ex(3), ey(3)
7950 
7951  real :: dist, r, r0
7952  integer :: i,j,k,n
7953  real :: utmp, vtmp
7954 
7955  real :: psi_b(isd:ied+1,jsd:jed+1), psi(isd:ied,jsd:jed), psi1, psi2
7956 
7957  real, dimension(:,:,:), pointer :: grid, agrid
7958  real, dimension(:,:), pointer :: area, dx, dy, dxc, dyc
7959 
7960  grid => gridstruct%grid
7961  agrid=> gridstruct%agrid
7962 
7963  area => gridstruct%area
7964  dx => gridstruct%dx
7965  dy => gridstruct%dy
7966  dxc => gridstruct%dxc
7967  dyc => gridstruct%dyc
7968 
7969  psi(:,:) = 1.e25
7970  psi_b(:,:) = 1.e25
7971  do j=jsd,jed
7972  do i=isd,ied
7973  psi(i,j) = (-1.0 * ubar * radius *( sin(agrid(i,j,2)) *cos(alpha) - &
7974  cos(agrid(i,j,1))*cos(agrid(i,j,2))*sin(alpha) ) )
7975  enddo
7976  enddo
7977  do j=jsd,jed+1
7978  do i=isd,ied+1
7979  psi_b(i,j) = (-1.0 * ubar * radius *( sin(grid(i,j,2)) *cos(alpha) - &
7980  cos(grid(i,j,1))*cos(grid(i,j,2))*sin(alpha) ) )
7981  enddo
7982  enddo
7983 
7984  if ( defongrid == 1 ) then
7985  do j=jsd,jed+1
7986  do i=isd,ied
7987  dist = dx(i,j)
7988  vc(i,j) = (psi_b(i+1,j)-psi_b(i,j))/dist
7989  if (dist==0) vc(i,j) = 0.
7990  enddo
7991  enddo
7992  do j=jsd,jed
7993  do i=isd,ied+1
7994  dist = dy(i,j)
7995  uc(i,j) = -1.0*(psi_b(i,j+1)-psi_b(i,j))/dist
7996  if (dist==0) uc(i,j) = 0.
7997  enddo
7998  enddo
7999 
8000 
8001  do j=js,je
8002  do i=is,ie+1
8003  dist = dxc(i,j)
8004  v(i,j) = (psi(i,j)-psi(i-1,j))/dist
8005  if (dist==0) v(i,j) = 0.
8006  enddo
8007  enddo
8008  do j=js,je+1
8009  do i=is,ie
8010  dist = dyc(i,j)
8011  u(i,j) = -1.0*(psi(i,j)-psi(i,j-1))/dist
8012  if (dist==0) u(i,j) = 0.
8013  enddo
8014  enddo
8015  endif
8016 
8017  end subroutine init_latlon_winds
8018 
8019  subroutine d2a2c(im,jm,km, ifirst,ilast, jfirst,jlast, ng, nested, &
8020  u,v, ua,va, uc,vc, gridstruct, domain)
8021 
8022 ! Input
8023  integer, intent(IN) :: im,jm,km
8024  integer, intent(IN) :: ifirst,ilast
8025  integer, intent(IN) :: jfirst,jlast
8026  integer, intent(IN) :: ng
8027  logical, intent(IN) :: nested
8028  type(fv_grid_type), intent(IN), target :: gridstruct
8029  type(domain2d), intent(INOUT) :: domain
8030 
8031  !real , intent(in) :: sinlon(im,jm)
8032  !real , intent(in) :: coslon(im,jm)
8033  !real , intent(in) :: sinl5(im,jm)
8034  !real , intent(in) :: cosl5(im,jm)
8035 
8036 ! Output
8037  ! real , intent(inout) :: u(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8038  ! real , intent(inout) :: v(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8039  ! real , intent(inout) :: ua(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8040  ! real , intent(inout) :: va(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8041  ! real , intent(inout) :: uc(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8042  ! real , intent(inout) :: vc(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8043 
8044  real , intent(inout) :: u(isd:ied,jsd:jed+1) !ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8045  real , intent(inout) :: v(isd:ied+1,jsd:jed) !ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8046  real , intent(inout) :: ua(isd:ied,jsd:jed) !ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8047  real , intent(inout) :: va(isd:ied,jsd:jed) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+ng)
8048  real , intent(inout) :: uc(isd:ied+1,jsd:jed) !(ifirst-ng:ilast+1+ng,jfirst-ng:jlast+ng)
8049  real , intent(inout) :: vc(isd:ied,jsd:jed+1) !(ifirst-ng:ilast+ng,jfirst-ng:jlast+1+ng)
8050 
8051 !--------------------------------------------------------------
8052 ! Local
8053 
8054  real :: sinlon(im,jm)
8055  real :: coslon(im,jm)
8056  real :: sinl5(im,jm)
8057  real :: cosl5(im,jm)
8058 
8059  real :: tmp1(jsd:jed+1)
8060  real :: tmp2(jsd:jed)
8061  real :: tmp3(jsd:jed)
8062 
8063  real mag,mag1,mag2, ang,ang1,ang2
8064  real us, vs, un, vn
8065  integer i, j, k, im2
8066  integer js1g1
8067  integer js2g1
8068  integer js2g2
8069  integer js2gc
8070  integer js2gc1
8071  integer js2gcp1
8072  integer js2gd
8073  integer jn2gc
8074  integer jn1g1
8075  integer jn1g2
8076  integer jn2gd
8077  integer jn2gsp1
8078 
8079  real, pointer, dimension(:,:,:) :: agrid, grid
8080  real, pointer, dimension(:,:) :: area, rarea, fC, f0
8081  real(kind=R_GRID), pointer, dimension(:,:,:) :: ee1, ee2, en1, en2
8082  real(kind=R_GRID), pointer, dimension(:,:,:,:) :: ew, es
8083  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8084 
8085  logical, pointer :: cubed_sphere, latlon
8086 
8087  logical, pointer :: have_south_pole, have_north_pole
8088 
8089  integer, pointer :: ntiles_g
8090  real, pointer :: acapN, acapS, globalarea
8091 
8092  grid => gridstruct%grid
8093  agrid=> gridstruct%agrid
8094 
8095  area => gridstruct%area
8096  rarea => gridstruct%rarea
8097 
8098  fc => gridstruct%fC
8099  f0 => gridstruct%f0
8100 
8101  ee1 => gridstruct%ee1
8102  ee2 => gridstruct%ee2
8103  ew => gridstruct%ew
8104  es => gridstruct%es
8105  en1 => gridstruct%en1
8106  en2 => gridstruct%en2
8107 
8108  dx => gridstruct%dx
8109  dy => gridstruct%dy
8110  dxa => gridstruct%dxa
8111  dya => gridstruct%dya
8112  rdxa => gridstruct%rdxa
8113  rdya => gridstruct%rdya
8114  dxc => gridstruct%dxc
8115  dyc => gridstruct%dyc
8116 
8117  cubed_sphere => gridstruct%cubed_sphere
8118  latlon => gridstruct%latlon
8119 
8120  have_south_pole => gridstruct%have_south_pole
8121  have_north_pole => gridstruct%have_north_pole
8122 
8123  ntiles_g => gridstruct%ntiles_g
8124  acapn => gridstruct%acapN
8125  acaps => gridstruct%acapS
8126  globalarea => gridstruct%globalarea
8127 
8128  if (cubed_sphere) then
8129 
8130  call dtoa( u, v,ua,va,dx,dy,dxa,dya,dxc,dyc,im,jm,ng)
8131  if (.not. nested) call fill_corners(ua, va, im, jm, vector=.true., agrid=.true.)
8132  call atoc(ua,va,uc,vc,dx,dy,dxa,dya,im,jm,ng, nested, domain, nocomm=.true.)
8133  if (.not. nested) call fill_corners(uc, vc, im, jm, vector=.true., cgrid=.true.)
8134 
8135  else ! Lat-Lon
8136 
8137  im2 = im/2
8138 
8139 ! Set loop limits
8140 
8141  js1g1 = jfirst-1
8142  js2g1 = jfirst-1
8143  js2g2 = jfirst-2
8144  js2gc = jfirst-ng
8145  js2gcp1 = jfirst-ng-1
8146  js2gd = jfirst-ng
8147  jn1g1 = jlast+1
8148  jn1g2 = jlast+2
8149  jn2gc = jlast+ng
8150  jn2gd = jlast+ng-1
8151  jn2gsp1 = jlast+ng-1
8152 
8153  if (have_south_pole) then
8154  js1g1 = 1
8155  js2g1 = 2
8156  js2g2 = 2
8157  js2gc = 2
8158  js2gcp1 = 2 ! NG-1 latitudes on S (starting at 2)
8159  js2gd = 2
8160  endif
8161  if (have_north_pole) then
8162  jn1g1 = jm
8163  jn1g2 = jm
8164  jn2gc = jm-1 ! NG latitudes on N (ending at jm-1)
8165  jn2gd = jm-1
8166  jn2gsp1 = jm-1
8167  endif
8168 !
8169 ! Treat the special case of ng = 1
8170 !
8171  if ( ng == 1 .AND. ng > 1 ) THEN
8172  js2gc1 = js2gc
8173  else
8174  js2gc1 = jfirst-ng+1
8175  if (have_south_pole) js2gc1 = 2 ! NG-1 latitudes on S (starting at 2)
8176  endif
8177 
8178  do k=1,km
8179 
8180  if ((have_south_pole) .or. (have_north_pole)) then
8181 ! Get D-grid V-wind at the poles.
8182  call vpol5(u(1:im,:), v(1:im,:), im, jm, &
8183  coslon, sinlon, cosl5, sinl5, ng, ng, jfirst, jlast )
8184  call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, v(:,:))
8185  endif
8186 
8187  call dtoa(u, v, ua, va, dx,dy,dxa,dya,dxc,dyc,im, jm, ng)
8188  if (.not. nested) call fill_corners(ua, va, im, jm, vector=.true., agrid=.true.)
8189 
8190  if ( have_south_pole ) then
8191 ! Projection at SP
8192  us = 0.
8193  vs = 0.
8194  do i=1,im2
8195  us = us + (ua(i+im2,2)-ua(i,2))*sinlon(i,2) &
8196  + (va(i,2)-va(i+im2,2))*coslon(i,2)
8197  vs = vs + (ua(i+im2,2)-ua(i,2))*coslon(i,2) &
8198  + (va(i+im2,2)-va(i,2))*sinlon(i,2)
8199  enddo
8200  us = us/im
8201  vs = vs/im
8202 ! SP
8203  do i=1,im2
8204  ua(i,1) = -us*sinlon(i,1) - vs*coslon(i,1)
8205  va(i,1) = us*coslon(i,1) - vs*sinlon(i,1)
8206  ua(i+im2,1) = -ua(i,1)
8207  va(i+im2,1) = -va(i,1)
8208  enddo
8209  ua(0 ,1) = ua(im,1)
8210  ua(im+1,1) = ua(1 ,1)
8211  va(im+1,1) = va(1 ,1)
8212  endif
8213 
8214  if ( have_north_pole ) then
8215 ! Projection at NP
8216  un = 0.
8217  vn = 0.
8218  j = jm-1
8219  do i=1,im2
8220  un = un + (ua(i+im2,j)-ua(i,j))*sinlon(i,j) &
8221  + (va(i+im2,j)-va(i,j))*coslon(i,j)
8222  vn = vn + (ua(i,j)-ua(i+im2,j))*coslon(i,j) &
8223  + (va(i+im2,j)-va(i,j))*sinlon(i,j)
8224  enddo
8225  un = un/im
8226  vn = vn/im
8227 ! NP
8228  do i=1,im2
8229  ua(i,jm) = -un*sinlon(i,jm) + vn*coslon(i,jm)
8230  va(i,jm) = -un*coslon(i,jm) - vn*sinlon(i,jm)
8231  ua(i+im2,jm) = -ua(i,jm)
8232  va(i+im2,jm) = -va(i,jm)
8233  enddo
8234  ua(0 ,jm) = ua(im,jm)
8235  ua(im+1,jm) = ua(1 ,jm)
8236  va(im+1,jm) = va(1 ,jm)
8237  endif
8238 
8239  if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, ua(:,:))
8240  if (latlon) call mp_ghost_ew(im,jm,1,1, ifirst,ilast, jfirst,jlast, 1,1, ng,ng, ng,ng, va(:,:))
8241 
8242 ! A -> C
8243  call atoc(ua, va, uc, vc, dx,dy,dxa,dya,im, jm, ng, nested, domain, nocomm=.true.)
8244 
8245  enddo ! km loop
8246 
8247  if (.not. nested) call fill_corners(uc, vc, im, jm, vector=.true., cgrid=.true.)
8248  endif
8249 
8250 
8251  end subroutine d2a2c
8252 
8253 
8254  subroutine atob_s(qin, qout, npx, npy, dxa, dya, nested, cubed_sphere, altInterp)
8255 
8256 ! atob_s :: interpolate scalar from the A-Grid to the B-grid
8257 !
8258  integer, intent(IN) :: npx, npy
8259  real , intent(IN) :: qin(isd:ied ,jsd:jed ) ! A-grid field
8260  real , intent(OUT) :: qout(isd:ied+1,jsd:jed+1) ! Output B-grid field
8261  integer, OPTIONAL, intent(IN) :: altInterp
8262  logical, intent(IN) :: nested, cubed_sphere
8263  real, intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8264 
8265  integer :: i,j,n
8266 
8267  real :: tmp1j(jsd:jed+1)
8268  real :: tmp2j(jsd:jed+1)
8269  real :: tmp3j(jsd:jed+1)
8270  real :: tmp1i(isd:ied+1)
8271  real :: tmp2i(isd:ied+1)
8272  real :: tmp3i(isd:ied+1)
8273  real :: tmpq(isd:ied ,jsd:jed )
8274  real :: tmpq1(isd:ied+1,jsd:jed+1)
8275  real :: tmpq2(isd:ied+1,jsd:jed+1)
8276 
8277  if (present(altinterp)) then
8278 
8279  tmpq(:,:) = qin(:,:)
8280 
8281  if (.not. nested) call fill_corners(tmpq , npx, npy, fill=xdir, agrid=.true.)
8282 ! ATOC
8283  do j=jsd,jed
8284  call interp_left_edge_1d(tmpq1(:,j), tmpq(:,j), dxa(:,j), isd, ied, altinterp)
8285  enddo
8286 
8287  if (.not. nested) call fill_corners(tmpq , npx, npy, fill=ydir, agrid=.true.)
8288 ! ATOD
8289  do i=isd,ied
8290  tmp1j(jsd:jed) = 0.0
8291  tmp2j(jsd:jed) = tmpq(i,jsd:jed)
8292  tmp3j(jsd:jed) = dya(i,jsd:jed)
8293  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, altinterp)
8294  tmpq2(i,jsd:jed) = tmp1j(jsd:jed)
8295  enddo
8296 
8297 ! CTOB
8298  do i=isd,ied
8299  tmp1j(:) = tmpq1(i,:)
8300  tmp2j(:) = tmpq1(i,:)
8301  tmp3j(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8302  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, altinterp)
8303  tmpq1(i,:) = tmp1j(:)
8304  enddo
8305 
8306 ! DTOB
8307  do j=jsd,jed
8308  tmp1i(:) = tmpq2(:,j)
8309  tmp2i(:) = tmpq2(:,j)
8310  tmp3i(:) = 1.0 ! Uniform Weighting missing first value so will not reproduce
8311  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, altinterp)
8312  tmpq2(:,j) = tmp1i(:)
8313  enddo
8314 
8315 ! Average
8316  do j=jsd,jed+1
8317  do i=isd,ied+1
8318  qout(i,j) = 0.5 * (tmpq1(i,j) + tmpq2(i,j))
8319  enddo
8320  enddo
8321 
8322 ! Fix Corners
8323  if (cubed_sphere .and. .not. nested) then
8324  i=1
8325  j=1
8326  if ( (is==i) .and. (js==j) ) then
8327  qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8328  endif
8329 
8330  i=npx
8331  j=1
8332  if ( (ie+1==i) .and. (js==j) ) then
8333  qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8334  endif
8335 
8336  i=1
8337  j=npy
8338  if ( (is==i) .and. (je+1==j) ) then
8339  qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8340  endif
8341 
8342  i=npx
8343  j=npy
8344  if ( (ie+1==i) .and. (je+1==j) ) then
8345  qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8346  endif
8347  endif
8348 
8349  else ! altInterp
8350 
8351  do j=js,je+1
8352  do i=is,ie+1
8353  qout(i,j) = 0.25 * (qin(i-1,j) + qin(i-1,j-1) + &
8354  qin(i ,j) + qin(i ,j-1))
8355  enddo
8356  enddo
8357 
8358  if (.not. nested) then
8359  i=1
8360  j=1
8361  if ( (is==i) .and. (js==j) ) then
8362  qout(i,j) = (1./3.) * (qin(i,j) + qin(i-1,j) + qin(i,j-1))
8363  endif
8364 
8365  i=npx
8366  j=1
8367  if ( (ie+1==i) .and. (js==j) ) then
8368  qout(i,j) = (1./3.) * (qin(i-1,j) + qin(i-1,j-1) + qin(i,j))
8369  endif
8370 
8371  i=1
8372  j=npy
8373  if ( (is==i) .and. (je+1==j) ) then
8374  qout(i,j) = (1./3.) * (qin(i,j-1) + qin(i-1,j-1) + qin(i,j))
8375  endif
8376 
8377  i=npx
8378  j=npy
8379  if ( (ie+1==i) .and. (je+1==j) ) then
8380  qout(i,j) = (1./3.) * (qin(i-1,j-1) + qin(i,j-1) + qin(i-1,j))
8381  endif
8382  endif !not nested
8383 
8384  endif ! altInterp
8385 
8386  end subroutine atob_s
8387 !
8388 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8389 !-------------------------------------------------------------------------------
8390 
8391 !-------------------------------------------------------------------------------
8392 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8393 !
8394 ! atod :: interpolate from the A-Grid to the D-grid
8395 !
8396  subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, domain)
8397 
8398 
8399  integer, intent(IN) :: npx, npy, ng
8400  real , intent(IN) :: uin(isd:ied ,jsd:jed ) ! A-grid u-wind field
8401  real , intent(IN) :: vin(isd:ied ,jsd:jed ) ! A-grid v-wind field
8402  real , intent(OUT) :: uout(isd:ied ,jsd:jed+1) ! D-grid u-wind field
8403  real , intent(OUT) :: vout(isd:ied+1,jsd:jed ) ! D-grid v-wind field
8404  logical, intent(IN) :: nested
8405  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8406  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc
8407  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc
8408  type(domain2d), intent(INOUT) :: domain
8409 
8410 
8411  integer :: i,j
8412  real :: tmp1i(isd:ied+1)
8413  real :: tmp2i(isd:ied)
8414  real :: tmp3i(isd:ied)
8415  real :: tmp1j(jsd:jed+1)
8416  real :: tmp2j(jsd:jed)
8417  real :: tmp3j(jsd:jed)
8418 
8419  do j=jsd+1,jed
8420  tmp1i(:) = 0.0
8421  tmp2i(:) = vin(:,j)*dxa(:,j)
8422  tmp3i(:) = dxa(:,j)
8423  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interporder)
8424  vout(:,j) = tmp1i(:)/dxc(:,j)
8425  enddo
8426  do i=isd+1,ied
8427  tmp1j(:) = 0.0
8428  tmp2j(:) = uin(i,:)*dya(i,:)
8429  tmp3j(:) = dya(i,:)
8430  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8431  uout(i,:) = tmp1j(:)/dyc(i,:)
8432  enddo
8433  call mp_update_dwinds(uout, vout, npx, npy, domain)
8434  if (.not. nested) call fill_corners(uout, vout, npx, npy, vector=.true., dgrid=.true.)
8435  end subroutine atod
8436 !
8437 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8438 !-------------------------------------------------------------------------------
8439 
8440 !-------------------------------------------------------------------------------
8441 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8442 !
8443 ! dtoa :: interpolate from the D-Grid to the A-grid
8444 !
8445  subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng)
8446 
8447  integer, intent(IN) :: npx, npy, ng
8448  real , intent(IN) :: uin(isd:ied ,jsd:jed+1) ! D-grid u-wind field
8449  real , intent(IN) :: vin(isd:ied+1,jsd:jed ) ! D-grid v-wind field
8450  real , intent(OUT) :: uout(isd:ied ,jsd:jed ) ! A-grid u-wind field
8451  real , intent(OUT) :: vout(isd:ied ,jsd:jed ) ! A-grid v-wind field
8452  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx, dyc
8453  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy, dxc
8454  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8455 
8456  integer :: i,j,n
8457 
8458  real :: tmp1i(isd:ied+1)
8459  real :: tmp2i(isd:ied+1)
8460  real :: tmp3i(isd:ied+1)
8461  real :: tmp1j(jsd:jed+1)
8462  real :: tmp2j(jsd:jed+1)
8463  real :: tmp3j(jsd:jed+1)
8464 
8465 !CLEANUP: replace dxa with rdxa, and dya with rdya; may change numbers.
8466 #ifdef VORT_ON
8467 ! circulation (therefore, vort) conserving:
8468  do j=jsd,jed
8469  do i=isd,ied
8470  uout(i,j) = 0.5*(uin(i,j)*dx(i,j)+uin(i,j+1)*dx(i,j+1))/dxa(i,j)
8471  vout(i,j) = 0.5*(vin(i,j)*dy(i,j)+vin(i+1,j)*dy(i+1,j))/dya(i,j)
8472  enddo
8473  enddo
8474 #else
8475  do i=isd,ied
8476  tmp1j(:) = 0.0
8477  tmp2j(:) = uin(i,:)*dyc(i,:)
8478  tmp3j(:) = dyc(i,:)
8479  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interporder)
8480  uout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dya(i,jsd:jed)
8481  enddo
8482  do j=jsd,jed
8483  tmp1i(:) = 0.0
8484  tmp2i(:) = vin(:,j)*dxc(:,j)
8485  tmp3i(:) = dxc(:,j)
8486  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interporder)
8487  vout(isd:ied,j) = tmp1i(isd+1:ied+1)/dxa(isd:ied,j)
8488  enddo
8489 #endif
8490 
8491  end subroutine dtoa
8492 !
8493 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8494 !-------------------------------------------------------------------------------
8495 
8496 !-------------------------------------------------------------------------------
8497 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8498 !
8499 ! atoc :: interpolate from the A-Grid to the C-grid
8500 !
8501  subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, domain, noComm)
8502 
8503 
8504  integer, intent(IN) :: npx, npy, ng
8505  real , intent(IN) :: uin(isd:ied ,jsd:jed ) ! A-grid u-wind field
8506  real , intent(IN) :: vin(isd:ied ,jsd:jed ) ! A-grid v-wind field
8507  real , intent(OUT) :: uout(isd:ied+1,jsd:jed ) ! C-grid u-wind field
8508  real , intent(OUT) :: vout(isd:ied ,jsd:jed+1) ! C-grid v-wind field
8509  logical, intent(IN) :: nested
8510  logical, OPTIONAL, intent(IN) :: noComm
8511  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dx
8512  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dy
8513  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8514  type(domain2d), intent(INOUT) :: domain
8515 
8516  real :: ang1
8517  integer :: i,j,n
8518 
8519  real :: tmp1i(isd:ied+1)
8520  real :: tmp2i(isd:ied)
8521  real :: tmp3i(isd:ied)
8522  real :: tmp1j(jsd:jed+1)
8523  real :: tmp2j(jsd:jed)
8524  real :: tmp3j(jsd:jed)
8525 
8526 #if !defined(ALT_INTERP)
8527 #ifdef VORT_ON
8528 ! Circulation conserving
8529  do j=jsd,jed
8530  do i=isd+1,ied
8531  uout(i,j) = ( uin(i,j)*dxa(i,j) + uin(i-1,j)*dxa(i-1,j) ) &
8532  / ( dxa(i,j) + dxa(i-1,j) )
8533  enddo
8534  enddo
8535  do j=jsd+1,jed
8536  do i=isd,ied
8537  vout(i,j) = ( vin(i,j)*dya(i,j) + vin(i,j-1)*dya(i,j-1) ) &
8538  / ( dya(i,j) + dya(i,j-1) )
8539  enddo
8540  enddo
8541 #else
8542  do j=jsd,jed
8543  call interp_left_edge_1d(uout(:,j), uin(:,j), dxa(:,j), isd, ied, interporder)
8544  enddo
8545  do i=isd,ied
8546 !!$ tmp1j(:) = vout(i,:)
8547  tmp2j(:) = vin(i,:)
8548  tmp3j(:) = dya(i,:)
8549  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8550  vout(i,:) = tmp1j(:)
8551  enddo
8552 #endif
8553 #else
8554 
8555  do j=jsd,jed
8556 !!$ tmp1i(:) = uout(:,j)
8557  tmp2i(:) = uin(:,j)*dya(:,j)
8558  tmp3i(:) = dxa(:,j)
8559  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied, interporder)
8560  uout(:,j) = tmp1i(:)/dy(:,j)
8561  enddo
8562  do i=isd,ied
8563 !!$ tmp1j(:) = vout(i,:)
8564  tmp2j(:) = vin(i,:)*dxa(i,:)
8565  tmp3j(:) = dya(i,:)
8566  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed, interporder)
8567  vout(i,:) = tmp1j(:)/dx(i,:)
8568  enddo
8569 
8570  if (cubed_sphere .and. .not. nested) then
8571  csfac = cos(30.0*pi/180.0)
8572  ! apply Corner scale factor for interp on Cubed-Sphere
8573  if ( (is==1) .and. (js==1) ) then
8574  i=1
8575  j=1
8576  uout(i,j)=uout(i,j)*csfac
8577  uout(i,j-1)=uout(i,j-1)*csfac
8578  vout(i,j)=vout(i,j)*csfac
8579  vout(i-1,j)=vout(i-1,j)*csfac
8580  endif
8581  if ( (is==1) .and. (je==npy-1) ) then
8582  i=1
8583  j=npy-1
8584  uout(i,j)=uout(i,j)*csfac
8585  uout(i,j+1)=uout(i,j+1)*csfac
8586  vout(i,j+1)=vout(i,j+1)*csfac
8587  vout(i-1,j+1)=vout(i-1,j+1)*csfac
8588  endif
8589  if ( (ie==npx-1) .and. (je==npy-1) ) then
8590  i=npx-1
8591  j=npy-1
8592  uout(i+1,j)=uout(i+1,j)*csfac
8593  uout(i+1,j+1)=uout(i+1,j+1)*csfac
8594  vout(i,j+1)=vout(i,j+1)*csfac
8595  vout(i+1,j+1)=vout(i+1,j+1)*csfac
8596  endif
8597  if ( (ie==npx-1) .and. (js==1) ) then
8598  i=npx-1
8599  j=1
8600  uout(i+1,j)=uout(i+1,j)*csfac
8601  uout(i+1,j-1)=uout(i+1,j-1)*csfac
8602  vout(i,j)=vout(i,j)*csfac
8603  vout(i+1,j)=vout(i+1,j)*csfac
8604  endif
8605  endif
8606 
8607 #endif
8608 
8609  if (present(nocomm)) then
8610  if (.not. nocomm) call mpp_update_domains( uout,vout, domain, gridtype=cgrid_ne_param, complete=.true.)
8611  else
8612  call mpp_update_domains( uout,vout, domain, gridtype=cgrid_ne_param, complete=.true.)
8613  endif
8614  if (.not. nested) call fill_corners(uout, vout, npx, npy, vector=.true., cgrid=.true.)
8615 
8616  end subroutine atoc
8617 !
8618 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8619 !-------------------------------------------------------------------------------
8620 
8621 !-------------------------------------------------------------------------------
8622 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8623 !
8624 ! ctoa :: interpolate from the C-Grid to the A-grid
8625 !
8626  subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng)
8627 
8628 
8629  integer, intent(IN) :: npx, npy, ng
8630  real , intent(IN) :: uin(isd:ied+1,jsd:jed ) ! C-grid u-wind field
8631  real , intent(IN) :: vin(isd:ied ,jsd:jed+1) ! C-grid v-wind field
8632  real , intent(OUT) :: uout(isd:ied ,jsd:jed ) ! A-grid u-wind field
8633  real , intent(OUT) :: vout(isd:ied ,jsd:jed ) ! A-grid v-wind field
8634  real , intent(IN), dimension(isd:ied+1,jsd:jed) :: dxc, dy
8635  real , intent(IN), dimension(isd:ied,jsd:jed+1) :: dyc, dx
8636  real , intent(IN), dimension(isd:ied,jsd:jed) :: dxa, dya
8637 
8638  integer :: i,j
8639 
8640  real :: tmp1i(isd:ied+1)
8641  real :: tmp2i(isd:ied+1)
8642  real :: tmp3i(isd:ied+1)
8643  real :: tmp1j(jsd:jed+1)
8644  real :: tmp2j(jsd:jed+1)
8645  real :: tmp3j(jsd:jed+1)
8646 
8647  ! do j=jsd,jed
8648  ! do i=isd,ied
8649  ! uout(i,j) = 0.5 * (uin(i,j)*dy(i,j) + uin(i+1,j)*dy(i+1,j))/dya(i,j)
8650  ! enddo
8651  ! enddo
8652  ! do j=jsd,jed
8653  ! do i=isd,ied
8654  ! vout(i,j) = 0.5 * (vin(i,j)*dx(i,j) + vin(i,j+1)*dx(i,j+1))/dxa(i,j)
8655  ! enddo
8656  ! enddo
8657  do i=isd,ied
8658  tmp1j(:) = 0.0
8659  tmp2j(:) = vin(i,:)*dx(i,:)
8660  tmp3j(:) = dyc(i,:)
8661  call interp_left_edge_1d(tmp1j, tmp2j, tmp3j, jsd, jed+1, interporder)
8662  vout(i,jsd:jed) = tmp1j(jsd+1:jed+1)/dxa(i,jsd:jed)
8663  enddo
8664  do j=jsd,jed
8665  tmp1i(:) = 0.0
8666  tmp2i(:) = uin(:,j)*dy(:,j)
8667  tmp3i(:) = dxc(:,j)
8668  call interp_left_edge_1d(tmp1i, tmp2i, tmp3i, isd, ied+1, interporder)
8669  uout(isd:ied,j) = tmp1i(isd+1:ied+1)/dya(isd:ied,j)
8670  enddo
8671 
8672  end subroutine ctoa
8673 !
8674 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8675 !-------------------------------------------------------------------------------
8676 
8677 !-------------------------------------------------------------------------------
8678 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8679 !
8680 ! rotate_winds :: rotate winds from the sphere-to-cube || cube-to-sphere
8681 !
8682  subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
8683 
8684 
8685  integer, intent(IN) :: ndims
8686  real , intent(INOUT) :: myU ! u-wind field
8687  real , intent(INOUT) :: myV ! v-wind field
8688  real(kind=R_GRID) , intent(IN) :: p1(ndims) ! p4
8689  real(kind=R_GRID) , intent(IN) :: p2(ndims) !
8690  real(kind=R_GRID) , intent(IN) :: p3(ndims) ! p1 t1 p3
8691  real(kind=R_GRID) , intent(IN) :: p4(ndims) !
8692  real(kind=R_GRID) , intent(IN) :: t1(ndims) ! p2
8693  integer, intent(IN) :: dir ! Direction ; 1=>sphere-to-cube 2=> cube-to-sphere
8694 
8695  real(kind=R_GRID) :: ee1(3), ee2(3), ee3(3), elon(3), elat(3)
8696 
8697  real :: g11, g12, g21, g22
8698 
8699  real :: newu, newv
8700 
8701  call get_unit_vector(p3, t1, p1, ee1)
8702  call get_unit_vector(p4, t1, p2, ee2)
8703  elon(1) = -sin(t1(1) - pi)
8704  elon(2) = cos(t1(1) - pi)
8705  elon(3) = 0.0
8706  elat(1) = -sin(t1(2))*cos(t1(1) - pi)
8707  elat(2) = -sin(t1(2))*sin(t1(1) - pi)
8708  elat(3) = cos(t1(2))
8709 
8710  g11 = inner_prod(ee1,elon)
8711  g12 = inner_prod(ee1,elat)
8712  g21 = inner_prod(ee2,elon)
8713  g22 = inner_prod(ee2,elat)
8714 
8715  if (dir == 1) then ! Sphere to Cube Rotation
8716  newu = myu*g11 + myv*g12
8717  newv = myu*g21 + myv*g22
8718  else
8719  newu = ( myu*g22 - myv*g12)/(g11*g22 - g21*g12)
8720  newv = (-myu*g21 + myv*g11)/(g11*g22 - g21*g12)
8721  endif
8722  myu = newu
8723  myv = newv
8724 
8725  end subroutine rotate_winds
8726 
8727  subroutine mp_update_dwinds_2d(u, v, npx, npy, domain)
8728  use mpp_parameter_mod, only: dgrid_ne
8729  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1) ! D-grid u-wind field
8730  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ) ! D-grid v-wind field
8731  integer, intent(IN) :: npx, npy
8732  type(domain2d), intent(INOUT) :: domain
8733 
8734  call mpp_update_domains( u, v, domain, gridtype=dgrid_ne, complete=.true.)
8735 ! if (.not. nested) call fill_corners(u , v , npx, npy, VECTOR=.true., DGRID=.true.)
8736 
8737  end subroutine mp_update_dwinds_2d
8738 !
8739 ! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ !
8740 !-------------------------------------------------------------------------------
8741 
8742 !-------------------------------------------------------------------------------
8743 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8744 !
8745  subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain)
8746  use mpp_parameter_mod, only: dgrid_ne
8747  real , intent(INOUT) :: u(isd:ied ,jsd:jed+1,npz) ! D-grid u-wind field
8748  real , intent(INOUT) :: v(isd:ied+1,jsd:jed ,npz) ! D-grid v-wind field
8749  integer, intent(IN) :: npx, npy, npz
8750  type(domain2d), intent(INOUT) :: domain
8751  integer k
8752 
8753  call mpp_update_domains( u, v, domain, gridtype=dgrid_ne, complete=.true.)
8754 ! do k=1,npz
8755 ! if (.not. nested) call fill_corners(u(isd:,jsd:,k) , v(isd:,jsd:,k) , npx, npy, VECTOR=.true., DGRID=.true.)
8756 ! enddo
8757 
8758  end subroutine mp_update_dwinds_3d
8759 
8760 !-------------------------------------------------------------------------------
8761 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8762 !
8763 ! gsum :: get global sum
8764 !
8765  real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile) result (gsum)
8766 
8767  integer, intent(IN) :: npx, npy
8768  integer, intent(IN) :: ifirst, ilast
8769  integer, intent(IN) :: jfirst, jlast
8770  integer, intent(IN) :: isd, ied
8771  integer, intent(IN) :: jsd, jed, tile
8772  real , intent(IN) :: p(ifirst:ilast,jfirst:jlast) ! field to be summed
8773  type(fv_grid_type), intent(IN), target :: gridstruct
8774 
8775  integer :: i,j,k,n
8776  integer :: j1, j2
8777  real :: gsum0
8778  real, allocatable :: p_r8(:,:,:)
8779 
8780  real, pointer, dimension(:,:,:) :: agrid, grid
8781  real, pointer, dimension(:,:) :: area, rarea, fc, f0
8782  real, pointer, dimension(:,:) :: dx,dy, dxa,dya, rdxa, rdya, dxc,dyc
8783 
8784  logical, pointer :: cubed_sphere, latlon
8785 
8786  logical, pointer :: have_south_pole, have_north_pole
8787 
8788  integer, pointer :: ntiles_g
8789  real, pointer :: acapn, acaps, globalarea
8790 
8791  grid => gridstruct%grid
8792  agrid=> gridstruct%agrid
8793 
8794  area => gridstruct%area
8795  rarea => gridstruct%rarea
8796 
8797  fc => gridstruct%fC
8798  f0 => gridstruct%f0
8799 
8800  dx => gridstruct%dx
8801  dy => gridstruct%dy
8802  dxa => gridstruct%dxa
8803  dya => gridstruct%dya
8804  rdxa => gridstruct%rdxa
8805  rdya => gridstruct%rdya
8806  dxc => gridstruct%dxc
8807  dyc => gridstruct%dyc
8808 
8809  cubed_sphere => gridstruct%cubed_sphere
8810  latlon => gridstruct%latlon
8811 
8812  have_south_pole => gridstruct%have_south_pole
8813  have_north_pole => gridstruct%have_north_pole
8814 
8815  ntiles_g => gridstruct%ntiles_g
8816  acapn => gridstruct%acapN
8817  acaps => gridstruct%acapS
8818  globalarea => gridstruct%globalarea
8819 
8820  allocate(p_r8(npx-1,npy-1,ntiles_g))
8821  gsum = 0.
8822 
8823  if (latlon) then
8824  j1 = 2
8825  j2 = npy-2
8826  !!! WARNING: acapS and acapN have NOT been initialized.
8827  gsum = gsum + p(1,1)*acaps
8828  gsum = gsum + p(1,npy-1)*acapn
8829  do j=j1,j2
8830  do i=1,npx-1
8831  gsum = gsum + p(i,j)*cos(agrid(i,j,2))
8832  enddo
8833  enddo
8834  else
8835 
8836  do n=tile,tile
8837  do j=jfirst,jlast
8838  do i=ifirst,ilast
8839  p_r8(i,j,n) = p(i,j)*area(i,j)
8840  enddo
8841  enddo
8842  enddo
8843  call mp_gather(p_r8, ifirst,ilast, jfirst,jlast, npx-1, npy-1, ntiles_g)
8844  if (is_master()) then
8845  do n=1,ntiles_g
8846  do j=1,npy-1
8847  do i=1,npx-1
8848  gsum = gsum + p_r8(i,j,n)
8849  enddo
8850  enddo
8851  enddo
8852  gsum = gsum/globalarea
8853  endif
8854  call mpp_broadcast(gsum, mpp_root_pe())
8855 
8856  endif
8857 
8858  deallocate(p_r8)
8859 
8860  end function globalsum
8861 
8862 
8863  subroutine get_unit_vector( p1, p2, p3, uvect )
8864  real(kind=R_GRID), intent(in):: p1(2), p2(2), p3(2) ! input position unit vectors (spherical coordinates)
8865  real(kind=R_GRID), intent(out):: uvect(3) ! output unit spherical cartesian
8866 ! local
8867  integer :: n
8868  real(kind=R_GRID) :: xyz1(3), xyz2(3), xyz3(3)
8869  real :: dp(3)
8870 
8871  call spherical_to_cartesian(p1(1), p1(2), one, xyz1(1), xyz1(2), xyz1(3))
8872  call spherical_to_cartesian(p2(1), p2(2), one, xyz2(1), xyz2(2), xyz2(3))
8873  call spherical_to_cartesian(p3(1), p3(2), one, xyz3(1), xyz3(2), xyz3(3))
8874  do n=1,3
8875  uvect(n) = xyz3(n)-xyz1(n)
8876  enddo
8877  call project_sphere_v(1, uvect,xyz2)
8878  call normalize_vect(1, uvect)
8879 
8880  end subroutine get_unit_vector
8881 
8882 
8883  subroutine normalize_vect(np, e)
8884 !
8885 ! Make e an unit vector
8886 !
8887  implicit none
8888  integer, intent(in):: np
8889  real(kind=R_GRID), intent(inout):: e(3,np)
8890 ! local:
8891  integer k, n
8892  real pdot
8893 
8894  do n=1,np
8895  pdot = sqrt(e(1,n)**2+e(2,n)**2+e(3,n)**2)
8896  do k=1,3
8897  e(k,n) = e(k,n) / pdot
8898  enddo
8899  enddo
8900 
8901  end subroutine normalize_vect
8902 !------------------------------------------------------------------------------
8903 !BOP
8904 ! !ROUTINE: mp_ghost_ew --- Ghost 4d east/west "lat/lon periodic
8905 !
8906 ! !INTERFACE:
8907  subroutine mp_ghost_ew(im, jm, km, nq, ifirst, ilast, jfirst, jlast, &
8908  kfirst, klast, ng_w, ng_e, ng_s, ng_n, q_ghst, q)
8909 !
8910 ! !INPUT PARAMETERS:
8911  integer, intent(in):: im, jm, km, nq
8912  integer, intent(in):: ifirst, ilast
8913  integer, intent(in):: jfirst, jlast
8914  integer, intent(in):: kfirst, klast
8915  integer, intent(in):: ng_e ! eastern zones to ghost
8916  integer, intent(in):: ng_w ! western zones to ghost
8917  integer, intent(in):: ng_s ! southern zones to ghost
8918  integer, intent(in):: ng_n ! northern zones to ghost
8919  real, intent(inout):: q_ghst(ifirst-ng_w:ilast+ng_e,jfirst-ng_s:jlast+ng_n,kfirst:klast,nq)
8920  real, optional, intent(in):: q(ifirst:ilast,jfirst:jlast,kfirst:klast,nq)
8921 !
8922 ! !DESCRIPTION:
8923 !
8924 ! Ghost 4d east/west
8925 !
8926 ! !REVISION HISTORY:
8927 ! 2005.08.22 Putman
8928 !
8929 !EOP
8930 !------------------------------------------------------------------------------
8931 !BOC
8932  integer :: i,j,k,n
8933 
8934  if (present(q)) then
8935  q_ghst(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq) = &
8936  q(ifirst:ilast,jfirst:jlast,kfirst:klast,1:nq)
8937  endif
8938 
8939 ! Assume Periodicity in X-dir and not overlapping
8940  do n=1,nq
8941  do k=kfirst,klast
8942  do j=jfirst-ng_s,jlast+ng_n
8943  do i=1, ng_w
8944  q_ghst(ifirst-i,j,k,n) = q_ghst(ilast-i+1,j,k,n)
8945  enddo
8946  do i=1, ng_e
8947  q_ghst(ilast+i,j,k,n) = q_ghst(ifirst+i-1,j,k,n)
8948  enddo
8949  enddo
8950  enddo
8951  enddo
8952 
8953 !EOC
8954  end subroutine mp_ghost_ew
8955 
8956 
8957 
8958 
8959 
8960 
8961 !-------------------------------------------------------------------------------
8962 ! vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv !
8963 !
8964 ! interp_left_edge_1d :: interpolate to left edge of a cell either
8965 ! order = 1 -> Linear average
8966 ! order = 2 -> Uniform PPM
8967 ! order = 3 -> Non-Uniform PPM
8968 !
8969  subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
8970  integer, intent(in):: ifirst,ilast
8971  real, intent(out) :: qout(ifirst:)
8972  real, intent(in) :: qin(ifirst:)
8973  real, intent(in) :: dx(ifirst:)
8974  integer, intent(in):: order
8975  integer :: i
8976 
8977  real :: dm(ifirst:ilast),qmax,qmin
8978  real :: r3, da1, da2, a6da, a6, al, ar
8979  real :: qLa, qLb1, qLb2
8980  real :: x
8981 
8982  r3 = 1./3.
8983 
8984  qout(:) = 0.0
8985  if (order==1) then
8986 ! 1st order Uniform linear averaging
8987  do i=ifirst+1,ilast
8988  qout(i) = 0.5 * (qin(i-1) + qin(i))
8989  enddo
8990  elseif (order==2) then
8991 ! Non-Uniform 1st order average
8992  do i=ifirst+1,ilast
8993  qout(i) = (dx(i-1)*qin(i-1) + dx(i)*qin(i))/(dx(i-1)+dx(i))
8994  enddo
8995  elseif (order==3) then
8996 
8997 ! PPM - Uniform
8998  do i=ifirst+1,ilast-1
8999  dm(i) = 0.25*(qin(i+1) - qin(i-1))
9000  enddo
9001 !
9002 ! Applies monotonic slope constraint
9003 !
9004  do i=ifirst+1,ilast-1
9005  qmax = max(qin(i-1),qin(i),qin(i+1)) - qin(i)
9006  qmin = qin(i) - min(qin(i-1),qin(i),qin(i+1))
9007  dm(i) = sign(min(abs(dm(i)),qmin,qmax),dm(i))
9008  enddo
9009 
9010  do i=ifirst+1,ilast-1
9011  qout(i) = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9012  ! al = 0.5*(qin(i-1)+qin(i)) + r3*(dm(i-1) - dm(i))
9013  ! da1 = dm(i) + dm(i)
9014  ! qout(i) = qin(i) - sign(min(abs(da1),abs(al-qin(i))), da1)
9015  enddo
9016 
9017 ! First order average to fill in end points
9018  qout(ifirst+1) = 0.5 * (qin(ifirst) + qin(ifirst+1))
9019  qout(ilast) = 0.5 * (qin(ilast-1) + qin(ilast))
9020 
9021  elseif (order==4) then
9022 
9023  ! Non-Uniform PPM
9024  do i=ifirst+1,ilast-1
9025  dm(i) = ( (2.*dx(i-1) + dx(i) ) / &
9026  ( dx(i+1) + dx(i) ) ) * ( qin(i+1) - qin(i) ) + &
9027  ( (dx(i) + 2.*dx(i+1)) / &
9028  (dx(i-1) + dx(i) ) ) * ( qin(i) - qin(i-1) )
9029  dm(i) = ( dx(i) / ( dx(i-1) + dx(i) + dx(i+1) ) ) * dm(i)
9030  if ( (qin(i+1)-qin(i))*(qin(i)-qin(i-1)) > 0.) then
9031  dm(i) = sign( min( abs(dm(i)), 2.*abs(qin(i)-qin(i-1)), 2.*abs(qin(i+1)-qin(i)) ) , dm(i) )
9032  else
9033  dm(i) = 0.
9034  endif
9035  enddo
9036 
9037  do i=ifirst+2,ilast-1
9038  qla = ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) - &
9039  ( (dx(i+1) + dx(i)) / (2.*dx(i) + dx(i-1)) )
9040  qla = ( (2.*dx(i) * dx(i-1)) / (dx(i-1) + dx(i)) ) * qla * &
9041  (qin(i) - qin(i-1))
9042  qlb1 = dx(i-1) * ( (dx(i-2) + dx(i-1)) / (2.*dx(i-1) + dx(i)) ) * &
9043  dm(i)
9044  qlb2 = dx(i) * ( (dx(i) + dx(i+1)) / (dx(i-1) + 2.*dx(i)) ) * &
9045  dm(i-1)
9046 
9047  qout(i) = 1. / ( dx(i-2) + dx(i-1) + dx(i) + dx(i+1) )
9048  qout(i) = qout(i) * ( qla - qlb1 + qlb2 )
9049  qout(i) = qin(i-1) + ( dx(i-1) / ( dx(i-1) + dx(i) ) ) * (qin(i) - qin(i-1)) + qout(i)
9050  enddo
9051 
9052  elseif (order==5) then
9053 
9054  ! Linear Spline
9055  do i=ifirst+1,ilast-1
9056  x = float(i-(ifirst+1))*float(ilast-ifirst+1-1)/float(ilast-ifirst-1)
9057  qout(i) = qin(ifirst+nint(x)) + (x - nint(x)) * (qin(ifirst+nint(x+1)) - qin(ifirst+nint(x)))
9058  ! if (tile==1) print*, ifirst+NINT(x+1), ifirst+NINT(x), (x - NINT(x))
9059  ! if (tile==1) print*, 0.5*(qin(i-1)+qin(i)), qout(i)
9060  enddo
9061 
9062 !!$ if (tile==1) print*,'x=fltarr(28)'
9063 !!$ do i=ifirst,ilast
9064 !!$ if (tile==1) print*, 'x(',i-ifirst,')=',qin(i)
9065 !!$ enddo
9066 
9067 
9068  call mp_stop
9069  stop
9070 
9071  endif
9072 
9073  end subroutine interp_left_edge_1d
9074 !------------------------------------------------------------------------------
9075 !-----------------------------------------------------------------------
9076 !BOP
9077 !
9078  subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, &
9079  ng_d, ng_s, jfirst, jlast)
9080 
9081 ! !INPUT PARAMETERS:
9082  integer im ! Total longitudes
9083  integer jm ! Total latitudes
9084  integer jfirst ! First PE latitude (no ghosting)
9085  integer jlast ! Last PE latitude (no ghosting)
9086  integer, intent(in):: ng_s, ng_d
9087  real, intent(in):: coslon(im,jm), sinlon(im,jm)
9088  real, intent(in):: cosl5(im,jm),sinl5(im,jm)
9089  real, intent(in):: u(im,jfirst-ng_d:jlast+ng_s)
9090 
9091 ! !INPUT/OUTPUT PARAMETERS:
9092  real, intent(inout):: v(im,jfirst-ng_d:jlast+ng_d)
9093 
9094 ! !DESCRIPTION:
9095 !
9096 ! Treat the V winds at the poles. This requires an average
9097 ! of the U- and V-winds, weighted by their angles of incidence
9098 ! at the pole points.
9099 !
9100 ! !REVISION HISTORY:
9101 !
9102 !EOP
9103 !-----------------------------------------------------------------------
9104 !BOC
9105 !
9106 ! !LOCAL VARIABLES:
9107 
9108  integer i, imh
9109  real uanp(im), uasp(im), vanp(im), vasp(im)
9110  real un, vn, us, vs, r2im
9111 
9112 ! WS 99.05.25 : Replaced conversions of IMR with IM
9113  r2im = 0.5d0/dble(im)
9114  imh = im / 2
9115 
9116 ! WS 990726 : Added condition to decide if poles are on this processor
9117 
9118  if ( jfirst-ng_d <= 1 ) then
9119  do i=1,im
9120  uasp(i) = u(i, 2) + u(i,3)
9121  enddo
9122 
9123  do i=1,im-1
9124  vasp(i) = v(i, 2) + v(i+1,2)
9125  enddo
9126  vasp(im) = v(im,2) + v(1,2)
9127 
9128 ! Projection at SP
9129  us = 0.; vs = 0.
9130 
9131  do i=1,imh
9132  us = us + (uasp(i+imh)-uasp(i))*sinlon(i,1) &
9133  + (vasp(i)-vasp(i+imh))*coslon(i,1)
9134  vs = vs + (uasp(i+imh)-uasp(i))*coslon(i,1) &
9135  + (vasp(i+imh)-vasp(i))*sinlon(i,1)
9136  enddo
9137  us = us*r2im
9138  vs = vs*r2im
9139 
9140 ! get V-wind at SP
9141 
9142  do i=1,imh
9143  v(i, 1) = us*cosl5(i,1) - vs*sinl5(i,1)
9144  v(i+imh,1) = -v(i,1)
9145  enddo
9146 
9147  endif
9148 
9149  if ( jlast+ng_d >= jm ) then
9150 
9151  do i=1,im
9152  uanp(i) = u(i,jm-1) + u(i,jm)
9153  enddo
9154 
9155  do i=1,im-1
9156  vanp(i) = v(i,jm-1) + v(i+1,jm-1)
9157  enddo
9158  vanp(im) = v(im,jm-1) + v(1,jm-1)
9159 
9160 ! Projection at NP
9161 
9162  un = 0.
9163  vn = 0.
9164  do i=1,imh
9165  un = un + (uanp(i+imh)-uanp(i))*sinlon(i,jm) &
9166  + (vanp(i+imh)-vanp(i))*coslon(i,jm)
9167  vn = vn + (uanp(i)-uanp(i+imh))*coslon(i,jm) &
9168  + (vanp(i+imh)-vanp(i))*sinlon(i,jm)
9169  enddo
9170  un = un*r2im
9171  vn = vn*r2im
9172 
9173 ! get V-wind at NP
9174 
9175  do i=1,imh
9176  v(i, jm) = -un*cosl5(i,jm) - vn*sinl5(i,jm)
9177  v(i+imh,jm) = -v(i,jm)
9178  enddo
9179 
9180  endif
9181 
9182  end subroutine vpol5
9183 
9184  subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
9185 ! Single PE version
9186  character(len=*), intent(in):: qname
9187  integer, intent(in):: is, ie, js, je
9188  integer, intent(in):: n_g, km
9189  real, intent(in):: q(is-n_g:ie+n_g, js-n_g:je+n_g, km)
9190  real, intent(in):: fac
9191 
9192  real qmin, qmax
9193  integer i,j,k
9194 
9195  qmin = q(is,js,1)
9196  qmax = qmin
9197 
9198  do k=1,km
9199  do j=js,je
9200  do i=is,ie
9201  if( q(i,j,k) < qmin ) then
9202  qmin = q(i,j,k)
9203  elseif( q(i,j,k) > qmax ) then
9204  qmax = q(i,j,k)
9205  endif
9206  enddo
9207  enddo
9208  enddo
9209 
9210  write(*,*) qname, ' max = ', qmax*fac, ' min = ', qmin*fac
9211 
9212  end subroutine prt_m1
9213 
9214  subroutine var_dz(km, ztop, ze)
9215  integer, intent(in):: km
9216  real, intent(in):: ztop
9217  real, intent(out), dimension(km+1):: ze
9218 ! Local
9219  real, dimension(km):: dz, s_fac
9220  real dz0, sum1
9221  integer k
9222 
9223  s_fac(km ) = 0.25
9224  s_fac(km-1) = 0.30
9225  s_fac(km-2) = 0.50
9226  s_fac(km-3) = 0.70
9227  s_fac(km-4) = 0.90
9228  s_fac(km-5) = 1.
9229  do k=km-6, 5, -1
9230  s_fac(k) = 1.05 * s_fac(k+1)
9231  enddo
9232  s_fac(4) = 1.1*s_fac(5)
9233  s_fac(3) = 1.2*s_fac(4)
9234  s_fac(2) = 1.3*s_fac(3)
9235  s_fac(1) = 1.5*s_fac(2)
9236 
9237  sum1 = 0.
9238  do k=1,km
9239  sum1 = sum1 + s_fac(k)
9240  enddo
9241 
9242  dz0 = ztop / sum1
9243 
9244  do k=1,km
9245  dz(k) = s_fac(k) * dz0
9246  enddo
9247 
9248  ze(km+1) = 0.
9249  do k=km,1,-1
9250  ze(k) = ze(k+1) + dz(k)
9251  enddo
9252 
9253 ! Re-scale dz with the stretched ztop
9254  do k=1,km
9255  dz(k) = dz(k) * (ztop/ze(1))
9256  enddo
9257 
9258  do k=km,1,-1
9259  ze(k) = ze(k+1) + dz(k)
9260  enddo
9261  ze(1) = ztop
9262 
9263  call sm1_edge(1, 1, 1, 1, km, 1, 1, ze, 1)
9264 
9265  if ( is_master() ) then
9266  write(*,*) 'var_dz: model top (km)=', ztop*0.001
9267  do k=km,1,-1
9268  dz(k) = ze(k) - ze(k+1)
9269  write(*,*) k, 0.5*(ze(k)+ze(k+1)), 'dz=', dz(k)
9270  enddo
9271  endif
9272 
9273  end subroutine var_dz
9274 
9275  subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
9276  integer, intent(in):: is, ie, js, je, km
9277  integer, intent(in):: ntimes, i, j
9278  real, intent(inout):: ze(is:ie,js:je,km+1)
9279 ! local:
9280  real, parameter:: df = 0.25
9281  real dz(km)
9282  real flux(km+1)
9283  integer k, n, k1, k2
9284 
9285  k2 = km-1
9286  do k=1,km
9287  dz(k) = ze(i,j,k+1) - ze(i,j,k)
9288  enddo
9289 
9290  do n=1,ntimes
9291  k1 = 2 + (ntimes-n)
9292 
9293  flux(k1 ) = 0.
9294  flux(k2+1) = 0.
9295  do k=k1+1,k2
9296  flux(k) = df*(dz(k) - dz(k-1))
9297  enddo
9298 
9299  do k=k1,k2
9300  dz(k) = dz(k) - flux(k) + flux(k+1)
9301  enddo
9302  enddo
9303 
9304  do k=km,1,-1
9305  ze(i,j,k) = ze(i,j,k+1) - dz(k)
9306  enddo
9307 
9308  end subroutine sm1_edge
9309 
9310 
9311 
9312 end module test_cases_nlm_mod
fv_diagnostics_nlm_mod::eqv_pot
subroutine, public eqv_pot(theta_e, pt, delp, delz, peln, pkz, q, is, ie, js, je, ng, npz, hydrostatic, moist)
Definition: fv_diagnostics_nlm.F90:3744
tracer_manager_mod::get_tracer_index
Definition: tracer_manager.F90:124
fv_mp_nlm_mod
Definition: fv_mp_nlm_mod.F90:24
constants_mod
Definition: constants.F90:24
constants_mod::radius
real, parameter, public radius
Radius of the Earth [m].
Definition: constants.F90:72
mpp_parameter_mod
Definition: mpp_parameter.F90:19
test_cases_nlm_mod::tvort_orig
real tvort_orig
Definition: test_cases_nlm.F90:143
field_manager_mod::model_atmos
integer, parameter, public model_atmos
Definition: field_manager.F90:299
test_cases_nlm_mod::mp_update_dwinds_3d
subroutine mp_update_dwinds_3d(u, v, npx, npy, npz, domain)
Definition: test_cases_nlm.F90:8746
fv_grid_tools_nlm_mod::spherical_to_cartesian
subroutine, public spherical_to_cartesian(lon, lat, r, x, y, z)
Definition: fv_grid_tools_nlm.F90:1812
init_hydro_nlm_mod::p_var
subroutine, public p_var(km, ifirst, ilast, jfirst, jlast, ptop, ptop_min, delp, delz, pt, ps, pe, peln, pk, pkz, cappa, q, ng, nq, area, dry_mass, adjust_dry_mass, mountain, moist_phys, hydrostatic, nwat, domain, make_nh)
Definition: init_hydro_nlm.F90:47
test_cases_nlm_mod::tracer_test
integer, public tracer_test
Definition: test_cases_nlm.F90:121
constants_mod::omega
real, parameter, public omega
Rotation rate of the Earth [1/s].
Definition: constants.F90:75
fv_grid_utils_nlm_mod::get_unit_vect2
subroutine, public get_unit_vect2(e1, e2, uc)
Definition: fv_grid_utils_nlm.F90:1776
test_cases_nlm_mod::initwindscase6
integer, parameter initwindscase6
Definition: test_cases_nlm.F90:116
test_cases_nlm_mod::lat0
real lat0
Definition: test_cases_nlm.F90:105
field_manager_mod
Definition: field_manager.F90:20
fv_grid_utils_nlm_mod::ptop_min
real, parameter, public ptop_min
Definition: fv_grid_utils_nlm.F90:54
test_cases_nlm_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_nlm.F90:5999
fv_grid_tools_nlm_mod::todeg
real(kind=r_grid), parameter, public todeg
Definition: fv_grid_tools_nlm.F90:66
mpp_parameter_mod::dgrid_ne
integer, parameter, public dgrid_ne
Definition: mpp_parameter.F90:106
test_cases_nlm_mod::initwindscase2
integer, parameter initwindscase2
Definition: test_cases_nlm.F90:114
constants_mod::pi_8
real(kind=8), parameter, public pi_8
Ratio of circle circumference to diameter [N/A].
Definition: constants.F90:73
test_cases_nlm_mod::case9_forcing1
subroutine, public case9_forcing1(phis, time_since_start)
Definition: test_cases_nlm.F90:4087
fv_grid_tools_nlm_mod::missing
real(kind=r_grid), parameter, public missing
Definition: fv_grid_tools_nlm.F90:68
fv_arrays_nlm_mod::fv_grid_type
Definition: fv_arrays_nlm.F90:115
test_cases_nlm_mod::var_dz
subroutine var_dz(km, ztop, ze)
Definition: test_cases_nlm.F90:9215
qg_constants::f0
real(kind=kind_real), parameter f0
Coriolis parameter at southern boundary.
Definition: qg_constants.f90:26
dcmip16_tc_pressure
real function dcmip16_tc_pressure(z, r)
Definition: test_cases_nlm.F90:7698
test_cases_nlm_mod::superk_u
subroutine superk_u(km, zz, um, dudz)
Definition: test_cases_nlm.F90:6996
test_cases_nlm_mod::initwindscase5
integer, parameter initwindscase5
Definition: test_cases_nlm.F90:115
mpp_domains_mod::mpp_update_domains
Definition: mpp_domains.F90:1068
test_cases_nlm_mod::ua0
real, dimension(:,:,:), allocatable ua0
Definition: test_cases_nlm.F90:135
test_cases_nlm_mod::theta_d
integer theta_d
Definition: test_cases_nlm.F90:93
test_cases_nlm_mod::gh_table
real, dimension(:), allocatable gh_table
Definition: test_cases_nlm.F90:138
crtm_parameters::up
integer, parameter, public up
Definition: CRTM_Parameters.f90:98
test_cases_nlm_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_nlm.F90:468
test_cases_nlm_mod::lon0
real lon0
Definition: test_cases_nlm.F90:106
test_cases_nlm_mod::mp_update_dwinds_2d
subroutine mp_update_dwinds_2d(u, v, npx, npy, domain)
Definition: test_cases_nlm.F90:8728
test_cases_nlm_mod::case9_forcing2
subroutine, public case9_forcing2(phis)
Definition: test_cases_nlm.F90:4122
dcmip16_bc_uwind_pert
real function dcmip16_bc_uwind_pert(z, lat, lon)
Definition: test_cases_nlm.F90:7370
dcmip16_bc_temperature
real function dcmip16_bc_temperature(z, lat)
Definition: test_cases_nlm.F90:7321
test_cases_nlm_mod::globalsum
real function globalsum(p, npx, npy, ifirst, ilast, jfirst, jlast, isd, ied, jsd, jed, gridstruct, tile)
Definition: test_cases_nlm.F90:8766
test_cases_nlm_mod::p0_c0
real p0_c0
Definition: test_cases_nlm.F90:103
test_cases_nlm_mod::tener_orig
real tener_orig
Definition: test_cases_nlm.F90:144
test_cases_nlm_mod::init_winds
subroutine init_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, npx, npy, ng, ndims, nregions, nested, gridstruct, domain, tile)
Definition: test_cases_nlm.F90:171
mid_pt_sphere
void mid_pt_sphere(const double *p1, const double *p2, double *pm)
Definition: gradient_c2l.c:326
fv_sg_nlm_mod
Definition: fv_sg_nlm.F90:20
constants_mod::rdgas
real, parameter, public rdgas
Gas constant for dry air [J/kg/deg].
Definition: constants.F90:77
test_cases_nlm_mod::u_jet
real function u_jet(lat)
Definition: test_cases_nlm.F90:4042
test_cases_nlm_mod::ctoa
subroutine ctoa(uin, vin, uout, vout, dx, dy, dxc, dyc, dxa, dya, npx, npy, ng)
Definition: test_cases_nlm.F90:8627
test_cases_nlm_mod::get_vorticity
subroutine get_vorticity(isc, iec, jsc, jec, isd, ied, jsd, jed, npz, u, v, vort, dx, dy, rarea)
Definition: test_cases_nlm.F90:3747
test_cases_nlm_mod::init_latlon
subroutine, public init_latlon(u, v, pt, delp, q, phis, ps, pe, peln, pk, pkz, uc, vc, ua, va, ak, bk, gridstruct, npx, npy, npz, ng, ncnst, ndims, nregions, dry_mass, mountain, moist_phys, hybrid_z, delz, ze0, domain_in, tile_in)
Definition: test_cases_nlm.F90:7757
fv_eta_nlm_mod::gw_1d
subroutine, public gw_1d(km, p0, ak, bk, ptop, ztop, pt1)
Definition: fv_eta_nlm.F90:2962
test_cases_nlm_mod::superk_sounding
subroutine superk_sounding(km, pe, p00, ze, pt, qz)
Definition: test_cases_nlm.F90:6710
test_cases_nlm_mod::gh0
real gh0
Definition: test_cases_nlm.F90:126
dcmip16_tc_uwind_pert
subroutine dcmip16_tc_uwind_pert(z, r, lon, lat, uu, vv)
Definition: test_cases_nlm.F90:7711
mpp_mod::mpp_chksum
Definition: mpp.F90:1232
fv_grid_utils_nlm_mod::cubed_to_latlon
subroutine, public cubed_to_latlon(u, v, ua, va, gridstruct, npx, npy, km, mode, grid_type, domain, nested, c2l_ord, bd)
Definition: fv_grid_utils_nlm.F90:2314
mpp_mod::mpp_broadcast
Definition: mpp.F90:1124
test_cases_nlm_mod::get_pt_on_great_circle
subroutine get_pt_on_great_circle(p1, p2, dist, heading, p3)
Definition: test_cases_nlm.F90:4906
mpp_mod
Definition: mpp.F90:39
test_cases_nlm_mod::pi_shift
real, parameter pi_shift
Definition: test_cases_nlm.F90:109
test_cases_nlm_mod::init_latlon_winds
subroutine init_latlon_winds(UBar, u, v, ua, va, uc, vc, defOnGrid, gridstruct)
Definition: test_cases_nlm.F90:7935
fv_grid_utils_nlm_mod
Definition: fv_grid_utils_nlm.F90:20
fv_grid_utils_nlm_mod::project_sphere_v
subroutine, public project_sphere_v(np, f, e)
Definition: fv_grid_utils_nlm.F90:3272
test_cases_nlm_mod::rotate_winds
subroutine rotate_winds(myU, myV, p1, p2, p3, p4, t1, ndims, dir)
Definition: test_cases_nlm.F90:8683
test_cases_nlm_mod::va0
real, dimension(:,:,:), allocatable va0
Definition: test_cases_nlm.F90:136
test_cases_nlm_mod::get_stats
subroutine, public get_stats(dt, dtout, nt, maxnt, ndays, u, v, pt, delp, q, phis, ps, uc, vc, ua, va, npx, npy, npz, ncnst, ndims, nregions, gridstruct, stats_lun, consv_lun, monitorFreq, tile, domain, nested)
Definition: test_cases_nlm.F90:4462
test_cases_nlm_mod::pmxn
subroutine pmxn(p, npx, npy, nregions, tile, gridstruct, pmin, pmax, i0, j0, n0)
Definition: test_cases_nlm.F90:5253
mpp_domains_mod
Definition: mpp_domains.F90:128
test_cases_nlm_mod::get_case9_b
subroutine get_case9_b(B, agrid)
Definition: test_cases_nlm.F90:4058
test_cases_nlm_mod::alpha
real, public alpha
Definition: test_cases_nlm.F90:98
mpp_parameter_mod::agrid
integer, parameter, public agrid
Definition: mpp_parameter.F90:101
fv_eta_nlm_mod::hybrid_z_dz
subroutine, public hybrid_z_dz(km, dz, ztop, s_rate)
Definition: fv_eta_nlm.F90:2470
test_cases_nlm_mod::vpol5
subroutine vpol5(u, v, im, jm, coslon, sinlon, cosl5, sinl5, ng_d, ng_s, jfirst, jlast)
Definition: test_cases_nlm.F90:9080
test_cases_nlm_mod::interp_left_edge_1d
subroutine interp_left_edge_1d(qout, qin, dx, ifirst, ilast, order)
Definition: test_cases_nlm.F90:8970
test_cases_nlm_mod::dcmip16_bc
subroutine dcmip16_bc(delp, pt, u, v, q, w, delz, is, ie, js, je, isd, ied, jsd, jed, npz, nq, ak, bk, ptop, pk, peln, pe, pkz, gz, phis, ps, grid, agrid, hydrostatic, nwat, adiabatic, do_pert, domain)
Definition: test_cases_nlm.F90:7034
test_cases_nlm_mod::tmass_orig
real tmass_orig
Definition: test_cases_nlm.F90:142
test_cases_nlm_mod::initwindscase9
integer, parameter initwindscase9
Definition: test_cases_nlm.F90:117
test_cases_nlm_mod::zz0
real, dimension(:), allocatable, public zz0
Definition: test_cases_nlm.F90:119
test_cases_nlm_mod::ubar
real ubar
Definition: test_cases_nlm.F90:124
fv_grid_utils_nlm_mod::f_p
integer, parameter, public f_p
Definition: fv_grid_utils_nlm.F90:47
test_cases_nlm_mod::gh_jet
real function gh_jet(npy, lat_in)
Definition: test_cases_nlm.F90:3995
mpp_domains_mod::domain2d
Definition: mpp_domains.F90:378
fv_grid_utils_nlm_mod::cart_to_latlon
subroutine, public cart_to_latlon(np, q, xs, ys)
Definition: fv_grid_utils_nlm.F90:1667
constants_mod::rvgas
real, parameter, public rvgas
Gas constant for water vapor [J/kg/deg].
Definition: constants.F90:78
test_cases_nlm_mod::check_courant_numbers
subroutine, public check_courant_numbers(uc, vc, ndt, n_split, gridstruct, npx, npy, npz, tile, noPrint)
Definition: test_cases_nlm.F90:5126
qg_constants::u1
real(kind=kind_real), parameter u1
Definition: qg_constants.f90:35
test_cases_nlm_mod::atoc
subroutine atoc(uin, vin, uout, vout, dx, dy, dxa, dya, npx, npy, ng, nested, domain, noComm)
Definition: test_cases_nlm.F90:8502
test_cases_nlm_mod::get_vector_stats
subroutine get_vector_stats(varU, varUT, varV, varVT, npx, npy, ndims, nregions, vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
Definition: test_cases_nlm.F90:5031
test_cases_nlm_mod::initwindscase0
integer, parameter initwindscase0
Definition: test_cases_nlm.F90:112
test_cases_nlm_mod::wind_field
integer, public wind_field
Definition: test_cases_nlm.F90:121
fv_mp_nlm_mod::ng
integer, parameter, public ng
Definition: fv_mp_nlm_mod.F90:2465
init_hydro_nlm_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)
Definition: init_hydro_nlm.F90:281
test_cases_nlm_mod::soliton_size
real, public soliton_size
Definition: test_cases_nlm.F90:100
dcmip16_bc_sphum
real function dcmip16_bc_sphum(p, ps, lat, lon)
Definition: test_cases_nlm.F90:7387
test_cases_nlm_mod::vbar
real vbar
Definition: test_cases_nlm.F90:124
test_cases_nlm_mod::d2a2c
subroutine d2a2c(im, jm, km, ifirst, ilast, jfirst, jlast, ng, nested, u, v, ua, va, uc, vc, gridstruct, domain)
Definition: test_cases_nlm.F90:8021
fv_arrays_nlm_mod::fv_flags_type
Definition: fv_arrays_nlm.F90:236
crtm_parameters::one
real(fp), parameter, public one
Definition: CRTM_Parameters.f90:71
constants_mod::cp_air
real, parameter, public cp_air
Specific heat capacity of dry air at constant pressure [J/kg/deg].
Definition: constants.F90:83
test_cases_nlm_mod::interporder
integer, parameter interporder
Definition: test_cases_nlm.F90:146
fv_arrays_nlm_mod
Definition: fv_arrays_nlm.F90:20
fv_surf_map_nlm_mod
Definition: fv_surf_map_nlm.F90:20
fv_grid_tools_nlm_mod
Definition: fv_grid_tools_nlm.F90:20
fv_arrays_nlm_mod::r_grid
integer, parameter, public r_grid
Definition: fv_arrays_nlm.F90:32
mpp_mod::mpp_sum
Definition: mpp.F90:680
test_cases_nlm_mod::rankine_vortex
subroutine rankine_vortex(ubar, r0, p1, u, v, grid)
Definition: test_cases_nlm.F90:3918
fv_surf_map_nlm_mod::surfdrv
subroutine, public surfdrv(npx, npy, grid, agrid, area, dx, dy, dxa, dya, dxc, dyc, sin_sg, phis, stretch_fac, nested, npx_global, domain, grid_number, bd)
Definition: fv_surf_map_nlm.F90:91
fv_grid_utils_nlm_mod::great_circle_dist
real function, public great_circle_dist(q1, q2, radius)
Definition: fv_grid_utils_nlm.F90:1968
fv_sg_nlm_mod::qsmith
subroutine, public qsmith(im, km, k1, t, p, q, qs, dqdt)
Definition: fv_sg_nlm.F90:1005
fv_grid_utils_nlm_mod::get_latlon_vector
subroutine, public get_latlon_vector(pp, elon, elat)
Definition: fv_grid_utils_nlm.F90:3253
test_cases_nlm_mod::dtoa
subroutine dtoa(uin, vin, uout, vout, dx, dy, dxa, dya, dxc, dyc, npx, npy, ng)
Definition: test_cases_nlm.F90:8446
test_cases_nlm_mod::nsolitons
integer, public nsolitons
Definition: test_cases_nlm.F90:99
test_cases_nlm_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_nlm.F90:3781
dcmip16_bc_uwind
real function dcmip16_bc_uwind(z, T, lat)
Definition: test_cases_nlm.F90:7354
init_hydro_nlm_mod
Definition: init_hydro_nlm.F90:21
test_cases_nlm_mod::soliton_umax
real, public soliton_umax
Definition: test_cases_nlm.F90:100
test_cases_nlm_mod::aoft
real, dimension(2) aoft
Definition: test_cases_nlm.F90:130
test_cases_nlm_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_nlm.F90:8909
test_cases_nlm_mod::case9_b
real, dimension(:,:), allocatable case9_b
Definition: test_cases_nlm.F90:129
test_cases_nlm_mod
Definition: test_cases_nlm.F90:21
fv_eta_nlm_mod
Definition: fv_eta_nlm.F90:20
test_cases_nlm_mod::atob_s
subroutine atob_s(qin, qout, npx, npy, dxa, dya, nested, cubed_sphere, altInterp)
Definition: test_cases_nlm.F90:8255
fv_grid_utils_nlm_mod::make_eta_level
subroutine, public make_eta_level(km, pe, area, kks, ak, bk, ptop, domain, bd)
Definition: fv_grid_utils_nlm.F90:3079
test_cases_nlm_mod::rgamma
real rgamma
Definition: test_cases_nlm.F90:104
test_cases_nlm_mod::phi0
real, dimension(:,:,:), allocatable phi0
Definition: test_cases_nlm.F90:134
test_cases_nlm_mod::gh_initialized
logical gh_initialized
Definition: test_cases_nlm.F90:139
constants_mod::grav
real, parameter, public grav
Acceleration due to gravity [m/s^2].
Definition: constants.F90:76
test_cases_nlm_mod::get_scalar_stats
subroutine get_scalar_stats(var, varT, npx, npy, ndims, nregions, vmin, vmax, L1_norm, L2_norm, Linf_norm, gridstruct, tile)
Definition: test_cases_nlm.F90:4942
fv_grid_utils_nlm_mod::g_sum
real function, public g_sum(domain, p, ifirst, ilast, jfirst, jlast, ngc, area, mode, reproduce)
Definition: fv_grid_utils_nlm.F90:2874
tracer_manager_mod
Definition: tracer_manager.F90:20
test_cases_nlm_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_nlm.F90:7407
test_cases_nlm_mod::atod
subroutine atod(uin, vin, uout, vout, dxa, dya, dxc, dyc, npx, npy, ng, nested, domain)
Definition: test_cases_nlm.F90:8397
test_cases_nlm_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_nlm.F90:6842
mpp_mod::mpp_error
Definition: mpp.F90:402
dcmip16_bc_pressure
real function dcmip16_bc_pressure(z, lat)
Definition: test_cases_nlm.F90:7338
normalize_vect
void normalize_vect(double *e)
Definition: mosaic_util.c:679
test_cases_nlm_mod::bubble_do
logical, public bubble_do
Definition: test_cases_nlm.F90:97
test_cases_nlm_mod::lats_table
real, dimension(:), allocatable lats_table
Definition: test_cases_nlm.F90:138
test_cases_nlm_mod::sm1_edge
subroutine sm1_edge(is, ie, js, je, km, i, j, ze, ntimes)
Definition: test_cases_nlm.F90:9276
max
#define max(a, b)
Definition: mosaic_util.h:33
test_cases_nlm_mod::initwindscase1
integer, parameter initwindscase1
Definition: test_cases_nlm.F90:113
fv_grid_tools_nlm_mod::get_unit_vector
Definition: fv_grid_tools_nlm.F90:75
test_cases_nlm_mod::terminator_tracers
subroutine terminator_tracers(i0, i1, j0, j1, ifirst, ilast, jfirst, jlast, km, q, delp, ncnst, lon, lat)
Definition: test_cases_nlm.F90:3850
fv_eta_nlm_mod::set_hybrid_z
subroutine, public set_hybrid_z(is, ie, js, je, ng, km, ztop, dz, rgrav, hs, ze, dz3)
Definition: fv_eta_nlm.F90:2787
fv_eta_nlm_mod::compute_dz_l101
subroutine, public compute_dz_l101(km, ztop, dz)
Definition: fv_eta_nlm.F90:2745
dcmip16_tc_temperature
real function dcmip16_tc_temperature(z, r)
Definition: test_cases_nlm.F90:7680
test_cases_nlm_mod::mp_update_dwinds
Definition: test_cases_nlm.F90:158
fv_eta_nlm_mod::compute_dz_l32
subroutine, public compute_dz_l32(km, ztop, dz)
Definition: fv_eta_nlm.F90:2676
fv_diagnostics_nlm_mod::prt_maxmin
subroutine, public prt_maxmin(qname, q, is, ie, js, je, n_g, km, fac)
Definition: fv_diagnostics_nlm.F90:2771
test_cases_nlm_mod::test_case
integer, public test_case
Definition: test_cases_nlm.F90:96
fv_grid_utils_nlm_mod::inner_prod
real function, public inner_prod(v1, v2)
Definition: fv_grid_utils_nlm.F90:912
fv_diagnostics_nlm_mod::qcly0
real, public qcly0
Definition: fv_diagnostics_nlm.F90:77
fv_diagnostics_nlm_mod::ppme
subroutine, public ppme(p, qe, delp, im, km)
Definition: fv_diagnostics_nlm.F90:3599
test_cases_nlm_mod::pz0
real, dimension(:), allocatable, public pz0
Definition: test_cases_nlm.F90:119
min
#define min(a, b)
Definition: mosaic_util.h:32
latlon2xyz
void latlon2xyz(int size, const double *lon, const double *lat, double *x, double *y, double *z)
Definition: mosaic_util.c:211
dcmip16_tc_sphum
real function dcmip16_tc_sphum(z)
Definition: test_cases_nlm.F90:7742
mpp_parameter_mod::scalar_pair
integer, parameter, public scalar_pair
Definition: mpp_parameter.F90:111
fv_diagnostics_nlm_mod
Definition: fv_diagnostics_nlm.F90:20
constants_mod::kappa
real, parameter, public kappa
RDGAS / CP_AIR [dimensionless].
Definition: constants.F90:82
mpp_parameter_mod::cgrid_ne
integer, parameter, public cgrid_ne
Definition: mpp_parameter.F90:104
test_cases_nlm_mod::sphum
integer sphum
Definition: test_cases_nlm.F90:93
fv_arrays_nlm_mod::fv_grid_bounds_type
Definition: fv_arrays_nlm.F90:601
test_cases_nlm_mod::case51_forcing
subroutine, public case51_forcing(delp, uc, vc, u, v, ua, va, pe, time, dt, gridstruct, npx, npy, npz, ptop, domain)
Definition: test_cases_nlm.F90:4140
test_cases_nlm_mod::prt_m1
subroutine prt_m1(qname, q, is, ie, js, je, n_g, km, fac)
Definition: test_cases_nlm.F90:9185
crtm_parameters::pi
real(fp), parameter, public pi
Definition: CRTM_Parameters.f90:86