<p><b>duda</b> 2011-10-21 11:41:56 -0600 (Fri, 21 Oct 2011)</p><p>BRANCH COMMIT<br>
<br>
Apply renaming scheme to files, modules, and subroutines in the hydrostatic atmosphere core.<br>
</p><hr noshade><pre><font color="gray">Modified: branches/source_renaming/src/core_hyd_atmos/Makefile
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/Makefile 2011-10-20 22:17:57 UTC (rev 1111)
+++ branches/source_renaming/src/core_hyd_atmos/Makefile 2011-10-21 17:41:56 UTC (rev 1112)
@@ -1,22 +1,22 @@
.SUFFIXES: .F .o
-OBJS = module_mpas_core.o \
- module_test_cases.o \
- module_time_integration.o \
- module_advection.o
+OBJS = mpas_atmh_mpas_core.o \
+ mpas_atmh_test_cases.o \
+ mpas_atmh_time_integration.o \
+ mpas_atmh_advection.o
all: core_hyd
core_hyd: $(OBJS)
ar -ru libdycore.a $(OBJS)
-module_test_cases.o:
+mpas_atmh_test_cases.o:
-module_time_integration.o:
+mpas_atmh_time_integration.o:
-module_advection.o:
+mpas_atmh_advection.o:
-module_mpas_core.o: module_advection.o module_test_cases.o module_time_integration.o
+mpas_atmh_mpas_core.o: mpas_atmh_advection.o mpas_atmh_test_cases.o mpas_atmh_time_integration.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Deleted: branches/source_renaming/src/core_hyd_atmos/module_advection.F
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/module_advection.F 2011-10-20 22:17:57 UTC (rev 1111)
+++ branches/source_renaming/src/core_hyd_atmos/module_advection.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -1,688 +0,0 @@
-module advection
-
- use mpas_grid_types
- use mpas_configure
- use mpas_constants
-
-
- contains
-
-
- subroutine initialize_advection_rk( grid )
-
-!
-! compute the cell coefficients for the polynomial fit.
-! this is performed during setup for model integration.
-! WCS, 31 August 2009
-!
- implicit none
-
- type (mesh_type), intent(in) :: grid
-
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: advCells
-
-! local variables
-
- real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
- real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
- real (kind=RKIND), dimension(grid % nCells) :: theta_abs
-
- real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
- real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
- real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
- real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
- real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
- integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
- integer :: iCell, iEdge
- real (kind=RKIND) :: pii
- real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
- real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
- real (kind=RKIND) :: angv1, angv2, dl1, dl2
- real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
-
- real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
- real (kind=RKIND) :: length_scale
- integer :: ma,na, cell_add, mw, nn
- integer, dimension(25) :: cell_list
-
-
- integer :: cell1, cell2
- integer, parameter :: polynomial_order = 2
-! logical, parameter :: debug = .true.
- logical, parameter :: debug = .false.
-! logical, parameter :: least_squares = .false.
- logical, parameter :: least_squares = .true.
- logical :: add_the_cell, do_the_cell
-
- logical, parameter :: reset_poly = .true.
-
- real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
-
-!---
-
- pii = 2.*asin(1.0)
-
- advCells => grid % advCells % array
- deriv_two => grid % deriv_two % array
- deriv_two(:,:,:) = 0.
-
- do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
-
- cell_list(1) = iCell
- do i=2, grid % nEdgesOnCell % array(iCell)+1
- cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
- end do
- n = grid % nEdgesOnCell % array(iCell) + 1
-
- if ( polynomial_order > 2 ) then
- do i=2,grid % nEdgesOnCell % array(iCell) + 1
- do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
- cell_add = grid % CellsOnCell % array (j,cell_list(i))
- add_the_cell = .true.
- do k=1,n
- if ( cell_add == cell_list(k) ) add_the_cell = .false.
- end do
- if (add_the_cell) then
- n = n+1
- cell_list(n) = cell_add
- end if
- end do
- end do
- end if
-
- advCells(1,iCell) = n
-
-! check to see if we are reaching outside the halo
-
- do_the_cell = .true.
- do i=1,n
- if (cell_list(i) > grid % nCells) do_the_cell = .false.
- end do
-
-
- if ( .not. do_the_cell ) cycle
-
-
-! compute poynomial fit for this cell if all needed neighbors exist
- if ( grid % on_a_sphere ) then
-
- do i=1,n
- advCells(i+1,iCell) = cell_list(i)
- xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
- yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
- zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
- end do
-
- theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
- xc(2), yc(2), zc(2), &
- 0., 0., 1. )
-
-! angles from cell center to neighbor centers (thetav)
-
- do i=1,n-1
-
- ip2 = i+2
- if (ip2 > n) ip2 = 2
-
- thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xc(ip2), yc(ip2), zc(ip2) )
-
- dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1) )
- end do
-
- length_scale = 1.
- do i=1,n-1
- dl_sphere(i) = dl_sphere(i)/length_scale
- end do
-
-! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
- thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
- do i=2,n-1
- thetat(i) = thetat(i-1) + thetav(i-1)
- end do
-
- do i=1,n-1
- xp(i) = cos(thetat(i)) * dl_sphere(i)
- yp(i) = sin(thetat(i)) * dl_sphere(i)
- end do
-
- else ! On an x-y plane
-
- do i=1,n-1
- xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
- yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
- end do
-
- end if
-
-
- ma = n-1
- mw = grid % nEdgesOnCell % array (iCell)
-
- bmatrix = 0.
- amatrix = 0.
- wmatrix = 0.
-
- if (polynomial_order == 2) then
- na = 6
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- wmatrix(i,i) = 1.
- end do
-
- else if (polynomial_order == 3) then
- na = 10
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
-
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- amatrix(i,7) = xp(i-1)**3
- amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
- amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
- amatrix(i,10) = yp(i-1)**3
-
- wmatrix(i,i) = 1.
-
- end do
-
- else
- na = 15
- ma = ma+1
-
- amatrix(1,1) = 1.
- wmatrix(1,1) = 1.
- do i=2,ma
- amatrix(i,1) = 1.
- amatrix(i,2) = xp(i-1)
- amatrix(i,3) = yp(i-1)
-
- amatrix(i,4) = xp(i-1)**2
- amatrix(i,5) = xp(i-1) * yp(i-1)
- amatrix(i,6) = yp(i-1)**2
-
- amatrix(i,7) = xp(i-1)**3
- amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
- amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
- amatrix(i,10) = yp(i-1)**3
-
- amatrix(i,11) = xp(i-1)**4
- amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
- amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
- amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
- amatrix(i,15) = yp(i-1)**4
-
- wmatrix(i,i) = 1.
-
- end do
-
- do i=1,mw
- wmatrix(i,i) = 1.
- end do
-
- end if
-
- call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
-
- do i=1,grid % nEdgesOnCell % array (iCell)
- ip1 = i+1
- if (ip1 > n-1) ip1 = 1
-
- iEdge = grid % EdgesOnCell % array (i,iCell)
- xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
- xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
- zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
-
- if ( grid % on_a_sphere ) then
- call arc_bisect( xv1, yv1, zv1, &
- xv2, yv2, zv2, &
- xec, yec, zec )
-
- thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
- xc(i+1), yc(i+1), zc(i+1), &
- xec, yec, zec )
- thetae_tmp = thetae_tmp + thetat(i)
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
- thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
- else
- thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
- end if
- else
- xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
- ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
- end if
-
- end do
-
-! fill second derivative stencil for rk advection
-
- do i=1, grid % nEdgesOnCell % array (iCell)
- iEdge = grid % EdgesOnCell % array (i,iCell)
-
-
- if ( grid % on_a_sphere ) then
- if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
-
- cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
- sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
- do j=1,n
- deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- else
-
- cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
- sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
- costsint = cos2t*sin2t
- cos2t = cos2t**2
- sin2t = sin2t**2
-
- do j=1,n
- deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
- + 2.*costsint*bmatrix(5,j) &
- + 2.*sin2t*bmatrix(6,j)
- end do
- end if
- else
- do j=1,n
- deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
- + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
- + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
- deriv_two(j,2,iEdge) = deriv_two(j,1,iEdge)
- end do
- end if
- end do
-
- end do ! end of loop over cells
-
- if (debug) stop
-
- end subroutine initialize_advection_rk
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION SPHERE_ANGLE
- !
- ! Computes the angle between arcs AB and AC, given points A, B, and C
- ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
-
- real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
-
- real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
- real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
-
- real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
- real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
- real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
-
- real (kind=RKIND) :: s ! Semiperimeter of the triangle
- real (kind=RKIND) :: sin_angle
-
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
-
- ABx = bx - ax
- ABy = by - ay
- ABz = bz - az
-
- ACx = cx - ax
- ACy = cy - ay
- ACz = cz - az
-
- Dx = (ABy * ACz) - (ABz * ACy)
- Dy = -((ABx * ACz) - (ABz * ACx))
- Dz = (ABx * ACy) - (ABy * ACx)
-
- s = 0.5*(a + b + c)
-! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
-
- if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
- else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
- end if
-
- end function sphere_angle
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION PLANE_ANGLE
- !
- ! Computes the angle between vectors AB and AC, given points A, B, and C, and
- ! a vector (u,v,w) normal to the plane.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
-
- real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
- real (kind=RKIND) :: mAB ! The magnitude of AB
- real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
- real (kind=RKIND) :: mAC ! The magnitude of AC
-
- real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
- real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
- real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
-
- real (kind=RKIND) :: cos_angle
-
- ABx = bx - ax
- ABy = by - ay
- ABz = bz - az
- mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
-
- ACx = cx - ax
- ACy = cy - ay
- ACz = cz - az
- mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
-
-
- Dx = (ABy * ACz) - (ABz * ACy)
- Dy = -((ABx * ACz) - (ABz * ACx))
- Dz = (ABx * ACy) - (ABy * ACx)
-
- cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
-
- if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
- else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
- end if
-
- end function plane_angle
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! FUNCTION ARC_LENGTH
- !
- ! Returns the length of the great circle arc from A=(ax, ay, az) to
- ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
- ! same sphere centered at the origin.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
-
- real (kind=RKIND) :: r, c
- real (kind=RKIND) :: cx, cy, cz
-
- cx = bx - ax
- cy = by - ay
- cz = bz - az
-
-! r = ax*ax + ay*ay + az*az
-! c = cx*cx + cy*cy + cz*cz
-!
-! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
-
- r = sqrt(ax*ax + ay*ay + az*az)
- c = sqrt(cx*cx + cy*cy + cz*cz)
-! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
- arc_length = r * 2.0 * asin(c/(2.0*r))
-
- end function arc_length
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! SUBROUTINE ARC_BISECT
- !
- ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
- ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
- ! surface of a sphere centered at the origin.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
-
- implicit none
-
- real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
- real (kind=RKIND), intent(out) :: cx, cy, cz
-
- real (kind=RKIND) :: r ! Radius of the sphere
- real (kind=RKIND) :: d
-
- r = sqrt(ax*ax + ay*ay + az*az)
-
- cx = 0.5*(ax + bx)
- cy = 0.5*(ay + by)
- cz = 0.5*(az + bz)
-
- if (cx == 0. .and. cy == 0. .and. cz == 0.) then
- write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
- else
- d = sqrt(cx*cx + cy*cy + cz*cz)
- cx = r * cx / d
- cy = r * cy / d
- cz = r * cz / d
- end if
-
- end subroutine arc_bisect
-
-
- subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
-
- implicit none
-
- integer, intent(in) :: m,n,ne
- real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
- real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
-
- ! local storage
-
- real (kind=RKIND), dimension(m,n) :: a
- real (kind=RKIND), dimension(n,m) :: b
- real (kind=RKIND), dimension(m,m) :: w,wt,h
- real (kind=RKIND), dimension(n,m) :: at, ath
- real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
- integer, dimension(n) :: indx
- integer :: i,j
-
- if ( (ne<n) .or. (ne<m) ) then
- write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
- stop
- end if
-
-! a(1:m,1:n) = a_in(1:n,1:m)
- a(1:m,1:n) = a_in(1:m,1:n)
- w(1:m,1:m) = weights_in(1:m,1:m)
- b_out(:,:) = 0.
-
- wt = transpose(w)
- h = matmul(wt,w)
- at = transpose(a)
- ath = matmul(at,h)
- atha = matmul(ath,a)
-
- ata = matmul(at,a)
-
-! if (m == n) then
-! call MIGS(a,n,b,indx)
-! else
-
- call MIGS(atha,n,atha_inv,indx)
-
- b = matmul(atha_inv,ath)
-
-! call MIGS(ata,n,ata_inv,indx)
-! b = matmul(ata_inv,at)
-! end if
- b_out(1:n,1:m) = b(1:n,1:m)
-
-! do i=1,n
-! write(6,*) ' i, indx ',i,indx(i)
-! end do
-!
-! write(6,*) ' '
-
- end subroutine poly_fit_2
-
-
-! Updated 10/24/2001.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! !
-! Please Note: !
-! !
-! (1) This computer program is written by Tao Pang in conjunction with !
-! his book, "An Introduction to Computational Physics," published !
-! by Cambridge University Press in 1997. !
-! !
-! (2) No warranties, express or implied, are made for this program. !
-! !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-SUBROUTine MIGS (A,N,X,INDX)
-!
-! Subroutine to invert matrix A(N,N) with the inverse stored
-! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
- REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
- REAL (kind=RKIND), DIMENSION (N,N) :: B
-!
- DO I = 1, N
- DO J = 1, N
- B(I,J) = 0.0
- END DO
- END DO
- DO I = 1, N
- B(I,I) = 1.0
- END DO
-!
- CALL ELGS (A,N,INDX)
-!
- DO I = 1, N-1
- DO J = I+1, N
- DO K = 1, N
- B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
- END DO
- END DO
- END DO
-!
- DO I = 1, N
- X(N,I) = B(INDX(N),I)/A(INDX(N),N)
- DO J = N-1, 1, -1
- X(J,I) = B(INDX(J),I)
- DO K = J+1, N
- X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
- END DO
- X(J,I) = X(J,I)/A(INDX(J),J)
- END DO
- END DO
-END SUBROUTine MIGS
-
-
-SUBROUTINE ELGS (A,N,INDX)
-!
-! Subroutine to perform the partial-pivoting Gaussian elimination.
-! A(N,N) is the original matrix in the input and transformed matrix
-! plus the pivoting element ratios below the diagonal in the output.
-! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
-!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K,ITMP
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND) :: C1,PI,PI1,PJ
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- REAL (kind=RKIND), DIMENSION (N) :: C
-!
-! Initialize the index
-!
- DO I = 1, N
- INDX(I) = I
- END DO
-!
-! Find the rescaling factors, one from each row
-!
- DO I = 1, N
- C1= 0.0
- DO J = 1, N
- C1 = AMAX1(C1,ABS(A(I,J)))
- END DO
- C(I) = C1
- END DO
-!
-! Search the pivoting (largest) element from each column
-!
- DO J = 1, N-1
- PI1 = 0.0
- DO I = J, N
- PI = ABS(A(INDX(I),J))/C(INDX(I))
- IF (PI.GT.PI1) THEN
- PI1 = PI
- K = I
- ENDIF
- END DO
-!
-! Interchange the rows via INDX(N) to record pivoting order
-!
- ITMP = INDX(J)
- INDX(J) = INDX(K)
- INDX(K) = ITMP
- DO I = J+1, N
- PJ = A(INDX(I),J)/A(INDX(J),J)
-!
-! Record pivoting ratios below the diagonal
-!
- A(INDX(I),J) = PJ
-!
-! Modify other elements accordingly
-!
- DO K = J+1, N
- A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
- END DO
- END DO
- END DO
-!
-END SUBROUTINE ELGS
-
-end module advection
Deleted: branches/source_renaming/src/core_hyd_atmos/module_mpas_core.F
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/module_mpas_core.F 2011-10-20 22:17:57 UTC (rev 1111)
+++ branches/source_renaming/src/core_hyd_atmos/module_mpas_core.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -1,301 +0,0 @@
-module mpas_core
-
- use mpas_framework
- use mpas_timekeeping
-
- type (io_output_object) :: restart_obj
- integer :: restart_frame
-
- integer :: current_outfile_frames
-
- type (MPAS_Clock_type) :: clock
-
- integer, parameter :: outputAlarmID = 1
- integer, parameter :: restartAlarmID = 2
-
- contains
-
-
- subroutine mpas_core_init(domain, startTimeStamp)
-
- use mpas_configure
- use mpas_grid_types
- use test_cases
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- character(len=*), intent(out) :: startTimeStamp
-
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block
-
-
- if (.not. config_do_restart) call setup_hyd_test_case(domain)
-
- !
- ! Initialize core
- !
- dt = config_dt
-
- call simulation_clock_init(domain, dt, startTimeStamp)
-
- block => domain % blocklist
- do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
- block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
- block => block % next
- end do
-
- restart_frame = 1
- current_outfile_frames = 0
-
- end subroutine mpas_core_init
-
-
- subroutine simulation_clock_init(domain, dt, startTimeStamp)
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(out) :: startTimeStamp
-
- type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
- type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
- integer :: ierr
-
- call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
- call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr)
-
- if (trim(config_run_duration) /= "none") then
- call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
- call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
-
- if (trim(config_stop_time) /= "none") then
- call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- if(startTime + runduration /= stopTime) then
- write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
- end if
- end if
- else if (trim(config_stop_time) /= "none") then
- call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
- call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
- else
- write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
- call mpas_dmpar_abort(domain % dminfo)
- end if
-
- ! set output alarm
- call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
- alarmStartTime = startTime + alarmTimeStep
- call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
-
- ! set restart alarm, if necessary
- if (trim(config_restart_interval) /= "none") then
- call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
- alarmStartTime = startTime + alarmTimeStep
- call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
- end if
-
- call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
-
- end subroutine simulation_clock_init
-
-
- subroutine mpas_init_block(block, mesh, dt)
-
- use mpas_grid_types
- use advection
- use time_integration
- use mpas_rbf_interpolation
- use mpas_vector_reconstruction
-
- implicit none
-
- type (block_type), intent(inout) :: block
- type (mesh_type), intent(inout) :: mesh
- real (kind=RKIND), intent(in) :: dt
-
-
- call compute_solver_constants(block % state % time_levs(1) % state, mesh)
- call compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
- call compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
- call initialize_advection_rk(mesh)
- call mpas_rbf_interp_initialize(mesh)
- call mpas_init_reconstruct(mesh)
- call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
- block % diag % uReconstructX % array, &
- block % diag % uReconstructY % array, &
- block % diag % uReconstructZ % array, &
- block % diag % uReconstructZonal % array, &
- block % diag % uReconstructMeridional % array &
- )
-
-
- end subroutine mpas_init_block
-
-
- subroutine mpas_core_run(domain, output_obj, output_frame)
-
- use mpas_grid_types
- use mpas_io_output
- use mpas_timer
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
- integer, intent(inout) :: output_frame
-
- integer :: ntimesteps, itimestep
- real (kind=RKIND) :: dt
- type (block_type), pointer :: block_ptr
-
- type (MPAS_Time_Type) :: currTime
- character(len=32) :: timeStamp
- integer :: ierr
-
- ! Eventually, dt should be domain specific
- dt = config_dt
-
- currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
- call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
- write(0,*) 'Initial time ', timeStamp
-
- call write_output_frame(output_obj, output_frame, domain)
-
- ! During integration, time level 1 stores the model state at the beginning of the
- ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
- do while (.not. mpas_is_clock_stop_time(clock))
-
- call mpas_advance_clock(clock)
-
- currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
- call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
- write(0,*) 'Doing timestep ', timeStamp
-
- call mpas_timer_start("time integration")
- call mpas_timestep(domain, dt, timeStamp)
- call mpas_timer_stop("time integration")
-
- ! Move time level 2 fields back into time level 1 for next time step
- call mpas_shift_time_levels_state(domain % blocklist % state)
-
- if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=ierr)) then
- call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=ierr)
- if(output_frame == 1) call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
- call write_output_frame(output_obj, output_frame, domain)
- end if
-
- if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
- call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr)
- if (restart_frame == 1) call mpas_output_state_init(restart_obj, domain, "RESTART")
- call mpas_output_state_for_domain(restart_obj, domain, restart_frame)
- restart_frame = restart_frame + 1
- end if
-
- end do
-
- end subroutine mpas_core_run
-
-
- subroutine write_output_frame(output_obj, output_frame, domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain and write model state to output file
- !
- ! Input/Output: domain - contains model state; diagnostic field are computed
- ! before returning
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use mpas_grid_types
- use mpas_io_output
-
- implicit none
-
- integer, intent(inout) :: output_frame
- type (domain_type), intent(inout) :: domain
- type (io_output_object), intent(inout) :: output_obj
-
- integer :: i, j, k
- integer :: eoe
- type (block_type), pointer :: block_ptr
-
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
- block_ptr => block_ptr % next
- end do
-
- call mpas_output_state_for_domain(output_obj, domain, output_frame)
- output_frame = output_frame + 1
-
- ! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
- if (config_frames_per_outfile > 0) then
- current_outfile_frames = current_outfile_frames + 1
- if(current_outfile_frames >= config_frames_per_outfile) then
- current_outfile_frames = 0
- call mpas_output_state_finalize(output_obj, domain % dminfo)
- output_frame = 1
- end if
- end if
-
- end subroutine write_output_frame
-
-
- subroutine compute_output_diagnostics(state, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
- !
- ! Input: state - contains model prognostic fields
- ! grid - contains grid metadata
- !
- ! Output: state - upon returning, diagnostic fields will have be computed
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- use mpas_grid_types
-
- implicit none
-
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
-
- integer :: i, eoe
- integer :: iEdge, k
-
- end subroutine compute_output_diagnostics
-
-
- subroutine mpas_timestep(domain, dt, timeStamp)
-
- use mpas_grid_types
- use time_integration
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(in) :: timeStamp
-
- call timestep(domain, dt, timeStamp)
-
- end subroutine mpas_timestep
-
-
- subroutine mpas_core_finalize(domain)
-
- use mpas_grid_types
-
- implicit none
-
- integer :: ierr
-
- type (domain_type), intent(inout) :: domain
-
- if (restart_frame > 1) call mpas_output_state_finalize(restart_obj, domain % dminfo)
-
- call mpas_destroy_clock(clock, ierr)
-
- end subroutine mpas_core_finalize
-
-end module mpas_core
Deleted: branches/source_renaming/src/core_hyd_atmos/module_test_cases.F
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/module_test_cases.F 2011-10-20 22:17:57 UTC (rev 1111)
+++ branches/source_renaming/src/core_hyd_atmos/module_test_cases.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -1,544 +0,0 @@
-module test_cases
-
- use mpas_grid_types
- use mpas_configure
- use mpas_constants
-
-
- contains
-
-
- subroutine setup_hyd_test_case(domain)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Configure grid metadata and model state for the hydrostatic test case
- ! specified in the namelist
- !
- ! Output: block - a subset (not necessarily proper) of the model domain to be
- ! initialized
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
-
- integer :: i
- type (block_type), pointer :: block_ptr
-
- if (config_test_case == 0) then
- write(0,*) ' need hydrostatic test case configuration, error stop '
- stop
-
- else if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
- write(0,*) ' Jablonowski and Williamson baroclinic wave test case '
- if (config_test_case == 1) write(0,*) ' no initial perturbation '
- if (config_test_case == 2) write(0,*) ' initial perturbation included '
- if (config_test_case == 3) write(0,*) ' normal-mode perturbation included '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- call hyd_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state, config_test_case)
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
- write(0,*) ' Only test case 1 and 2 are currently supported for hydrostatic core '
- stop
- end if
-
- end subroutine setup_hyd_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine hyd_test_case_1(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (mesh_type), intent(inout) :: grid
- type (state_type), intent(inout) :: state
- integer, intent(in) :: test_case
-
- real (kind=RKIND), parameter :: u0 = 35.0
- real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
- real (kind=RKIND), parameter :: omega_e = 7.29212e-05
- real (kind=RKIND), parameter :: t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
- real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
- real (kind=RKIND), parameter :: theta_c = pii/4.0
- real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
- real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
-
- real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp, dbn, dnu, dnw
- real (kind=RKIND), dimension(:), pointer :: surface_pressure
- real (kind=RKIND), dimension(:,:), pointer :: pressure, theta, alpha, geopotential, h
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iEdge, vtx1, vtx2, ivtx, k, nz, nz1, index_qv
- real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
-
- real (kind=RKIND) :: ptop, p0, phi
- real (kind=RKIND) :: lon_Edge
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature
- real (kind=RKIND) :: ptmp, es, qvs
- integer :: iter
-
-! real (kind=RKIND), dimension(grid % nVertLevelsP1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
-! real (kind=RKIND), dimension(grid % nVertLevelsP1 ) :: znuc, znuv, bn, divh, dpn, teta, phi
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn, teta
-
- real (kind=RKIND) :: HYAI_CAM26(27), HYBI_CAM26(27), HYAM_CAM26(26), HYBM_CAM26(26)
-
- logical, parameter :: cam26 = .true.
-
- data hyai_cam26 / 0.002194067, 0.004895209, 0.009882418, 0.018052010, &
- 0.029837240, 0.044623340, 0.061605870, 0.078512430, &
- 0.077312710, 0.075901310, 0.074240860, 0.072287440, &
- 0.069989330, 0.067285740, 0.064105090, 0.060363220, &
- 0.055961110, 0.050782250, 0.044689600, 0.037521910, &
- 0.029089490, 0.020847390, 0.013344430, 0.007084990, &
- 0.002521360, 0.000000000, 0.000000000/, &
- hybi_cam26 / 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
- 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
- 0.015053090, 0.032762280, 0.053596220, 0.078106270, &
- 0.106941100, 0.140863700, 0.180772000, 0.227722000, &
- 0.282956200, 0.347936400, 0.424382200, 0.514316800, &
- 0.620120200, 0.723535500, 0.817676800, 0.896215300, &
- 0.953476103, 0.985112200, 1.000000000/
-
- !
- ! Scale all distances and areas from a unit sphere to one with radius a
- !
- grid % xCell % array = grid % xCell % array * a
- grid % yCell % array = grid % yCell % array * a
- grid % zCell % array = grid % zCell % array * a
- grid % xVertex % array = grid % xVertex % array * a
- grid % yVertex % array = grid % yVertex % array * a
- grid % zVertex % array = grid % zVertex % array * a
- grid % xEdge % array = grid % xEdge % array * a
- grid % yEdge % array = grid % yEdge % array * a
- grid % zEdge % array = grid % zEdge % array * a
- grid % dvEdge % array = grid % dvEdge % array * a
- grid % dcEdge % array = grid % dcEdge % array * a
- grid % areaCell % array = grid % areaCell % array * a**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
-
- index_qv = state % index_qv
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
-
- rdnu => grid % rdnu % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
- dbn => grid % dbn % array
- dnu => grid % dnu % array
- dnw => grid % dnw % array
-
- surface_pressure => state % surface_pressure % array
- pressure => state % pressure % array
- theta => state % theta % array
- alpha => state % alpha % array
- geopotential => state % geopotential % array
- h => state % h % array
- scalars => state % scalars % array
-
- scalars(:,:,:) = 0.
-
- p0 = 100000.
- bn (1) = 1.
- znw(1) = 1.
- znwc(1) = 1.
- !znwv(1) = (znwc(1)-.252)*pii/2.
- znwv(1) = ((znwc(1)-.252)*pii/2.*p0-ptop)/(p0-ptop)
-
- if (cam26) then
-
- if (grid % nVertLevels /= 26 ) then
- write(0,*) ' init is for 26 levels only, error stop '
- stop
- else
- do k=1,nz
- hyai(k) = hyai_cam26(k)
- hybi(k) = hybi_cam26(k)
- end do
-
- write(0,*) ' initialization using cam 26 levels '
-
- end if
-
- ptop = hyai(1)*p0
-
- do k=1,nz1
- hyam(k) = .5*(hyai(k)+hyai(k+1))
- hybm(k) = .5*(hybi(k)+hybi(k+1))
- znuc(nz-k) = hyam(k) + hybm(k)
- znwc(nz-k+1) = hyai(k) + hybi(k)
- znu (nz-k ) = (znuc(nz-k )*p0-ptop)/(p0-ptop)
- znw (nz-k+1) = (znwc(nz-k+1)*p0-ptop)/(p0-ptop)
-! znuv(nz-k ) = (znuc(nz-k )-.252)*pii/2.
-! znwv(nz-k+1) = (znwc(nz-k+1)-.252)*pii/2.
- bn(k+1) = hybi(nz-k)
- end do
-
- else ! analytic profile
-
- ptop = 219.4067
- znw(1) = 1.
-
- do k=1,nz1
-
- ! eta profile (constant deta for exp=1,)
-
- znw(k+1) = (1.-float(k)/float(nz1))**2.
-
- ! profile for tranisition from sigma to presure coordinate
- ! bn(k)=znw(k) for sigma coord, bn(k)=0 for p coord
- ! bn(1)=1, bn(nz)=0 must be satisfied
-
- bn(k+1) = znw(k+1)*sin(.5*pii*znw(k+1))**2
- !! bn(k+1) = znw(k+1)
-
- znu (k) = .5*(znw(k)+znw(k+1))
- znuc(k) = (znu(k )*(p0-ptop)+ptop)/p0
- znwc(k+1) = (znw(k+1)*(p0-ptop)+ptop)/p0
- end do
-
- end if ! cam or analytic grid-level profile
-
- !
- ! metrics for vertical stretching
- !
-
- do k=1,nz1
- !znuv(k ) = (znuc(k )-.252)*pii/2.
- !znwv(k+1) = (znwc(k+1)-.252)*pii/2.
- znuv(k ) = ((znuc(k )-.252)*pii/2.*p0-ptop)/(p0-ptop)
- znwv(k+1) = ((znwc(k+1)-.252)*pii/2.*p0-ptop)/(p0-ptop)
- dnw (k) = znw(k+1)-znw(k)
- rdnw(k) = 1./dnw(k)
- dbn (k) = rdnw(k)*(bn(k+1)-bn(k))
- dpn (k) = 0.
- divh(k) = 0.
- write (6,*) k,znw(k),dnw(k),bn(k),dbn(k)
- end do
-
- dpn(nz)=0.
- fnm(1) = 0.
- fnp(1) = 0.
- do k=2,nz1
- dnu (k) = .5*(dnw(k)+dnw(k-1))
- rdnu(k) = 1./dnu(k)
- fnp (k) = .5* dnw(k )/dnu(k)
- fnm (k) = .5* dnw(k-1)/dnu(k)
- end do
-
- !
- ! Initialize wind field
- !
-
- lat_pert = latitude_pert*pii/180.
- lon_pert = longitude_pert*pii/180.
-
- do iEdge=1,grid % nEdges
-
- vtx1 = grid % VerticesOnEdge % array (1,iEdge)
- vtx2 = grid % VerticesOnEdge % array (2,iEdge)
- lat1 = grid%latVertex%array(vtx1)
- lat2 = grid%latVertex%array(vtx2)
- flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
-
- if (config_test_case == 2) then
- r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
- lat_pert, lon_pert, 1.)/(pert_radius)
- u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
-
- else if (config_test_case == 3) then
- lon_Edge = grid % lonEdge % array(iEdge)
- u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
- *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
- else
- u_pert = 0.0
- end if
-
-
- do k=1,grid % nVertLevels
- fluxk = u0*flux*(cos(znuv(k))**(1.5))
- state % u % array(k,iEdge) = fluxk + u_pert
- end do
-
- !
- ! Generate rotated Coriolis field
- !
-
- grid % fEdge % array(iEdge) = 2.0 * omega * &
- ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
- sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
- )
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 2.0 * omega * &
- (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha_grid) + &
- sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
- )
- end do
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! To get hydrostatic balance with misture -- soln. 2.
-! original scheme by Jablonowski
-! T' = -1./R_d *(p/p_0) * d(phi')/d(eta)
-! = -1./R_d * eta * d(phi')/d(eta)
-! soln. 2 -> derive temperature profile from hydrostatic balance with moisture
-!
-! T_v = -1/(1+q_v)*(p/R_d)* d(eta)/d(p_d) * d(phi)/d(eta)
-! phi'(k) = phi(k+1) + d(eta)* alpha_pert * d(eta)/d(p_d)
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- do iCell=1,grid % nCells
-
- phi = grid % latCell % array (iCell)
-
- surface_pressure(iCell) = p0
-
- do k=1,nz1
- h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
- end do
-
- pressure(nz,iCell) = ptop
- do k=nz1,1,-1
- pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)
- end do
-
- do k=1,nz1
- ptmp = 0.5*(pressure(k,iCell)+pressure(k+1,iCell))
- if (znuc(k) >= eta_t) then
- teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity) + delta_t*(eta_t-ptmp/p0)**5
- end if
- theta (k,iCell) = teta(k)+.75*ptmp/h(k,iCell)*pii*u0/rgas*sin(znuv(k)) &
- *sqrt(cos(znuv(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(znuv(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
-
- theta (k,iCell) = theta(k,iCell)* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
- alpha(k,iCell) = ((rgas/p0)*theta(k,iCell)* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm)
-
- end do
- end do
-!
-! initialization for geopotential
-!
- do iCell=1,grid % nCells
-
- phi = grid % latCell % array (iCell)
-
- geopotential(1,iCell) = u0*cos(znwv(1))**1.5* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(znwv(1))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
- do k=1,nz1
- geopotential(k+1,iCell) = geopotential(k,iCell)-dnw(k)*h(k,iCell)*alpha(k,iCell)
- end do
- end do
-
- write(6,*) 'ptop_dry = ',ptop,' zt_dry = ',geopotential(nz,1)/gravity
-
- write(6,*) ' full sounding for dry'
- do k=1,nz1
- write(6,*) k, geopotential(k,1)/gravity, 0.01*pressure(k,1), theta(k,1), &
- theta(k,1)*(pressure(k,1)/p0)**(rgas/cp)
- end do
-
-!
-! initialization for moisture
-!
- if (config_mp_physics /= 0) then
-
- do iCell=1,grid % nCells
- do k=1,nz1
- ptmp = 0.5*(pressure(k,iCell) + pressure(k+1,iCell))
- if (ptmp < 50000.) then
- rel_hum(k,iCell) = 0.0
- else
- rel_hum(k,iCell) = (1.-((p0-ptmp)/50000.)**1.25)
- end if
- rel_hum(k,iCell) = min(rh_max,rel_hum(k,iCell))
- end do
- end do
- else
- rel_hum(:,:) = 0.
- end if
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! iteration
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- do iter=1,30
- do iCell=1,grid % nCells
-
- phi = grid % latCell % array (iCell)
- do k=1,nz1
- ptmp = 0.5*(pressure(k+1,iCell)+pressure(k,iCell))
-
- if(znuc(k) >= eta_t) then
- teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity) + delta_t*(eta_t-ptmp/p0)**5
- end if
-
- temperature (k,iCell) = teta(k)+.75*ptmp/h(k,iCell)*pii*u0/rgas*sin(znuv(k)) &
- *sqrt(cos(znuv(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(znuv(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
-
- temperature(k,iCell) = temperature(k,iCell)/(1.+0.61*scalars(index_qv,k,iCell))
-
- theta (k,iCell) = temperature(k,iCell)* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
- alpha (k,iCell) = (rgas/p0)*theta(k,iCell)*(1.+1.61*scalars(index_qv,k,iCell))* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
-
- if (temperature(k,iCell) > 273.15) then
- es = 1000.*0.6112*exp(17.67*(temperature(k,iCell)-273.15)/(temperature(k,iCell)-29.65))
- else
- es = 1000.*0.6112*exp(21.8745584*(temperature(k,iCell)-273.16)/(temperature(k,iCell)-7.66))
- end if
- qvs = (287.04/461.6)*es/(ptmp-es)
-! qvs = 380.*exp(17.27*(temperature(k,iCell)-273.)/(temperature(k,iCell)-36.))/ptmp
-
- scalars(index_qv,k,iCell) = rel_hum(k,iCell)*qvs
- end do
-
- do k=nz1,1,-1
- pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)*(1.+scalars(index_qv,k,iCell))
- geopotential(k,iCell) = geopotential(k+1,iCell)+dnw(k)*h(k,iCell)*alpha(k,iCell)
- end do
-
- end do
- end do
-
- write(6,*) 'ptop = ',ptop,' zt = ',geopotential(nz,1)/gravity
-
- write(6,*) ' full sounding with moisture'
- do k=1,nz1
- write(6,*) k, geopotential(k,1)/gravity, 0.01*pressure(k,1), theta(k,1), &
- theta(k,1)*(pressure(k,1)/p0)**(rgas/cp)
- end do
-
-! When initializing a scalar, be sure not to put unreasonably large values
-! into indices in the moist class
-! scalars(2,:,:) = 1. ! transport test
-! scalars(2,:,:) = theta ! transport test
-! if (num_scalars >= 2) then
-! scalars(2,:,:) = 0.0
-! do iCell=1,grid%nCells
-! r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
-! if (r < a/3.0) then
-! do k=1,grid%nVertLevels
-! scalars(2,k,iCell) = (1.0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
-! end do
-! end if
-! end do
-! end if
-! if (num_scalars >= 3) scalars(3,:,:) = theta + 100. ! transport test
-! if (num_scalars >= 4) scalars(4,:,:) = theta + 200. ! transport test
-! if (num_scalars >= 5) scalars(5,:,:) = theta + 300. ! transport test
-
- end subroutine hyd_test_case_1
-
-
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-
- real function AA(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! A, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- AA = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
- 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*(R*cos(theta))**2.0)
-
- end function AA
-
-
- real function BB(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! B, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- BB = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
-
- end function BB
-
-
- real function CC(theta)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! C, used in height field computation for Rossby-Haurwitz wave
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), parameter :: w = 7.848e-6
- real (kind=RKIND), parameter :: K = 7.848e-6
- real (kind=RKIND), parameter :: R = 4.0
-
- real (kind=RKIND), intent(in) :: theta
-
- CC = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
-
- end function CC
-
-end module test_cases
Deleted: branches/source_renaming/src/core_hyd_atmos/module_time_integration.F
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/module_time_integration.F 2011-10-20 22:17:57 UTC (rev 1111)
+++ branches/source_renaming/src/core_hyd_atmos/module_time_integration.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -1,2122 +0,0 @@
-module time_integration
-
- use mpas_grid_types
- use mpas_configure
- use mpas_constants
- use mpas_dmpar
- use mpas_vector_reconstruction
-
-
- contains
-
-
- subroutine timestep(domain, dt, timeStamp)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
- character(len=*), intent(in) :: timeStamp
-
- type (block_type), pointer :: block
-
- if (trim(config_time_integration) == 'SRK3') then
- call srk3(domain, dt)
- else
- write(0,*) 'Unknown time integration option '//trim(config_time_integration)
- write(0,*) 'Currently, only ''SRK3'' is supported.'
- stop
- end if
-
- block => domain % blocklist
- do while (associated(block))
- block % state % time_levs(2) % state % xtime % scalar = timeStamp
- block => block % next
- end do
-
- end subroutine timestep
-
-
- subroutine srk3(domain, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step using
- ! time-split RK3 scheme
- !
- ! Hydrostatic (primitive eqns.) solver
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (domain_type), intent(inout) :: domain
- real (kind=RKIND), intent(in) :: dt
-
- integer :: iCell, k
- type (block_type), pointer :: block
-
- integer, parameter :: TEND = 1
- integer :: rk_step, number_of_sub_steps
-
- real (kind=RKIND), dimension(3) :: rk_timestep, rk_sub_timestep
- integer, dimension(3) :: number_sub_steps
- integer :: small_step
- logical, parameter :: debug = .false.
- logical, parameter :: debug_mass_conservation = .true.
-
- real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
- real (kind=RKIND) :: global_domain_mass, global_scalar_mass, global_scalar_min, global_scalar_max
-
- !
- ! Initialize time_levs(2) with state at current time
- ! Initialize RK weights
- !
-
- number_of_sub_steps = config_number_of_sub_steps
-
- rk_timestep(1) = dt/3.
- rk_timestep(2) = dt/2.
- rk_timestep(3) = dt
-
- rk_sub_timestep(1) = dt/3.
- rk_sub_timestep(2) = dt/real(number_of_sub_steps)
- rk_sub_timestep(3) = dt/real(number_of_sub_steps)
-
- number_sub_steps(1) = 1
- number_sub_steps(2) = number_of_sub_steps/2
- number_sub_steps(3) = number_of_sub_steps
-
- if(debug) write(0,*) ' copy step in rk solver '
-
- block => domain % blocklist
- do while (associated(block))
- call mpas_copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
- block => block % next
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- do rk_step = 1, 3
-
- if(debug) write(0,*) ' rk substep ', rk_step
-
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % qtot % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % cqu % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
- block => block % next
- end do
-
- if(debug) write(0,*) ' rk substep ', rk_step
-
- block => domain % blocklist
- do while (associated(block))
- call compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
- if(debug) write(0,*) ' returned from dyn_tend '
-
- !
- ! --- update halos for tendencies
- !
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % theta % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
-
- ! --- advance over sub_steps
-
- block => domain % blocklist
- do while (associated(block))
- !
- ! Note: Scalars in new time level shouldn't be overwritten, since their provisional values
- ! from the previous RK step are needed to compute new scalar tendencies in advance_scalars.
- ! A cleaner way of preserving scalars should be added in future.
- !
- block % mesh % scalars_old % array(:,:,:) = block % state % time_levs(2) % state % scalars % array(:,:,:)
- call mpas_copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
- block % state % time_levs(2) % state % scalars % array(:,:,:) = block % mesh % scalars_old % array(:,:,:)
- block => block % next
- end do
-
- if(debug) write(0,*) ' returned from copy_state '
-
- do small_step = 1, number_sub_steps(rk_step)
-
- if(debug) write(0,*) ' small step ',small_step
-
- block => domain % blocklist
- do while (associated(block))
- call advance_dynamics( block % tend, block % state % time_levs(2) % state, &
- block % mesh, &
- small_step, number_sub_steps(rk_step), rk_sub_timestep(rk_step) )
- block => block % next
- end do
-
- if(debug) write(0,*) ' dynamics advance complete '
-
- ! will need communications here?
- !
- ! --- update halos for prognostic variables
- !
- block => domain % blocklist
- do while (associated(block))
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nEdges, &
-!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % uhAvg % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nEdges, &
-!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % wwAvg % array(:,:), &
-!! block % mesh % nVertLevels+1, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % theta % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
-!! block % mesh % nVertLevels, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % mesh % dpsdt % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % state % time_levs(2) % state % surface_pressure % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % ww % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % pressure_old % array(:,:), &
-!! block % mesh % nVertLevels+1, block % mesh % nCells, &
-!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
- block % mesh % nVertLevels+1, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
- end do
-
- if(debug) write(0,*) ' advance scalars '
-
-
- ! --- advance scalars with time integrated mass fluxes
-
- block => domain % blocklist
- do while (associated(block))
- !
- ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses
- ! the functionality of the advance_scalars routine; however, it is noticeably slower,
- ! so we keep the advance_scalars routine as well
- !
- if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then
- call advance_scalars( block % tend, &
- block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step) )
- else
- call advance_scalars_mono( block % tend, &
- block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step), rk_step, 3, &
- domain % dminfo, block % parinfo % cellsToSend, block % parinfo % cellsToRecv )
- end if
- block => block % next
- end do
-
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % scalars % array(:,:,:), &
- block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(2) % state % scalars % array(:,:,:), &
- block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
-
- if(debug) write(0,*) ' advance scalars complete '
-
- ! --- compute some diagnostic quantities for the next timestep
-
- block => domain % blocklist
- do while (associated(block))
- call compute_solver_constants( block % state % time_levs(2) % state, block % mesh )
- call compute_state_diagnostics( block % state % time_levs(2) % state, block % mesh )
- call compute_solve_diagnostics( dt, block % state % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
- if(debug) write(0,*) ' diagnostics complete '
-
-
- ! might need communications here *****************************
-
- end do
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! END RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- !
- ! Compute full velocity vectors at cell centers, and compute vertical velocity diagnostic
- !
- block => domain % blocklist
- do while (associated(block))
- call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
- block % diag % uReconstructX % array, &
- block % diag % uReconstructY % array, &
- block % diag % uReconstructZ % array, &
- block % diag % uReconstructZonal % array, &
- block % diag % uReconstructMeridional % array &
- )
-
- call compute_w(block % state % time_levs(2) % state, block % state % time_levs(1) % state, block % mesh, dt)
- block => block % next
- end do
-
- if(debug) write(0,*) ' rk step complete - mass diagnostics '
-
- if(debug .or. debug_mass_conservation) then
- domain_mass = 0.
- scalar_mass = 0.
- block => domain % blocklist
- scalar_min = block % state % time_levs(2) % state % scalars % array (2,1,1)
- scalar_max = block % state % time_levs(2) % state % scalars % array (2,1,1)
- do while(associated(block))
- do iCell = 1, block % mesh % nCellsSolve
- domain_mass = domain_mass + block % state % time_levs(2) % state % surface_pressure % array (iCell) * &
- block % mesh % areaCell % array (iCell) &
- - block % state % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
- block % mesh % areaCell % array (iCell)
- do k=1, block % mesh % nVertLevelsSolve
- scalar_mass = scalar_mass - block % state % time_levs(2) % state % scalars % array (2,k,iCell) * &
- block % state % time_levs(2) % state % h % array (k,iCell) * &
- block % mesh % dnw % array (k) * &
- block % mesh % areaCell % array (iCell)
- scalar_min = min(scalar_min,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
- scalar_max = max(scalar_max,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
- end do
- end do
- block => block % next
- end do
- call mpas_dmpar_sum_real(domain % dminfo, domain_mass, global_domain_mass)
- call mpas_dmpar_sum_real(domain % dminfo, scalar_mass, global_scalar_mass)
- call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min)
- call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max)
- write(0,*) ' mass in the domain = ',global_domain_mass
- write(0,*) ' scalar mass in the domain = ',global_scalar_mass
- write(0,*) ' scalar_min, scalar_max ',global_scalar_min, global_scalar_max
- end if
-
-
- end subroutine srk3
-
-!------------------------------------------------------------------------------------------------------------------
-
- subroutine compute_solver_constants(s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (state_type), intent(in) :: s
- type (mesh_type), intent(inout) :: grid
-
- integer :: iEdge, iCell, k, cell1, cell2, iq
-
- integer :: nCells, nEdges, nVertLevels
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
-
- grid % qtot % array = 0.
- grid % cqu % array = 1.
-
- if (s % num_scalars > 0) then
-
- do iCell = 1, nCells
- do k = 1, nVertLevels
- do iq = s % moist_start, s % moist_end
- grid % qtot % array(k,iCell) = grid % qtot % array(k,iCell) + s % scalars % array (iq, k, iCell)
- end do
- end do
- end do
-
- do iEdge = 1, nEdges
- do k = 1, nVertLevels
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- grid % cqu % array(k,iEdge) = 1./( 1. + 0.5*(grid % qtot % array(k,cell1)+grid % qtot % array(k,cell2)) )
- end do
- end do
-
- end if
-
- end subroutine compute_solver_constants
-
-!------------------------------------------------------------------------------------------------------------------
-
- subroutine compute_state_diagnostics(s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(inout) :: grid
-
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar
- real (kind=RKIND), dimension(:,:), pointer :: h, pressure, qtot, alpha, geopotential, theta
- real (kind=RKIND), dimension(:,:), pointer :: theta_old, ww_old, u_old, u, ww, h_edge_old, h_edge, h_old
- real (kind=RKIND), dimension(:), pointer :: surface_pressure, dbn, dnu, dnw
-
- integer :: iEdge, iCell, k, cell1, cell2, iq
- integer :: nCells, nEdges, nVertLevels
-
- real (kind=RKIND) :: p0,tm,ptop,ptmp
-
- h => s % h % array
- theta => s % theta % array
- pressure => s % pressure % array
- qtot => grid % qtot % array
- surface_pressure => s % surface_pressure % array
- alpha => s % alpha % array
- geopotential => s % geopotential % array
- scalar => s % scalars % array
- theta_old => grid % theta_old % array
- u_old => grid % u_old % array
- ww_old => grid % ww_old % array
- h_old => grid % h_old % array
- h_edge_old => grid % h_edge_old % array
- h_edge => s % h_edge % array
- u => s % u % array
- ww => s % ww % array
-
- dbn => grid % dbn % array
- dnu => grid % dnu % array
- dnw => grid % dnw % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
-
-
-
-! ptop = grid % ptop
-! p0 = grid % p0
-! ptop = 219.4067
- p0 = 1e+05
- ptop = pressure(nVertLevels+1,1)
-
-! write(0,*) ' ptop in compute_state_diagnostics ',ptop
-
-!*****************************
-
- do iCell = 1, nCells
- do k=1,nVertLevels
- h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
- end do
-
- do k = nVertLevels, 1, -1
- pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
- end do
-
- do k=1, nVertLevels
- ! note that theta is not coupled here
- tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell) ! assume scalar(1) is qv here?
- alpha(k,iCell) = (rgas/p0)*tm*(0.5*(pressure(k+1,iCell)+pressure(k,iCell))/p0)**cvpm
- geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
- end do
- end do
-
- theta_old(:,:) = theta(:,:)
- ww_old(:,:) = ww(:,:)
- u_old(:,:) = u(:,:)
- h_edge_old(:,:) = h_edge(:,:)
- h_old(:,:) = h(:,:)
-
- end subroutine compute_state_diagnostics
-
-!------------------------------------------------------------------------------------------
-
- subroutine compute_dyn_tend(tend, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (mesh_type), intent(in) :: grid
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
-
- integer :: nCells, nEdges, nVertices, nVertLevels
- real (kind=RKIND) :: h_mom_eddy_visc2, v_mom_eddy_visc2, h_mom_eddy_visc4
- real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, h_theta_eddy_visc4
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, p_s
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, divergence, vorticity, ke, pv_edge, geopotential, theta, ww, &
- h_diabatic, tend_theta
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
-
- real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: wdtn, wdun
- real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
-
- real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp
-
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
- h => s % h % array
- u => s % u % array
- h_edge => s % h_edge % array
- circulation => s % circulation % array
- divergence => s % divergence % array
- vorticity => s % vorticity % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- geopotential => s % geopotential % array
- theta => s % theta % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- fEdge => grid % fEdge % array
- deriv_two => grid % deriv_two % array
-
- vh => tend % vh % array
- tend_u => tend % u % array
- tend_theta => tend % theta % array
- h_diabatic => grid % h_diabatic % array
-
- ww => s % ww % array
- rdnu => grid % rdnu % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
- nVertices = grid % nVertices
-
- h_mom_eddy_visc2 = config_h_mom_eddy_visc2
- h_mom_eddy_visc4 = config_h_mom_eddy_visc4
- v_mom_eddy_visc2 = config_v_mom_eddy_visc2
- h_theta_eddy_visc2 = config_h_theta_eddy_visc2
- h_theta_eddy_visc4 = config_h_theta_eddy_visc4
- v_theta_eddy_visc2 = config_v_theta_eddy_visc2
-
-
- !
- ! Compute u (normal) velocity tendency for each edge (cell face)
- !
-
- tend_u(:,:) = 0.0
-
-#ifdef LANL_FORMULATION
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- q = 0.0
- do j = 1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
- q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
- end do
- tend_u(k,iEdge) = q - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
- end do
- end do
-
-#endif
-
-#ifdef NCAR_FORMULATION
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- vh(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- do j=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- do k=1,nVertLevels
- vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
- end do
- end do
- end do
-
- do iEdge=1,grid % nEdgesSolve
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
- (areaTriangle(vertex1) + areaTriangle(vertex2))
-
- workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
-
- tend_u(k,iEdge) = workpv * vh(k,iEdge) - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
- end do
- end do
-#endif
-
-
- !
- ! horizontal mixing for u
- !
- if ( h_mom_eddy_visc2 > 0.0 ) then
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- !
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="red">abla vorticity
- ! only valid for h_mom_eddy_visc2 == constant
- !
- u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
- u_diffusion = h_mom_eddy_visc2 * u_diffusion
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
- end do
- end do
- end if
-
- if ( h_mom_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_divergence(nVertLevels, nCells+1))
- allocate(delsq_u(nVertLevels, nEdges+1))
- allocate(delsq_circulation(nVertLevels, nVertices+1))
- allocate(delsq_vorticity(nVertLevels, nVertices+1))
-
- delsq_u(:,:) = 0.0
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- !
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="red">abla vorticity
- ! only valid for h_mom_eddy_visc4 == constant
- !
- u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
-
- delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
- end do
- end do
-
- delsq_circulation(:,:) = 0.0
- do iEdge=1,nEdges
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(1,iEdge)) = delsq_circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * delsq_u(k,iEdge)
- delsq_circulation(k,verticesOnEdge(2,iEdge)) = delsq_circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- r = 1.0 / areaTriangle(iVertex)
- do k=1,nVertLevels
- delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
- end do
- end do
-
- delsq_divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
- end do
- end do
-
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
-
- do k=1,nVertLevels
-
- !
- ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="gray">abla vorticity
- ! only valid for h_mom_eddy_visc4 == constant
- !
- u_diffusion = ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
- -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) - h_mom_eddy_visc4 * u_diffusion
- end do
- end do
-
- deallocate(delsq_divergence)
- deallocate(delsq_u)
- deallocate(delsq_circulation)
- deallocate(delsq_vorticity)
-
- end if
-
-
- !
- ! vertical advection for u
- !
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- wdun(1) = 0.
- do k=2,nVertLevels
- wdun(k) = &
- (ww(k,cell1)/(h(k,cell1)+h(k-1,cell1)) +ww(k,cell2)/(h(k,cell2)+h(k-1,cell2)))* &
- rdnu(k)*(u(k,iEdge)-u(k-1,iEdge))
- end do
- wdun(nVertLevels+1) = 0.
-
- do k=1,nVertLevels
- tend_u(k,iEdge) = tend_u(k,iEdge) - 0.5*(wdun(k+1)+wdun(k))
- end do
- end do
-
-
- !
- ! vertical mixing for u - 2nd order
- !
- if ( v_mom_eddy_visc2 > 0.0 ) then
-
- do iEdge=1,grid % nEdgesSolve
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=2,nVertLevels-1
-
- z1 = 0.5*(geopotential(k-1,cell1)+geopotential(k-1,cell2))/gravity
- z2 = 0.5*(geopotential(k ,cell1)+geopotential(k ,cell2))/gravity
- z3 = 0.5*(geopotential(k+1,cell1)+geopotential(k+1,cell2))/gravity
- z4 = 0.5*(geopotential(k+2,cell1)+geopotential(k+2,cell2))/gravity
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + v_mom_eddy_visc2*( &
- (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) &
- -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
-
-!----------- rhs for theta
-
- tend_theta(:,:) = 0.
-
-
- !
- ! horizontal mixing for theta - we could combine this with advection directly (i.e. as a turbulent flux),
- ! but here we can also code in hyperdiffusion if we wish (2nd order at present)
- !
- if ( h_theta_eddy_visc2 > 0.0 ) then
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
-
- do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * h_edge(k,iEdge) * theta_turb_flux
- tend_theta(k,cell1) = tend_theta(k,cell1) + flux
- tend_theta(k,cell2) = tend_theta(k,cell2) - flux
- end do
-
- end do
-
- end if
-
- if ( h_theta_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_theta(nVertLevels, nCells+1))
-
- delsq_theta(:,:) = 0.
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
-
- do k=1,grid % nVertLevels
- delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- end do
-
- end do
-
- do iCell = 1, nCells
- r = 1.0 / areaCell(iCell)
- do k=1,nVertLevels
- delsq_theta(k,iCell) = delsq_theta(k,iCell) * r
- end do
- end do
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
-
- do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc4*prandtl*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * theta_turb_flux
-
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
- end do
-
- end do
-
- deallocate(delsq_theta)
-
- end if
-
-
- !
- ! horizontal advection for theta
- !
-
- if (config_theta_adv_order == 2) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,grid % nVertLevels
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) )
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
- end do
- end do
-
- else if (config_theta_adv_order == 3) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,grid % nVertLevels
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
- end do
-
-! 3rd order stencil
- if( u(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
- else
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
- end if
-
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
-
- end do
- end do
-
- else if (config_theta_adv_order == 4) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,grid % nVertLevels
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- tend_theta(k,cell1) = tend_theta(k,cell1) - flux
- tend_theta(k,cell2) = tend_theta(k,cell2) + flux
- end do
-
- end do
- end if
-
-
- !
- ! vertical advection plus diabatic term
- ! Note: we are also dividing through by the cell area after the horizontal flux divergence
- !
- do iCell = 1, nCells
- wdtn(1) = 0.
- do k=2,nVertLevels
- wdtn(k) = ww(k,icell)*(fnm(k)*theta(k,iCell)+fnp(k)*theta(k-1,iCell))
- end do
- wdtn(nVertLevels+1) = 0.
- do k=1,nVertLevels
- tend_theta(k,iCell) = tend_theta(k,iCell)/areaCell(iCell) -rdnw(k)*(wdtn(k+1)-wdtn(k))
-!! tend_theta(k,iCell) = tend_theta(k) + h(k,iCell)*h_diabatic(k,iCell)
- end do
- end do
-
-
- !
- ! vertical mixing for theta - 2nd order
- !
- if ( v_theta_eddy_visc2 > 0.0 ) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = geopotential(k-1,iCell)/gravity
- z2 = geopotential(k ,iCell)/gravity
- z3 = geopotential(k+1,iCell)/gravity
- z4 = geopotential(k+2,iCell)/gravity
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl*h(k,iCell)*( &
- (theta(k+1,iCell)-theta(k ,iCell))/(zp-z0) &
- -(theta(k ,iCell)-theta(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
- end subroutine compute_dyn_tend
-
-!---------------------------------------------------------------------------------------------------------
-
- subroutine advance_dynamics(tend, s, grid, small_step, number_small_steps, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance the dry dynamics a small timestep (forward-backward integration)
- !
- ! Input: s - current model state
- ! tend - large-timestep tendency (d*/dt)
- ! grid - grid metadata
- ! dt - timestep
- !
- ! Output: s - model state advanced a timestep dt
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(in) :: tend
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
- real (kind=RKIND), intent(in) :: dt
- integer, intent(in) :: small_step, number_small_steps
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
-
- integer :: nEdges, nVertices, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, dpsdt, &
- surface_pressure
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, vorticity, ke, pv_edge, geopotential, alpha, theta, &
- pressure, pressure_old, tend_theta, uhAvg, wwAvg, ww, u_old, &
- theta_old, h_edge_old, qtot, ww_old, cqu, h_old
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar
-
-! real (kind=RKIND), pointer :: smext, p0, ptop
- real (kind=RKIND) :: smext, smdiv, p0, ptop
- real (kind=RKIND) :: tm, ptmp, he_old
-
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
-
- real (kind=RKIND), dimension( grid % nVertLevels + 1) :: wdtn
-
- real (kind=RKIND), dimension(:), pointer :: dnw, dbn, rdnw, dnu, fnm, fnp
- real (kind=RKIND) :: maxpdt,minpdt, maxww, minww
- integer :: maxpt,minpt
-
- h => s % h % array
- u => s % u % array
- h_edge => s % h_edge % array
- theta => s % theta % array
-
-! u_old => s_old % u % array
-! h_edge_old => s_old % h_edge % array
-! theta_old => s_old % theta % array
-! ww_old => s_old % ww % array
-! h_old => s_old % h % array
- u_old => grid % u_old % array
- h_edge_old => grid % h_edge_old % array
- theta_old => grid % theta_old % array
- ww_old => grid % ww_old % array
- h_old => grid % h_old % array
-
- geopotential => s % geopotential % array
- alpha => s % alpha % array
- surface_pressure => s % surface_pressure % array
- pressure => s % pressure % array
- pressure_old => grid % pressure_old % array
-
- cellsOnEdge => grid % cellsOnEdge % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- tend_h => tend % h % array
- tend_u => tend % u % array
- tend_theta => tend % theta % array
-
-
- uhAvg => grid % uhAvg % array
- wwAvg => grid % wwAvg % array
- dpsdt => grid % dpsdt % array
- qtot => grid % qtot % array
- cqu => grid % cqu % array
- ww => s % ww % array
- scalar => s % scalars % array
-
- dnw => grid % dnw % array
- dbn => grid % dbn % array
- dnu => grid % dnu % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
-
-! p0 => grid % p0
-! ptop => grid % ptop
-! smext => grid % smext
-
- nVertLevels = grid % nVertLevels
- nEdges = grid % nEdges
-
- p0 = 1.e+05
- ptop = pressure(nVertLevels+1,1)
- smext = 0.1
- smdiv = 0.1
-
-! write(0,*) ' ptop in advance_dynamics ',ptop
-
-!--- begin computations
-
-! we assume that the pressure, alpha, geopotential are already properly set
-! in first small step of a set, couple theta
-
- if(small_step == 1) then
-
- do iCell=1,grid % nCells
- do k=1,nVertLevels
- theta(k,iCell) = theta(k,iCell)*h(k,iCell)
- end do
- end do
-
- uhAvg = 0.
- wwAvg = 0.
- pressure_old(:,:) = pressure(:,:)
- dpsdt(:) = 0.
-
- end if
-
- !
- ! update horizontal momentum
- !
-
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- u(k,iEdge) = u(k,iEdge) + dt*tend_u(k,iEdge) &
- -(0.5*dt/dcEdge(iEdge))*( &
- (geopotential(k+1,cell2)-geopotential(k+1,cell1)) &
- +(geopotential(k ,cell2)-geopotential(k ,cell1)) &
- +cqu(k,iEdge)*(alpha(k,cell2)+alpha(k,cell1))* &
- 0.5*(pressure(k+1,cell2)-pressure(k+1,cell1) &
- +pressure(k ,cell2)-pressure(k ,cell1))) &
- -smext*dcEdge(iEdge)*(dpsdt(cell2)-dpsdt(cell1))/h_edge(k,iEdge)
- end do
- end do
-
- !
- ! calculate omega, update theta
- !
-
- tend_h = 0.
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- tend_h(k,cell1) = tend_h(k,cell1) + flux
- tend_h(k,cell2) = tend_h(k,cell2) - flux
- end do
- do k=1,nVertLevels
- uhAvg(k,iEdge) = uhAvg(k,iEdge) + u(k,iEdge) * h_edge(k,iEdge)
- end do
- end do
-
- do iCell=1, grid % nCells
- dpsdt(iCell) = 0.
- do k=1,nVertLevels
- dpsdt(iCell) = dpsdt(iCell) + dnw(k)*tend_h(k,iCell)
- end do
- dpsdt(iCell) = dpsdt(iCell)/areaCell(iCell)
-
- surface_pressure(iCell) = surface_pressure(iCell) + dt*dpsdt(iCell)
-
- do k=1,nVertLevels
- h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
- end do
-
- ! omega calculation
-
- ww(1,iCell) = 0.
- do k=2, nVertLevels
- ww(k,iCell) = ww(k-1,iCell)-dnw(k-1)*(dbn(k-1)*dpsdt(iCell)+tend_h(k-1,iCell)/areaCell(iCell))
- wwAvg(k,iCell) = wwAvg(k,iCell) + ww(k,iCell)
- end do
- ww(nVertLevels+1,iCell) = 0.
-
- ! theta update - theta should be coupled at this point...
-
- wdtn(1) = 0.
- do k = 2, nVertLevels
- wdtn(k) = (ww(k,iCell)-ww_old(k,iCell))*(fnm(k)*theta_old(k,iCell)+fnp(k)*theta_old(k-1,iCell))
- end do
- wdtn(nVertLevels+1) = 0.
-
- do k = 1, nVertLevels
- theta(k,iCell) = theta(k,iCell) + dt*tend_theta(k,iCell)
- theta(k,iCell) = theta(k,iCell) - dt*rdnw(k)*(wdtn(k+1)-wdtn(k))
- end do
- end do
-
- !
- ! add in perturbation horizontal flux divergence
- !
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5*(h(k,cell1)+h(k,cell2)) ! here is update of h_edge
- he_old = 0.5*(h_old(k,cell1)+h_old(k,cell2))
- flux = 0.5*(u(k,iEdge) * h_edge(k,iEdge) - u_old(k,iEdge) * he_old)* &
- (theta_old(k,cell1)+theta_old(k,cell2))*dvEdge(iEdge)
- theta(k,cell1) = theta(k,cell1) - dt*flux/areaCell(cell1)
- theta(k,cell2) = theta(k,cell2) + dt*flux/areaCell(cell2)
- end do
- end do
-
-
- ! compute some diagnostics using the new state
-
- do iCell = 1, grid % nCells
-
- do k = nVertLevels,1,-1
- pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
- end do
-
- do k=1, nVertLevels
- tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell)/h(k,iCell) ! assume scalar(1) is qv here?
- alpha(k,iCell) = (rgas/p0)*tm* &
- (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
- geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
- end do
-
- if(small_step /= number_small_steps) then
- do k=1, nVertLevels+1
- ptmp = pressure(k,iCell)
- pressure(k,iCell) = pressure(k,iCell) + smdiv*(pressure(k,iCell)-pressure_old(k,iCell))
- pressure_old(k,iCell) = ptmp
- end do
- end if
-
- end do
-
-! if last small step of a set, decouple theta
-
- if(small_step == number_small_steps) then
- do iCell=1,grid % nCells
- do k=1,nVertLevels
- theta(k,iCell) = theta(k,iCell)/h(k,iCell)
- end do
- end do
- uhAvg = uhAvg/real(number_small_steps)
- wwAvg = wwAvg/real(number_small_steps)
- end if
-
- end subroutine advance_dynamics
-
-
- subroutine advance_scalars( tend, s_old, s_new, grid, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed scalar tendencies
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(in) :: tend
- type (state_type), intent(in) :: s_old
- type (state_type), intent(inout) :: s_new
- type (mesh_type), intent(in) :: grid
- real (kind=RKIND) :: dt
-
- integer :: i, iCell, iEdge, k, iScalar, cell1, cell2, num_scalars
- real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
-
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
- integer, dimension(:,:), pointer :: cellsOnEdge
-
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn
- integer :: nVertLevels
-
- real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
- real (kind=RKIND) :: coef_3rd_order
-
- num_scalars = s_old % num_scalars
-
- coef_3rd_order = 0.
- if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
- if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
- scalar_old => s_old % scalars % array
- scalar_new => s_new % scalars % array
- deriv_two => grid % deriv_two % array
- uhAvg => grid % uhAvg % array
- dvEdge => grid % dvEdge % array
- dcEdge => grid % dcEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- scalar_tend => tend % scalars % array
- h_old => s_old % h % array
- h_new => s_new % h % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
- fnm => grid % fnm % array
- fnp => grid % fnp % array
- rdnw => grid % rdnw % array
-
- nVertLevels = grid % nVertLevels
-
- scalar_tend = 0. ! testing purposes - we have no sources or sinks
-
- !
- ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts form scalar_old
- !
- !
- ! horizontal flux divergence, accumulate in scalar_tend
-
- if (config_scalar_adv_order == 2) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,grid % nVertLevels
- do iScalar=1,num_scalars
- scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
- flux = uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
- scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
- scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
- end do
- end do
- end do
-
- else if (config_scalar_adv_order == 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,grid % nVertLevels
-
- do iScalar=1,num_scalars
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- if (uhAvg(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- else
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- end if
-
-! old version of the above code, with coef_3rd_order assumed to be 1.0
-! if (uhAvg(k,iEdge) > 0) then
-! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
-! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
-! -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
-! else
-! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
-! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
-! -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
-! end if
-
- scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
- scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
-
- end do
- end do
- end do
-
- else if (config_scalar_adv_order == 4) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,grid % nVertLevels
-
- do iScalar=1,num_scalars
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
- scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
- end do
- end do
-
- end do
- end if
-
-
- !
- ! vertical flux divergence
- !
-
- do iCell=1,grid % nCells
-
- wdtn(:,1) = 0.
- do k = 2, nVertLevels
- do iScalar=1,num_scalars
- wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
- end do
- end do
- wdtn(:,nVertLevels+1) = 0.
-
- do k=1,grid % nVertLevelsSolve
- do iScalar=1,num_scalars
- scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
- + dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
-
- end do
- end do
- end do
-
- end subroutine advance_scalars
-
-
- subroutine advance_scalars_mono( tend, s_old, s_new, grid, dt, rk_step, rk_order, dminfo, cellsToSend, cellsToRecv)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed scalar tendencies
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (tend_type), intent(in) :: tend
- type (state_type), intent(in) :: s_old
- type (state_type), intent(inout) :: s_new
- type (mesh_type), intent(in) :: grid
- integer, intent(in) :: rk_step, rk_order
- real (kind=RKIND), intent(in) :: dt
- type (dm_info), intent(in) :: dminfo
- type (exchange_list), pointer :: cellsToSend, cellsToRecv
-
- integer :: i, iCell, iEdge, k, iScalar, cell_upwind, cell1, cell2, num_scalars
- real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
- real (kind=RKIND) :: fdir, flux_upwind, h_flux_upwind, s_upwind
-
- real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
- integer, dimension(:,:), pointer :: cellsOnEdge
-
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nEdges+1) :: h_flux
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
- real (kind=RKIND), dimension( s_old % num_scalars ) :: s_max, s_min, s_max_update, s_min_update
-
- integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
-
- real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
- real (kind=RKIND), parameter :: eps=1.e-20
- real (kind=RKIND) :: coef_3rd_order
-
- num_scalars = s_old % num_scalars
-
- scalar_old => s_old % scalars % array
- scalar_new => s_new % scalars % array
- deriv_two => grid % deriv_two % array
- uhAvg => grid % uhAvg % array
- dvEdge => grid % dvEdge % array
- dcEdge => grid % dcEdge % array
- cellsOnEdge => grid % cellsOnEdge % array
- scalar_tend => tend % scalars % array
- h_old => s_old % h % array
- h_new => s_new % h % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
- fnm => grid % fnm % array
- fnp => grid % fnp % array
- rdnw => grid % rdnw % array
-
- nVertLevels = grid % nVertLevels
-
- scalar_tend = 0. ! testing purposes - we have no sources or sinks
-
- !
- ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old
- !
-
- km1 = 1
- km0 = 2
- v_flux(:,:,km1) = 0.
- v_flux_upwind(:,:,km1) = 0.
- scale_out(:,:,:) = 1.
- scale_in(:,:,:) = 1.
-
- coef_3rd_order = 0.
- if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
- if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
- do k = 1, grid % nVertLevels
- kcp1 = min(k+1,grid % nVertLevels)
- kcm1 = max(k-1,1)
-
-! vertical flux
-
- do iCell=1,grid % nCells
-
- if (k < grid % nVertLevels) then
- cell_upwind = k
- if (wwAvg(k+1,iCell) >= 0) cell_upwind = k+1
- do iScalar=1,num_scalars
- v_flux(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * &
- (fnm(k+1) * scalar_new(iScalar,k+1,iCell) + fnp(k+1) * scalar_new(iScalar,k,iCell))
- v_flux_upwind(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * scalar_old(iScalar,cell_upwind,iCell)
- v_flux(iScalar,iCell,km0) = v_flux(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km0)
-! v_flux(iScalar,iCell,km0) = 0. ! use only upwind - for testing
- s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
- - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
- end do
- else
- do iScalar=1,num_scalars
- v_flux(iScalar,iCell,km0) = 0.
- v_flux_upwind(iScalar,iCell,km0) = 0.
- s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
- - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
- end do
- end if
-
- end do
-
-! horizontal flux
-
- if (config_scalar_adv_order == 2) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- cell_upwind = cell2
- if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
- do iScalar=1,num_scalars
- scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
- h_flux(iScalar,iEdge) = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
- h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
- h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
-! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
- end do
- end do
-
- else if (config_scalar_adv_order >= 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- cell_upwind = cell2
- if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
- do iScalar=1,num_scalars
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
- end do
-
- if (uhAvg(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- else
- flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
- 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- end if
-
- h_flux(iScalar,iEdge) = dt * flux
- h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
- h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
-! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
- end do
- end do
-
- end if
-
-
- if ( (rk_step == rk_order) .and. (config_monotonic .or. config_positive_definite) ) then
-
-!*************************************************************************************************************
-!--- limiter - we limit horizontal and vertical fluxes on level k
-!--- (these are h fluxes contributing to level k scalars, and v flux contributing to level k, k-1 scalars)
-
- do iCell=1,grid % nCells
-
- do iScalar=1,num_scalars
-
- s_max(iScalar) = max(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
- s_min(iScalar) = min(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
- s_max_update(iScalar) = s_update(iScalar,iCell,km0)
- s_min_update(iScalar) = s_update(iScalar,iCell,km0)
-
- ! add in vertical flux to get max and min estimate
- s_max_update(iScalar) = s_max_update(iScalar) &
- - rdnw(k) * (max(0.,v_flux(iScalar,iCell,km0)) - min(0.,v_flux(iScalar,iCell,km1)))
- s_min_update(iScalar) = s_min_update(iScalar) &
- - rdnw(k) * (min(0.,v_flux(iScalar,iCell,km0)) - max(0.,v_flux(iScalar,iCell,km1)))
-
- end do
-
- do i = 1, grid % nEdgesOnCell % array(iCell) ! go around the edges of each cell
- do iScalar=1,num_scalars
-
- s_max(iScalar) = max(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_max(iScalar))
- s_min(iScalar) = min(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_min(iScalar))
-
- iEdge = grid % EdgesOnCell % array (i,iCell)
- if (iCell == cellsOnEdge(1,iEdge)) then
- fdir = 1.0
- else
- fdir = -1.0
- end if
- flux = -fdir * h_flux(iScalar,iEdge)/grid % areaCell % array(iCell)
- s_max_update(iScalar) = s_max_update(iScalar) + max(0.,flux)
- s_min_update(iScalar) = s_min_update(iScalar) + min(0.,flux)
-
- end do
-
- end do
-
- if( config_positive_definite ) s_min(:) = 0.
-
- do iScalar=1,num_scalars
- scale_out (iScalar,iCell,km0) = 1.
- scale_in (iScalar,iCell,km0) = 1.
- s_max_update (iScalar) = s_max_update (iScalar) / h_new (k,iCell)
- s_min_update (iScalar) = s_min_update (iScalar) / h_new (k,iCell)
- s_upwind = s_update(iScalar,iCell,km0) / h_new(k,iCell)
- if ( s_max_update(iScalar) > s_max(iScalar) .and. config_monotonic) &
- scale_in (iScalar,iCell,km0) = max(0.,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
- if ( s_min_update(iScalar) < s_min(iScalar) ) &
- scale_out (iScalar,iCell,km0) = max(0.,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
- end do
-
- end do ! end loop over cells to compute scale factor
-
-
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
-
- ! rescale the horizontal fluxes
-
- do iEdge = 1, grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- do iScalar=1,num_scalars
- flux = h_flux(iScalar,iEdge)
- if (flux > 0) then
- flux = flux * min(scale_out(iScalar,cell1,km0), scale_in(iScalar,cell2,km0))
- else
- flux = flux * min(scale_in(iScalar,cell1,km0), scale_out(iScalar,cell2,km0))
- end if
- h_flux(iScalar,iEdge) = flux
- end do
- end do
-
- ! rescale the vertical flux
-
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- flux = v_flux(iScalar,iCell,km1)
- if (flux > 0) then
- flux = flux * min(scale_out(iScalar,iCell,km0), scale_in(iScalar,iCell,km1))
- else
- flux = flux * min(scale_in(iScalar,iCell,km0), scale_out(iScalar,iCell,km1))
- end if
- v_flux(iScalar,iCell,km1) = flux
- end do
- end do
-
-! end of limiter
-!*******************************************************************************************************************
-
- end if
-
-!--- update
-
- do iCell=1,grid % nCells
- ! add in upper vertical flux that was just renormalized
- do iScalar=1,num_scalars
- s_update(iScalar,iCell,km0) = s_update(iScalar,iCell,km0) + rdnw(k) * v_flux(iScalar,iCell,km1)
- if (k > 1) s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) - rdnw(k-1)*v_flux(iScalar,iCell,km1)
- end do
- end do
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do iScalar=1,num_scalars
- s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - &
- h_flux(iScalar,iEdge) / grid % areaCell % array(cell1)
- s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + &
- h_flux(iScalar,iEdge) / grid % areaCell % array(cell2)
- end do
- end do
-
- ! decouple from mass
- if (k > 1) then
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) / h_new(k-1,iCell)
- end do
- end do
-
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- scalar_new(iScalar,k-1,iCell) = s_update(iScalar,iCell,km1)
- end do
- end do
- end if
-
- ktmp = km1
- km1 = km0
- km0 = ktmp
-
- end do
-
- do iCell=1,grid % nCells
- do iScalar=1,num_scalars
- scalar_new(iScalar,grid % nVertLevels,iCell) = s_update(iScalar,iCell,km1) / h_new(grid%nVertLevels,iCell)
- end do
- end do
-
- end subroutine advance_scalars_mono
-
-
- subroutine compute_solve_diagnostics(dt, s, grid)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields used in the tendency computations
- !
- ! Input: grid - grid metadata
- !
- ! Output: s - computed diagnostics
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: dt
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
-
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, r
-
- integer :: nCells, nEdges, nVertices, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
- real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
- circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, &
- divergence
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
-
-
- h => s % h % array
- u => s % u % array
- v => s % v % array
- vh => s % vh % array
- h_edge => s % h_edge % array
- tend_h => s % h % array
- tend_u => s % u % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- pv_vertex => s % pv_vertex % array
- pv_cell => s % pv_cell % array
- gradPVn => s % gradPVn % array
- gradPVt => s % gradPVt % array
-
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- !
- ! Compute height on cell edges at velocity locations
- !
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end do
-
- !
- ! Compute circulation and relative vorticity at each vertex
- !
- circulation(:,:) = 0.0
- do iEdge=1,nEdges
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- do k=1,nVertLevels
- vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
- end do
- end do
-
-
- !
- ! Compute the divergence at each cell center
- !
- divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
- divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
- end do
- end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- divergence(k,iCell) = divergence(k,iCell) * r
- end do
- end do
-
-
- !
- ! Compute kinetic energy in each cell
- !
- ke(:,:) = 0.0
- do iCell=1,nCells
- do i=1,nEdgesOnCell(iCell)
- iEdge = edgesOnCell(i,iCell)
- do k=1,nVertLevels
- ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
- end do
- end do
- do k=1,nVertLevels
- ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
- end do
- end do
-
- !
- ! Compute v (tangential) velocities
- !
- v(:,:) = 0.0
- do iEdge = 1,nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end do
- end do
-
-
- ! tdr
- !
- ! Compute height at vertices, pv at vertices, and average pv to edge locations
- ! ( this computes pv_vertex at all vertices bounding real cells )
- !
- do iVertex = 1,nVertices
- do k=1,nVertLevels
- h_vertex = 0.0
- do i=1,grid % vertexDegree
- h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
- end do
- h_vertex = h_vertex / areaTriangle(iVertex)
-
- pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
- end do
- end do
- ! tdr
-
-
- ! tdr
- !
- ! Compute gradient of PV in the tangent direction
- ! ( this computes gradPVt at all edges bounding real cells )
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
- dvEdge(iEdge)
- end do
- end do
-
- ! tdr
- !
- ! Compute pv at the edges
- ! ( this computes pv_edge at all edges bounding real cells )
- !
- pv_edge(:,:) = 0.0
- do iVertex = 1,nVertices
- do i=1,grid % vertexDegree
- iEdge = edgesOnVertex(i,iVertex)
- do k=1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- end do
- end do
- end do
- ! tdr
-
- ! tdr
- !
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
- end do
- end do
-
-
- ! tdr
- !
- ! Compute pv at cell centers
- ! ( this computes pv_cell for all real cells )
- !
- pv_cell(:,:) = 0.0
- do iVertex = 1, nVertices
- do i=1,grid % vertexDegree
- iCell = cellsOnVertex(i,iVertex)
- do k = 1,nVertLevels
- pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
- end do
- end do
- end do
- ! tdr
-
- ! tdr
- !
- ! Compute gradient of PV in normal direction
- ! (tdr: 2009-10-02: this is not correct because the pv_cell in the halo is not correct)
- !
- gradPVn(:,:) = 0.0
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
- dcEdge(iEdge)
- end do
- end do
- ! tdr
-
- ! Modify PV edge with upstream bias.
- !
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
- end do
- end do
-
-
- end subroutine compute_solve_diagnostics
-
-
- subroutine compute_w (s_new, s_old, grid, dt )
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute (diagnose) vertical velocity (used by physics)
- !
- ! Input: s_new - current model state
- ! s_old - previous model state
- ! grid - grid metadata
- ! dt - timestep between new and old
- !
- ! Output: w (m/s)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (state_type), intent(inout) :: s_new
- type (state_type), intent(in) :: s_old
- type (mesh_type), intent(inout) :: grid
-
- real (kind=RKIND), intent(in) :: dt
-
- real (kind=RKIND), dimension(:,:), pointer :: geo_new, geo_old, u, ww, h, w
- real (kind=RKIND), dimension(:), pointer :: dvEdge, rdnw, fnm, fnp
-
- integer :: iEdge, iCell, k, cell1, cell2
- real (kind=RKIND), dimension( grid % nVertlevels + 1 ) :: wdwn
- real (kind=RKIND) :: flux
-
- geo_new => s_new % geopotential % array
- geo_old => s_old % geopotential % array
- u => s_new % u % array
- ww => s_new % ww % array
- h => s_new % h % array
- w => s_new % w % array
- dvEdge => grid % dvEdge % array
- rdnw => grid % rdnw % array
- fnm => grid % fnm % array
- fnp => grid % fnp % array
-
- w = 0.
-
- do iCell=1, grid % nCellsSolve
- wdwn(1) = 0.
- do k=2,grid % nVertlevels + 1
- wdwn(k) = (0.5*(ww(k,iCell)+ww(k-1,iCell))/h(k-1,iCell)) &
- *rdnw(k-1)*(geo_new(k,iCell)-geo_new(k-1,iCell))
- enddo
- w(1,iCell) = 0.
- do k=2, grid % nVertLevels
- w(k,iCell) = (((geo_new(k,iCell)-geo_old(k,iCell))/dt)+ &
- fnm(k)*wdwn(k+1)+fnp(k)*wdwn(k))/gravity
- enddo
- k = grid % nVertLevels + 1
- w(k,iCell) = ((geo_new(k,iCell)-geo_old(k,iCell))/dt)/gravity
- enddo
-
- do iEdge=1, grid % nEdges
- cell1 = grid % cellsOnEdge % array (1,iEdge)
- cell2 = grid % cellsOnEdge % array (2,iEdge)
- if (cell1 <= grid % nCellsSolve .or. cell2 <= grid % nCellsSolve ) then
- do k=2, grid % nVertLevels
- flux = 0.25*(u(k,iEdge)+u(k-1,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
- w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
- w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
- enddo
- k = 1
- flux = 0.5*(1.5*u(1,iEdge)-0.5*u(2,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
- w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
- w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
-
- k = grid % nVertLevels + 1
- flux = 0.5*(1.5*u(k-1,iEdge)-0.5*u(k-2,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
- w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
- w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
-
- end if
- end do
-
- end subroutine compute_w
-
-end module time_integration
Copied: branches/source_renaming/src/core_hyd_atmos/mpas_atmh_advection.F (from rev 1111, branches/source_renaming/src/core_hyd_atmos/module_advection.F)
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/mpas_atmh_advection.F (rev 0)
+++ branches/source_renaming/src/core_hyd_atmos/mpas_atmh_advection.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -0,0 +1,688 @@
+module atmh_advection
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+
+
+ contains
+
+
+ subroutine atmh_initialize_advection_rk( grid )
+
+!
+! compute the cell coefficients for the polynomial fit.
+! this is performed during setup for model integration.
+! WCS, 31 August 2009
+!
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: advCells
+
+! local variables
+
+ real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
+ real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
+ real (kind=RKIND), dimension(grid % nCells) :: theta_abs
+
+ real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
+ real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
+ real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
+ real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
+ real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
+ integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
+ integer :: iCell, iEdge
+ real (kind=RKIND) :: pii
+ real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
+ real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
+ real (kind=RKIND) :: angv1, angv2, dl1, dl2
+ real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
+
+ real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
+ real (kind=RKIND) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+
+ integer :: cell1, cell2
+ integer, parameter :: polynomial_order = 2
+! logical, parameter :: debug = .true.
+ logical, parameter :: debug = .false.
+! logical, parameter :: least_squares = .false.
+ logical, parameter :: least_squares = .true.
+ logical :: add_the_cell, do_the_cell
+
+ logical, parameter :: reset_poly = .true.
+
+ real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
+
+!---
+
+ pii = 2.*asin(1.0)
+
+ advCells => grid % advCells % array
+ deriv_two => grid % deriv_two % array
+ deriv_two(:,:,:) = 0.
+
+ do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+ if ( polynomial_order > 2 ) then
+ do i=2,grid % nEdgesOnCell % array(iCell) + 1
+ do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
+ cell_add = grid % CellsOnCell % array (j,cell_list(i))
+ add_the_cell = .true.
+ do k=1,n
+ if ( cell_add == cell_list(k) ) add_the_cell = .false.
+ end do
+ if (add_the_cell) then
+ n = n+1
+ cell_list(n) = cell_add
+ end if
+ end do
+ end do
+ end if
+
+ advCells(1,iCell) = n
+
+! check to see if we are reaching outside the halo
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if ( .not. do_the_cell ) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if ( grid % on_a_sphere ) then
+
+ do i=1,n
+ advCells(i+1,iCell) = cell_list(i)
+ xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
+ yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
+ zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xc(ip2), yc(ip2), zc(ip2) )
+
+ dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+ thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ do i=1,n-1
+ xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
+ yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
+ end do
+
+ end if
+
+
+ ma = n-1
+ mw = grid % nEdgesOnCell % array (iCell)
+
+ bmatrix = 0.
+ amatrix = 0.
+ wmatrix = 0.
+
+ if (polynomial_order == 2) then
+ na = 6
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ wmatrix(i,i) = 1.
+ end do
+
+ else if (polynomial_order == 3) then
+ na = 10
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ else
+ na = 15
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ amatrix(i,11) = xp(i-1)**4
+ amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
+ amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
+ amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
+ amatrix(i,15) = yp(i-1)**4
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ do i=1,mw
+ wmatrix(i,i) = 1.
+ end do
+
+ end if
+
+ call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
+
+ do i=1,grid % nEdgesOnCell % array (iCell)
+ ip1 = i+1
+ if (ip1 > n-1) ip1 = 1
+
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+
+ if ( grid % on_a_sphere ) then
+ call arc_bisect( xv1, yv1, zv1, &
+ xv2, yv2, zv2, &
+ xec, yec, zec )
+
+ thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xec, yec, zec )
+ thetae_tmp = thetae_tmp + thetat(i)
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ else
+ thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ end if
+ else
+ xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
+ ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
+ end if
+
+ end do
+
+! fill second derivative stencil for rk advection
+
+ do i=1, grid % nEdgesOnCell % array (iCell)
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+
+
+ if ( grid % on_a_sphere ) then
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+
+ cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+
+ cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+ else
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
+ + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
+ + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
+ deriv_two(j,2,iEdge) = deriv_two(j,1,iEdge)
+ end do
+ end if
+ end do
+
+ end do ! end of loop over cells
+
+ if (debug) stop
+
+ end subroutine atmh_initialize_advection_rk
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION SPHERE_ANGLE
+ !
+ ! Computes the angle between arcs AB and AC, given points A, B, and C
+ ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
+
+ real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: s ! Semiperimeter of the triangle
+ real (kind=RKIND) :: sin_angle
+
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ s = 0.5*(a + b + c)
+! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+
+ if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ else
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ end if
+
+ end function sphere_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION PLANE_ANGLE
+ !
+ ! Computes the angle between vectors AB and AC, given points A, B, and C, and
+ ! a vector (u,v,w) normal to the plane.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: cos_angle
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+ mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+ mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
+
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
+
+ if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
+ plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ else
+ plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ end if
+
+ end function plane_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION ARC_LENGTH
+ !
+ ! Returns the length of the great circle arc from A=(ax, ay, az) to
+ ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
+ ! same sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function arc_length(ax, ay, az, bx, by, bz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+
+ real (kind=RKIND) :: r, c
+ real (kind=RKIND) :: cx, cy, cz
+
+ cx = bx - ax
+ cy = by - ay
+ cz = bz - az
+
+! r = ax*ax + ay*ay + az*az
+! c = cx*cx + cy*cy + cz*cz
+!
+! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+ c = sqrt(cx*cx + cy*cy + cz*cz)
+! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
+ arc_length = r * 2.0 * asin(c/(2.0*r))
+
+ end function arc_length
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! SUBROUTINE ARC_BISECT
+ !
+ ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
+ ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
+ ! surface of a sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+ real (kind=RKIND), intent(out) :: cx, cy, cz
+
+ real (kind=RKIND) :: r ! Radius of the sphere
+ real (kind=RKIND) :: d
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+
+ cx = 0.5*(ax + bx)
+ cy = 0.5*(ay + by)
+ cz = 0.5*(az + bz)
+
+ if (cx == 0. .and. cy == 0. .and. cz == 0.) then
+ write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
+ else
+ d = sqrt(cx*cx + cy*cy + cz*cz)
+ cx = r * cx / d
+ cy = r * cy / d
+ cz = r * cz / d
+ end if
+
+ end subroutine arc_bisect
+
+
+ subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
+
+ implicit none
+
+ integer, intent(in) :: m,n,ne
+ real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
+ real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
+
+ ! local storage
+
+ real (kind=RKIND), dimension(m,n) :: a
+ real (kind=RKIND), dimension(n,m) :: b
+ real (kind=RKIND), dimension(m,m) :: w,wt,h
+ real (kind=RKIND), dimension(n,m) :: at, ath
+ real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
+ integer, dimension(n) :: indx
+ integer :: i,j
+
+ if ( (ne<n) .or. (ne<m) ) then
+ write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
+ stop
+ end if
+
+! a(1:m,1:n) = a_in(1:n,1:m)
+ a(1:m,1:n) = a_in(1:m,1:n)
+ w(1:m,1:m) = weights_in(1:m,1:m)
+ b_out(:,:) = 0.
+
+ wt = transpose(w)
+ h = matmul(wt,w)
+ at = transpose(a)
+ ath = matmul(at,h)
+ atha = matmul(ath,a)
+
+ ata = matmul(at,a)
+
+! if (m == n) then
+! call MIGS(a,n,b,indx)
+! else
+
+ call MIGS(atha,n,atha_inv,indx)
+
+ b = matmul(atha_inv,ath)
+
+! call MIGS(ata,n,ata_inv,indx)
+! b = matmul(ata_inv,at)
+! end if
+ b_out(1:n,1:m) = b(1:n,1:m)
+
+! do i=1,n
+! write(6,*) ' i, indx ',i,indx(i)
+! end do
+!
+! write(6,*) ' '
+
+ end subroutine poly_fit_2
+
+
+! Updated 10/24/2001.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !
+! Please Note: !
+! !
+! (1) This computer program is written by Tao Pang in conjunction with !
+! his book, "An Introduction to Computational Physics," published !
+! by Cambridge University Press in 1997. !
+! !
+! (2) No warranties, express or implied, are made for this program. !
+! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+SUBROUTine MIGS (A,N,X,INDX)
+!
+! Subroutine to invert matrix A(N,N) with the inverse stored
+! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
+ REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
+ REAL (kind=RKIND), DIMENSION (N,N) :: B
+!
+ DO I = 1, N
+ DO J = 1, N
+ B(I,J) = 0.0
+ END DO
+ END DO
+ DO I = 1, N
+ B(I,I) = 1.0
+ END DO
+!
+ CALL ELGS (A,N,INDX)
+!
+ DO I = 1, N-1
+ DO J = I+1, N
+ DO K = 1, N
+ B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
+ END DO
+ END DO
+ END DO
+!
+ DO I = 1, N
+ X(N,I) = B(INDX(N),I)/A(INDX(N),N)
+ DO J = N-1, 1, -1
+ X(J,I) = B(INDX(J),I)
+ DO K = J+1, N
+ X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
+ END DO
+ X(J,I) = X(J,I)/A(INDX(J),J)
+ END DO
+ END DO
+END SUBROUTine MIGS
+
+
+SUBROUTINE ELGS (A,N,INDX)
+!
+! Subroutine to perform the partial-pivoting Gaussian elimination.
+! A(N,N) is the original matrix in the input and transformed matrix
+! plus the pivoting element ratios below the diagonal in the output.
+! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K,ITMP
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND) :: C1,PI,PI1,PJ
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
+ REAL (kind=RKIND), DIMENSION (N) :: C
+!
+! Initialize the index
+!
+ DO I = 1, N
+ INDX(I) = I
+ END DO
+!
+! Find the rescaling factors, one from each row
+!
+ DO I = 1, N
+ C1= 0.0
+ DO J = 1, N
+ C1 = AMAX1(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+!
+! Search the pivoting (largest) element from each column
+!
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+!
+! Interchange the rows via INDX(N) to record pivoting order
+!
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+!
+! Record pivoting ratios below the diagonal
+!
+ A(INDX(I),J) = PJ
+!
+! Modify other elements accordingly
+!
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+!
+END SUBROUTINE ELGS
+
+end module atmh_advection
Copied: branches/source_renaming/src/core_hyd_atmos/mpas_atmh_mpas_core.F (from rev 1111, branches/source_renaming/src/core_hyd_atmos/module_mpas_core.F)
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/mpas_atmh_mpas_core.F (rev 0)
+++ branches/source_renaming/src/core_hyd_atmos/mpas_atmh_mpas_core.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -0,0 +1,302 @@
+module mpas_core
+
+ use mpas_framework
+ use mpas_timekeeping
+
+ type (io_output_object) :: restart_obj
+ integer :: restart_frame
+
+ integer :: current_outfile_frames
+
+ type (MPAS_Clock_type) :: clock
+
+ integer, parameter :: outputAlarmID = 1
+ integer, parameter :: restartAlarmID = 2
+
+
+ contains
+
+
+ subroutine mpas_core_init(domain, startTimeStamp)
+
+ use mpas_configure
+ use mpas_grid_types
+ use atmh_test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ character(len=*), intent(out) :: startTimeStamp
+
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block
+
+
+ if (.not. config_do_restart) call atmh_setup_test_case(domain)
+
+ !
+ ! Initialize core
+ !
+ dt = config_dt
+
+ call atmh_simulation_clock_init(domain, dt, startTimeStamp)
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_init_block(block, block % mesh, dt)
+ block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
+ block => block % next
+ end do
+
+ restart_frame = 1
+ current_outfile_frames = 0
+
+ end subroutine mpas_core_init
+
+
+ subroutine mpas_core_run(domain, output_obj, output_frame)
+
+ use mpas_grid_types
+ use mpas_io_output
+ use mpas_timer
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+ integer, intent(inout) :: output_frame
+
+ integer :: ntimesteps, itimestep
+ real (kind=RKIND) :: dt
+ type (block_type), pointer :: block_ptr
+
+ type (MPAS_Time_Type) :: currTime
+ character(len=32) :: timeStamp
+ integer :: ierr
+
+ ! Eventually, dt should be domain specific
+ dt = config_dt
+
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ write(0,*) 'Initial time ', timeStamp
+
+ call atmh_write_output_frame(output_obj, output_frame, domain)
+
+ ! During integration, time level 1 stores the model state at the beginning of the
+ ! time step, and time level 2 stores the state advanced dt in time by timestep(...)
+ do while (.not. mpas_is_clock_stop_time(clock))
+
+ call mpas_advance_clock(clock)
+
+ currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr)
+ call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
+ write(0,*) 'Doing timestep ', timeStamp
+
+ call mpas_timer_start("time integration")
+ call atmh_do_timestep(domain, dt, timeStamp)
+ call mpas_timer_stop("time integration")
+
+ ! Move time level 2 fields back into time level 1 for next time step
+ call mpas_shift_time_levels_state(domain % blocklist % state)
+
+ if (mpas_is_alarm_ringing(clock, outputAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, outputAlarmID, ierr=ierr)
+ if(output_frame == 1) call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp)) ! output_frame will always be > 1 here unless it is reset after the output file is finalized
+ call atmh_write_output_frame(output_obj, output_frame, domain)
+ end if
+
+ if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr)
+ if (restart_frame == 1) call mpas_output_state_init(restart_obj, domain, "RESTART")
+ call mpas_output_state_for_domain(restart_obj, domain, restart_frame)
+ restart_frame = restart_frame + 1
+ end if
+
+ end do
+
+ end subroutine mpas_core_run
+
+
+ subroutine mpas_core_finalize(domain)
+
+ use mpas_grid_types
+
+ implicit none
+
+ integer :: ierr
+
+ type (domain_type), intent(inout) :: domain
+
+ if (restart_frame > 1) call mpas_output_state_finalize(restart_obj, domain % dminfo)
+
+ call mpas_destroy_clock(clock, ierr)
+
+ end subroutine mpas_core_finalize
+
+
+ subroutine atmh_simulation_clock_init(domain, dt, startTimeStamp)
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(out) :: startTimeStamp
+
+ type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime
+ type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep
+ integer :: ierr
+
+ call mpas_set_time(curr_time=startTime, dateTimeString=config_start_time, ierr=ierr)
+ call mpas_set_timeInterval(timeStep, dt=dt, ierr=ierr)
+
+ if (trim(config_run_duration) /= "none") then
+ call mpas_set_timeInterval(runDuration, timeString=config_run_duration, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, runDuration=runDuration, ierr=ierr)
+
+ if (trim(config_stop_time) /= "none") then
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ if(startTime + runduration /= stopTime) then
+ write(0,*) 'Warning: config_run_duration and config_stop_time are inconsitent: using config_run_duration.'
+ end if
+ end if
+ else if (trim(config_stop_time) /= "none") then
+ call mpas_set_time(curr_time=stopTime, dateTimeString=config_stop_time, ierr=ierr)
+ call mpas_create_clock(clock, startTime=startTime, timeStep=timeStep, stopTime=stopTime, ierr=ierr)
+ else
+ write(0,*) 'Error: Neither config_run_duration nor config_stop_time were specified.'
+ call mpas_dmpar_abort(domain % dminfo)
+ end if
+
+ ! set output alarm
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_output_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, outputAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+
+ ! set restart alarm, if necessary
+ if (trim(config_restart_interval) /= "none") then
+ call mpas_set_timeInterval(alarmTimeStep, timeString=config_restart_interval, ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock, restartAlarmID, alarmStartTime, alarmTimeStep, ierr=ierr)
+ end if
+
+ call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
+
+ end subroutine atmh_simulation_clock_init
+
+
+ subroutine atmh_init_block(block, mesh, dt)
+
+ use mpas_grid_types
+ use mpas_rbf_interpolation
+ use mpas_vector_reconstruction
+ use atmh_advection
+ use atmh_time_integration
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (mesh_type), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+
+ call atmh_compute_solver_constants(block % state % time_levs(1) % state, mesh)
+ call atmh_compute_state_diagnostics(block % state % time_levs(1) % state, mesh)
+ call atmh_compute_solve_diagnostics(dt, block % state % time_levs(1) % state, mesh)
+ call atmh_initialize_advection_rk(mesh)
+ call mpas_rbf_interp_initialize(mesh)
+ call mpas_init_reconstruct(mesh)
+ call mpas_reconstruct(mesh, block % state % time_levs(1) % state % u % array, &
+ block % diag % uReconstructX % array, &
+ block % diag % uReconstructY % array, &
+ block % diag % uReconstructZ % array, &
+ block % diag % uReconstructZonal % array, &
+ block % diag % uReconstructMeridional % array &
+ )
+
+
+ end subroutine atmh_init_block
+
+
+ subroutine atmh_write_output_frame(output_obj, output_frame, domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain and write model state to output file
+ !
+ ! Input/Output: domain - contains model state; diagnostic field are computed
+ ! before returning
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+ use mpas_io_output
+
+ implicit none
+
+ integer, intent(inout) :: output_frame
+ type (domain_type), intent(inout) :: domain
+ type (io_output_object), intent(inout) :: output_obj
+
+ integer :: i, j, k
+ integer :: eoe
+ type (block_type), pointer :: block_ptr
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call atmh_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
+ call mpas_output_state_for_domain(output_obj, domain, output_frame)
+ output_frame = output_frame + 1
+
+ ! if the maximum number of frames per outfile has been reached, finalize outfile and reset frame
+ if (config_frames_per_outfile > 0) then
+ current_outfile_frames = current_outfile_frames + 1
+ if(current_outfile_frames >= config_frames_per_outfile) then
+ current_outfile_frames = 0
+ call mpas_output_state_finalize(output_obj, domain % dminfo)
+ output_frame = 1
+ end if
+ end if
+
+ end subroutine atmh_write_output_frame
+
+
+ subroutine atmh_compute_output_diagnostics(state, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iEdge, k
+
+ end subroutine atmh_compute_output_diagnostics
+
+
+ subroutine atmh_do_timestep(domain, dt, timeStamp)
+
+ use mpas_grid_types
+ use atmh_time_integration
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(in) :: timeStamp
+
+ call atmh_timestep(domain, dt, timeStamp)
+
+ end subroutine atmh_do_timestep
+
+end module mpas_core
Copied: branches/source_renaming/src/core_hyd_atmos/mpas_atmh_test_cases.F (from rev 1111, branches/source_renaming/src/core_hyd_atmos/module_test_cases.F)
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/mpas_atmh_test_cases.F (rev 0)
+++ branches/source_renaming/src/core_hyd_atmos/mpas_atmh_test_cases.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -0,0 +1,544 @@
+module atmh_test_cases
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+
+
+ contains
+
+
+ subroutine atmh_setup_test_case(domain)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Configure grid metadata and model state for the hydrostatic test case
+ ! specified in the namelist
+ !
+ ! Output: block - a subset (not necessarily proper) of the model domain to be
+ ! initialized
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ integer :: i
+ type (block_type), pointer :: block_ptr
+
+ if (config_test_case == 0) then
+ write(0,*) ' need hydrostatic test case configuration, error stop '
+ stop
+
+ else if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
+ write(0,*) ' Jablonowski and Williamson baroclinic wave test case '
+ if (config_test_case == 1) write(0,*) ' no initial perturbation '
+ if (config_test_case == 2) write(0,*) ' initial perturbation included '
+ if (config_test_case == 3) write(0,*) ' normal-mode perturbation included '
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call atmh_test_case_1(block_ptr % mesh, block_ptr % state % time_levs(1) % state, config_test_case)
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+
+ block_ptr => block_ptr % next
+ end do
+
+ else
+ write(0,*) ' Only test case 1 and 2 are currently supported for hydrostatic core '
+ stop
+ end if
+
+ end subroutine atmh_setup_test_case
+
+!----------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_test_case_1(grid, state, test_case)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (mesh_type), intent(inout) :: grid
+ type (state_type), intent(inout) :: state
+ integer, intent(in) :: test_case
+
+ real (kind=RKIND), parameter :: u0 = 35.0
+ real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation
+ real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND), parameter :: t0 = 288., delta_t = 4.8e+05, dtdz = 0.005, eta_t = 0.2
+ real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
+ real (kind=RKIND), parameter :: theta_c = pii/4.0
+ real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
+ real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
+ real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
+
+ real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp, dbn, dnu, dnw
+ real (kind=RKIND), dimension(:), pointer :: surface_pressure
+ real (kind=RKIND), dimension(:,:), pointer :: pressure, theta, alpha, geopotential, h
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars
+
+ integer :: iCell, iEdge, vtx1, vtx2, ivtx, k, nz, nz1, index_qv
+ real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
+
+ real (kind=RKIND) :: ptop, p0, phi
+ real (kind=RKIND) :: lon_Edge
+
+ real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature
+ real (kind=RKIND) :: ptmp, es, qvs
+ integer :: iter
+
+! real (kind=RKIND), dimension(grid % nVertLevelsP1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
+! real (kind=RKIND), dimension(grid % nVertLevelsP1 ) :: znuc, znuv, bn, divh, dpn, teta, phi
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
+ real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn, teta
+
+ real (kind=RKIND) :: HYAI_CAM26(27), HYBI_CAM26(27), HYAM_CAM26(26), HYBM_CAM26(26)
+
+ logical, parameter :: cam26 = .true.
+
+ data hyai_cam26 / 0.002194067, 0.004895209, 0.009882418, 0.018052010, &
+ 0.029837240, 0.044623340, 0.061605870, 0.078512430, &
+ 0.077312710, 0.075901310, 0.074240860, 0.072287440, &
+ 0.069989330, 0.067285740, 0.064105090, 0.060363220, &
+ 0.055961110, 0.050782250, 0.044689600, 0.037521910, &
+ 0.029089490, 0.020847390, 0.013344430, 0.007084990, &
+ 0.002521360, 0.000000000, 0.000000000/, &
+ hybi_cam26 / 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.000000000, 0.000000000, 0.000000000, 0.000000000, &
+ 0.015053090, 0.032762280, 0.053596220, 0.078106270, &
+ 0.106941100, 0.140863700, 0.180772000, 0.227722000, &
+ 0.282956200, 0.347936400, 0.424382200, 0.514316800, &
+ 0.620120200, 0.723535500, 0.817676800, 0.896215300, &
+ 0.953476103, 0.985112200, 1.000000000/
+
+ !
+ ! Scale all distances and areas from a unit sphere to one with radius a
+ !
+ grid % xCell % array = grid % xCell % array * a
+ grid % yCell % array = grid % yCell % array * a
+ grid % zCell % array = grid % zCell % array * a
+ grid % xVertex % array = grid % xVertex % array * a
+ grid % yVertex % array = grid % yVertex % array * a
+ grid % zVertex % array = grid % zVertex % array * a
+ grid % xEdge % array = grid % xEdge % array * a
+ grid % yEdge % array = grid % yEdge % array * a
+ grid % zEdge % array = grid % zEdge % array * a
+ grid % dvEdge % array = grid % dvEdge % array * a
+ grid % dcEdge % array = grid % dcEdge % array * a
+ grid % areaCell % array = grid % areaCell % array * a**2.0
+ grid % areaTriangle % array = grid % areaTriangle % array * a**2.0
+ grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a**2.0
+
+ index_qv = state % index_qv
+
+ nz1 = grid % nVertLevels
+ nz = nz1 + 1
+
+ rdnu => grid % rdnu % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+ dbn => grid % dbn % array
+ dnu => grid % dnu % array
+ dnw => grid % dnw % array
+
+ surface_pressure => state % surface_pressure % array
+ pressure => state % pressure % array
+ theta => state % theta % array
+ alpha => state % alpha % array
+ geopotential => state % geopotential % array
+ h => state % h % array
+ scalars => state % scalars % array
+
+ scalars(:,:,:) = 0.
+
+ p0 = 100000.
+ bn (1) = 1.
+ znw(1) = 1.
+ znwc(1) = 1.
+ !znwv(1) = (znwc(1)-.252)*pii/2.
+ znwv(1) = ((znwc(1)-.252)*pii/2.*p0-ptop)/(p0-ptop)
+
+ if (cam26) then
+
+ if (grid % nVertLevels /= 26 ) then
+ write(0,*) ' init is for 26 levels only, error stop '
+ stop
+ else
+ do k=1,nz
+ hyai(k) = hyai_cam26(k)
+ hybi(k) = hybi_cam26(k)
+ end do
+
+ write(0,*) ' initialization using cam 26 levels '
+
+ end if
+
+ ptop = hyai(1)*p0
+
+ do k=1,nz1
+ hyam(k) = .5*(hyai(k)+hyai(k+1))
+ hybm(k) = .5*(hybi(k)+hybi(k+1))
+ znuc(nz-k) = hyam(k) + hybm(k)
+ znwc(nz-k+1) = hyai(k) + hybi(k)
+ znu (nz-k ) = (znuc(nz-k )*p0-ptop)/(p0-ptop)
+ znw (nz-k+1) = (znwc(nz-k+1)*p0-ptop)/(p0-ptop)
+! znuv(nz-k ) = (znuc(nz-k )-.252)*pii/2.
+! znwv(nz-k+1) = (znwc(nz-k+1)-.252)*pii/2.
+ bn(k+1) = hybi(nz-k)
+ end do
+
+ else ! analytic profile
+
+ ptop = 219.4067
+ znw(1) = 1.
+
+ do k=1,nz1
+
+ ! eta profile (constant deta for exp=1,)
+
+ znw(k+1) = (1.-float(k)/float(nz1))**2.
+
+ ! profile for tranisition from sigma to presure coordinate
+ ! bn(k)=znw(k) for sigma coord, bn(k)=0 for p coord
+ ! bn(1)=1, bn(nz)=0 must be satisfied
+
+ bn(k+1) = znw(k+1)*sin(.5*pii*znw(k+1))**2
+ !! bn(k+1) = znw(k+1)
+
+ znu (k) = .5*(znw(k)+znw(k+1))
+ znuc(k) = (znu(k )*(p0-ptop)+ptop)/p0
+ znwc(k+1) = (znw(k+1)*(p0-ptop)+ptop)/p0
+ end do
+
+ end if ! cam or analytic grid-level profile
+
+ !
+ ! metrics for vertical stretching
+ !
+
+ do k=1,nz1
+ !znuv(k ) = (znuc(k )-.252)*pii/2.
+ !znwv(k+1) = (znwc(k+1)-.252)*pii/2.
+ znuv(k ) = ((znuc(k )-.252)*pii/2.*p0-ptop)/(p0-ptop)
+ znwv(k+1) = ((znwc(k+1)-.252)*pii/2.*p0-ptop)/(p0-ptop)
+ dnw (k) = znw(k+1)-znw(k)
+ rdnw(k) = 1./dnw(k)
+ dbn (k) = rdnw(k)*(bn(k+1)-bn(k))
+ dpn (k) = 0.
+ divh(k) = 0.
+ write (6,*) k,znw(k),dnw(k),bn(k),dbn(k)
+ end do
+
+ dpn(nz)=0.
+ fnm(1) = 0.
+ fnp(1) = 0.
+ do k=2,nz1
+ dnu (k) = .5*(dnw(k)+dnw(k-1))
+ rdnu(k) = 1./dnu(k)
+ fnp (k) = .5* dnw(k )/dnu(k)
+ fnm (k) = .5* dnw(k-1)/dnu(k)
+ end do
+
+ !
+ ! Initialize wind field
+ !
+
+ lat_pert = latitude_pert*pii/180.
+ lon_pert = longitude_pert*pii/180.
+
+ do iEdge=1,grid % nEdges
+
+ vtx1 = grid % VerticesOnEdge % array (1,iEdge)
+ vtx2 = grid % VerticesOnEdge % array (2,iEdge)
+ lat1 = grid%latVertex%array(vtx1)
+ lat2 = grid%latVertex%array(vtx2)
+ flux = (0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+
+ if (config_test_case == 2) then
+ r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
+ lat_pert, lon_pert, 1.)/(pert_radius)
+ u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
+
+ else if (config_test_case == 3) then
+ lon_Edge = grid % lonEdge % array(iEdge)
+ u_pert = u_perturbation*cos(k_x*(lon_Edge - lon_pert)) &
+ *(0.5*(lat2-lat1) - 0.125*(sin(4.*lat2) - sin(4.*lat1)))*a/grid % dvEdge % array(iEdge)
+ else
+ u_pert = 0.0
+ end if
+
+
+ do k=1,grid % nVertLevels
+ fluxk = u0*flux*(cos(znuv(k))**(1.5))
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
+
+ !
+ ! Generate rotated Coriolis field
+ !
+
+ grid % fEdge % array(iEdge) = 2.0 * omega * &
+ ( -cos(grid%lonEdge%array(iEdge)) * cos(grid%latEdge%array(iEdge)) * sin(alpha_grid) + &
+ sin(grid%latEdge%array(iEdge)) * cos(alpha_grid) &
+ )
+ end do
+
+ do iVtx=1,grid % nVertices
+ grid % fVertex % array(iVtx) = 2.0 * omega * &
+ (-cos(grid%lonVertex%array(iVtx)) * cos(grid%latVertex%array(iVtx)) * sin(alpha_grid) + &
+ sin(grid%latVertex%array(iVtx)) * cos(alpha_grid) &
+ )
+ end do
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! To get hydrostatic balance with misture -- soln. 2.
+! original scheme by Jablonowski
+! T' = -1./R_d *(p/p_0) * d(phi')/d(eta)
+! = -1./R_d * eta * d(phi')/d(eta)
+! soln. 2 -> derive temperature profile from hydrostatic balance with moisture
+!
+! T_v = -1/(1+q_v)*(p/R_d)* d(eta)/d(p_d) * d(phi)/d(eta)
+! phi'(k) = phi(k+1) + d(eta)* alpha_pert * d(eta)/d(p_d)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ do iCell=1,grid % nCells
+
+ phi = grid % latCell % array (iCell)
+
+ surface_pressure(iCell) = p0
+
+ do k=1,nz1
+ h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
+ end do
+
+ pressure(nz,iCell) = ptop
+ do k=nz1,1,-1
+ pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)
+ end do
+
+ do k=1,nz1
+ ptmp = 0.5*(pressure(k,iCell)+pressure(k+1,iCell))
+ if (znuc(k) >= eta_t) then
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity)
+ else
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity) + delta_t*(eta_t-ptmp/p0)**5
+ end if
+ theta (k,iCell) = teta(k)+.75*ptmp/h(k,iCell)*pii*u0/rgas*sin(znuv(k)) &
+ *sqrt(cos(znuv(k)))* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *2.*u0*cos(znuv(k))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
+
+ theta (k,iCell) = theta(k,iCell)* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
+ alpha(k,iCell) = ((rgas/p0)*theta(k,iCell)* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm)
+
+ end do
+ end do
+!
+! initialization for geopotential
+!
+ do iCell=1,grid % nCells
+
+ phi = grid % latCell % array (iCell)
+
+ geopotential(1,iCell) = u0*cos(znwv(1))**1.5* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *(u0)*cos(znwv(1))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
+ do k=1,nz1
+ geopotential(k+1,iCell) = geopotential(k,iCell)-dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+ end do
+
+ write(6,*) 'ptop_dry = ',ptop,' zt_dry = ',geopotential(nz,1)/gravity
+
+ write(6,*) ' full sounding for dry'
+ do k=1,nz1
+ write(6,*) k, geopotential(k,1)/gravity, 0.01*pressure(k,1), theta(k,1), &
+ theta(k,1)*(pressure(k,1)/p0)**(rgas/cp)
+ end do
+
+!
+! initialization for moisture
+!
+ if (config_mp_physics /= 0) then
+
+ do iCell=1,grid % nCells
+ do k=1,nz1
+ ptmp = 0.5*(pressure(k,iCell) + pressure(k+1,iCell))
+ if (ptmp < 50000.) then
+ rel_hum(k,iCell) = 0.0
+ else
+ rel_hum(k,iCell) = (1.-((p0-ptmp)/50000.)**1.25)
+ end if
+ rel_hum(k,iCell) = min(rh_max,rel_hum(k,iCell))
+ end do
+ end do
+ else
+ rel_hum(:,:) = 0.
+ end if
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! iteration
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ do iter=1,30
+ do iCell=1,grid % nCells
+
+ phi = grid % latCell % array (iCell)
+ do k=1,nz1
+ ptmp = 0.5*(pressure(k+1,iCell)+pressure(k,iCell))
+
+ if(znuc(k) >= eta_t) then
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity)
+ else
+ teta(k) = t0*(ptmp/p0)**(rgas*dtdz/gravity) + delta_t*(eta_t-ptmp/p0)**5
+ end if
+
+ temperature (k,iCell) = teta(k)+.75*ptmp/h(k,iCell)*pii*u0/rgas*sin(znuv(k)) &
+ *sqrt(cos(znuv(k)))* &
+ ((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *2.*u0*cos(znuv(k))**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*a*omega)
+
+ temperature(k,iCell) = temperature(k,iCell)/(1.+0.61*scalars(index_qv,k,iCell))
+
+ theta (k,iCell) = temperature(k,iCell)* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**(-rgas/cp)
+ alpha (k,iCell) = (rgas/p0)*theta(k,iCell)*(1.+1.61*scalars(index_qv,k,iCell))* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
+
+ if (temperature(k,iCell) > 273.15) then
+ es = 1000.*0.6112*exp(17.67*(temperature(k,iCell)-273.15)/(temperature(k,iCell)-29.65))
+ else
+ es = 1000.*0.6112*exp(21.8745584*(temperature(k,iCell)-273.16)/(temperature(k,iCell)-7.66))
+ end if
+ qvs = (287.04/461.6)*es/(ptmp-es)
+! qvs = 380.*exp(17.27*(temperature(k,iCell)-273.)/(temperature(k,iCell)-36.))/ptmp
+
+ scalars(index_qv,k,iCell) = rel_hum(k,iCell)*qvs
+ end do
+
+ do k=nz1,1,-1
+ pressure(k,iCell) = pressure(k+1,iCell)-dnw(k)*h(k,iCell)*(1.+scalars(index_qv,k,iCell))
+ geopotential(k,iCell) = geopotential(k+1,iCell)+dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+
+ end do
+ end do
+
+ write(6,*) 'ptop = ',ptop,' zt = ',geopotential(nz,1)/gravity
+
+ write(6,*) ' full sounding with moisture'
+ do k=1,nz1
+ write(6,*) k, geopotential(k,1)/gravity, 0.01*pressure(k,1), theta(k,1), &
+ theta(k,1)*(pressure(k,1)/p0)**(rgas/cp)
+ end do
+
+! When initializing a scalar, be sure not to put unreasonably large values
+! into indices in the moist class
+! scalars(2,:,:) = 1. ! transport test
+! scalars(2,:,:) = theta ! transport test
+! if (num_scalars >= 2) then
+! scalars(2,:,:) = 0.0
+! do iCell=1,grid%nCells
+! r = sphere_distance(theta_c, lambda_c, grid % latCell % array(iCell), grid % lonCell % array(iCell), a)
+! if (r < a/3.0) then
+! do k=1,grid%nVertLevels
+! scalars(2,k,iCell) = (1.0 / 2.0) * (1.0 + cos(pii*r*3.0/a))
+! end do
+! end if
+! end do
+! end if
+! if (num_scalars >= 3) scalars(3,:,:) = theta + 100. ! transport test
+! if (num_scalars >= 4) scalars(4,:,:) = theta + 200. ! transport test
+! if (num_scalars >= 5) scalars(5,:,:) = theta + 300. ! transport test
+
+ end subroutine atmh_test_case_1
+
+
+ real function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
+ ! sphere with given radius.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
+
+ real (kind=RKIND) :: arg1
+
+ arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
+ cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
+ sphere_distance = 2.*radius*asin(arg1)
+
+ end function sphere_distance
+
+
+ real function AA(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! A, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ AA = 0.5 * w * (2.0 * omega + w) * cos(theta)**2.0 + &
+ 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 + 2.0*R**2.0 - R - 2.0 - 2.0*(R*cos(theta))**2.0)
+
+ end function AA
+
+
+ real function BB(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! B, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ BB = (2.0*(omega + w)*K / ((R+1.0)*(R+2.0))) * cos(theta)**R * ((R**2.0 + 2.0*R + 2.0) - ((R+1.0)*cos(theta))**2.0)
+
+ end function BB
+
+
+ real function CC(theta)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! C, used in height field computation for Rossby-Haurwitz wave
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), parameter :: w = 7.848e-6
+ real (kind=RKIND), parameter :: K = 7.848e-6
+ real (kind=RKIND), parameter :: R = 4.0
+
+ real (kind=RKIND), intent(in) :: theta
+
+ CC = 0.25 * K**2.0 * cos(theta)**(2.0*R) * ((R+1.0)*cos(theta)**2.0 - R - 2.0)
+
+ end function CC
+
+end module atmh_test_cases
Copied: branches/source_renaming/src/core_hyd_atmos/mpas_atmh_time_integration.F (from rev 1111, branches/source_renaming/src/core_hyd_atmos/module_time_integration.F)
===================================================================
--- branches/source_renaming/src/core_hyd_atmos/mpas_atmh_time_integration.F (rev 0)
+++ branches/source_renaming/src/core_hyd_atmos/mpas_atmh_time_integration.F 2011-10-21 17:41:56 UTC (rev 1112)
@@ -0,0 +1,2122 @@
+module atmh_time_integration
+
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_constants
+ use mpas_dmpar
+ use mpas_vector_reconstruction
+
+
+ contains
+
+
+ subroutine atmh_timestep(domain, dt, timeStamp)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+ character(len=*), intent(in) :: timeStamp
+
+ type (block_type), pointer :: block
+
+ if (trim(config_time_integration) == 'SRK3') then
+ call atmh_srk3(domain, dt)
+ else
+ write(0,*) 'Unknown time integration option '//trim(config_time_integration)
+ write(0,*) 'Currently, only ''SRK3'' is supported.'
+ stop
+ end if
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % state % time_levs(2) % state % xtime % scalar = timeStamp
+ block => block % next
+ end do
+
+ end subroutine atmh_timestep
+
+
+ subroutine atmh_srk3(domain, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step using
+ ! time-split RK3 scheme
+ !
+ ! Hydrostatic (primitive eqns.) solver
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ real (kind=RKIND), intent(in) :: dt
+
+ integer :: iCell, k
+ type (block_type), pointer :: block
+
+ integer, parameter :: TEND = 1
+ integer :: rk_step, number_of_sub_steps
+
+ real (kind=RKIND), dimension(3) :: rk_timestep, rk_sub_timestep
+ integer, dimension(3) :: number_sub_steps
+ integer :: small_step
+ logical, parameter :: debug = .false.
+ logical, parameter :: debug_mass_conservation = .true.
+
+ real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
+ real (kind=RKIND) :: global_domain_mass, global_scalar_mass, global_scalar_min, global_scalar_max
+
+ !
+ ! Initialize time_levs(2) with state at current time
+ ! Initialize RK weights
+ !
+
+ number_of_sub_steps = config_number_of_sub_steps
+
+ rk_timestep(1) = dt/3.
+ rk_timestep(2) = dt/2.
+ rk_timestep(3) = dt
+
+ rk_sub_timestep(1) = dt/3.
+ rk_sub_timestep(2) = dt/real(number_of_sub_steps)
+ rk_sub_timestep(3) = dt/real(number_of_sub_steps)
+
+ number_sub_steps(1) = 1
+ number_sub_steps(2) = number_of_sub_steps/2
+ number_sub_steps(3) = number_of_sub_steps
+
+ if(debug) write(0,*) ' copy step in rk solver '
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
+ block => block % next
+ end do
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! BEGIN RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+ do rk_step = 1, 3
+
+ if(debug) write(0,*) ' rk substep ', rk_step
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % qtot % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % cqu % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nVertices, &
+ block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
+ end if
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' rk substep ', rk_step
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_compute_dyn_tend( block % tend, block % state % time_levs(2) % state, block % mesh )
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' returned from dyn_tend '
+
+ !
+ ! --- update halos for tendencies
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % u % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % theta % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+
+ ! --- advance over sub_steps
+
+ block => domain % blocklist
+ do while (associated(block))
+ !
+ ! Note: Scalars in new time level shouldn't be overwritten, since their provisional values
+ ! from the previous RK step are needed to compute new scalar tendencies in advance_scalars.
+ ! A cleaner way of preserving scalars should be added in future.
+ !
+ block % mesh % scalars_old % array(:,:,:) = block % state % time_levs(2) % state % scalars % array(:,:,:)
+ call mpas_copy_state( block % state % time_levs(2) % state, block % state % time_levs(1) % state )
+ block % state % time_levs(2) % state % scalars % array(:,:,:) = block % mesh % scalars_old % array(:,:,:)
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' returned from copy_state '
+
+ do small_step = 1, number_sub_steps(rk_step)
+
+ if(debug) write(0,*) ' small step ',small_step
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_advance_dynamics( block % tend, block % state % time_levs(2) % state, &
+ block % mesh, &
+ small_step, number_sub_steps(rk_step), rk_sub_timestep(rk_step) )
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' dynamics advance complete '
+
+ ! will need communications here?
+ !
+ ! --- update halos for prognostic variables
+ !
+ block => domain % blocklist
+ do while (associated(block))
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % u % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nEdges, &
+!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % uhAvg % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nEdges, &
+!! block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % wwAvg % array(:,:), &
+!! block % mesh % nVertLevels+1, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % theta % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % h % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
+!! block % mesh % nVertLevels, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % mesh % dpsdt % array(:), &
+ block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % state % time_levs(2) % state % surface_pressure % array(:), &
+ block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % alpha % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % ww % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pressure % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+!! call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % mesh % pressure_old % array(:,:), &
+!! block % mesh % nVertLevels+1, block % mesh % nCells, &
+!! block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % geopotential % array(:,:), &
+ block % mesh % nVertLevels+1, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+ end do
+
+ if(debug) write(0,*) ' advance scalars '
+
+
+ ! --- advance scalars with time integrated mass fluxes
+
+ block => domain % blocklist
+ do while (associated(block))
+ !
+ ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses
+ ! the functionality of the advance_scalars routine; however, it is noticeably slower,
+ ! so we keep the advance_scalars routine as well
+ !
+ if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then
+ call atmh_advance_scalars( block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ block % mesh, rk_timestep(rk_step) )
+ else
+ call atmh_advance_scalars_mono( block % tend, &
+ block % state % time_levs(1) % state, block % state % time_levs(2) % state, &
+ block % mesh, rk_timestep(rk_step), rk_step, 3, &
+ domain % dminfo, block % parinfo % cellsToSend, block % parinfo % cellsToRecv )
+ end if
+ block => block % next
+ end do
+
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % scalars % array(:,:,:), &
+ block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(2) % state % scalars % array(:,:,:), &
+ block % tend % num_scalars, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+
+
+ if(debug) write(0,*) ' advance scalars complete '
+
+ ! --- compute some diagnostic quantities for the next timestep
+
+ block => domain % blocklist
+ do while (associated(block))
+ call atmh_compute_solver_constants( block % state % time_levs(2) % state, block % mesh )
+ call atmh_compute_state_diagnostics( block % state % time_levs(2) % state, block % mesh )
+ call atmh_compute_solve_diagnostics( dt, block % state % time_levs(2) % state, block % mesh )
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' diagnostics complete '
+
+
+ ! might need communications here *****************************
+
+ end do
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! END RK loop
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ !
+ ! Compute full velocity vectors at cell centers, and compute vertical velocity diagnostic
+ !
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
+ block % diag % uReconstructX % array, &
+ block % diag % uReconstructY % array, &
+ block % diag % uReconstructZ % array, &
+ block % diag % uReconstructZonal % array, &
+ block % diag % uReconstructMeridional % array &
+ )
+
+ call atmh_compute_w(block % state % time_levs(2) % state, block % state % time_levs(1) % state, block % mesh, dt)
+ block => block % next
+ end do
+
+ if(debug) write(0,*) ' rk step complete - mass diagnostics '
+
+ if(debug .or. debug_mass_conservation) then
+ domain_mass = 0.
+ scalar_mass = 0.
+ block => domain % blocklist
+ scalar_min = block % state % time_levs(2) % state % scalars % array (2,1,1)
+ scalar_max = block % state % time_levs(2) % state % scalars % array (2,1,1)
+ do while(associated(block))
+ do iCell = 1, block % mesh % nCellsSolve
+ domain_mass = domain_mass + block % state % time_levs(2) % state % surface_pressure % array (iCell) * &
+ block % mesh % areaCell % array (iCell) &
+ - block % state % time_levs(2) % state % pressure % array (block % mesh % nVertLevels + 1, 1) * &
+ block % mesh % areaCell % array (iCell)
+ do k=1, block % mesh % nVertLevelsSolve
+ scalar_mass = scalar_mass - block % state % time_levs(2) % state % scalars % array (2,k,iCell) * &
+ block % state % time_levs(2) % state % h % array (k,iCell) * &
+ block % mesh % dnw % array (k) * &
+ block % mesh % areaCell % array (iCell)
+ scalar_min = min(scalar_min,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
+ scalar_max = max(scalar_max,block % state % time_levs(2) % state % scalars % array (2,k,iCell))
+ end do
+ end do
+ block => block % next
+ end do
+ call mpas_dmpar_sum_real(domain % dminfo, domain_mass, global_domain_mass)
+ call mpas_dmpar_sum_real(domain % dminfo, scalar_mass, global_scalar_mass)
+ call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min)
+ call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max)
+ write(0,*) ' mass in the domain = ',global_domain_mass
+ write(0,*) ' scalar mass in the domain = ',global_scalar_mass
+ write(0,*) ' scalar_min, scalar_max ',global_scalar_min, global_scalar_max
+ end if
+
+
+ end subroutine atmh_srk3
+
+!------------------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_compute_solver_constants(s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute height and normal wind tendencies, as well as diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
+ ! circulation; vorticity; and kinetic energy, ke) and the
+ ! tendencies for height (h) and u (u)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(inout) :: grid
+
+ integer :: iEdge, iCell, k, cell1, cell2, iq
+
+ integer :: nCells, nEdges, nVertLevels
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+
+ grid % qtot % array = 0.
+ grid % cqu % array = 1.
+
+ if (s % num_scalars > 0) then
+
+ do iCell = 1, nCells
+ do k = 1, nVertLevels
+ do iq = s % moist_start, s % moist_end
+ grid % qtot % array(k,iCell) = grid % qtot % array(k,iCell) + s % scalars % array (iq, k, iCell)
+ end do
+ end do
+ end do
+
+ do iEdge = 1, nEdges
+ do k = 1, nVertLevels
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+ grid % cqu % array(k,iEdge) = 1./( 1. + 0.5*(grid % qtot % array(k,cell1)+grid % qtot % array(k,cell2)) )
+ end do
+ end do
+
+ end if
+
+ end subroutine atmh_compute_solver_constants
+
+!------------------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_compute_state_diagnostics(s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
+ ! circulation; vorticity; and kinetic energy, ke) and the
+ ! tendencies for height (h) and u (u)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(inout) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar
+ real (kind=RKIND), dimension(:,:), pointer :: h, pressure, qtot, alpha, geopotential, theta
+ real (kind=RKIND), dimension(:,:), pointer :: theta_old, ww_old, u_old, u, ww, h_edge_old, h_edge, h_old
+ real (kind=RKIND), dimension(:), pointer :: surface_pressure, dbn, dnu, dnw
+
+ integer :: iEdge, iCell, k, cell1, cell2, iq
+ integer :: nCells, nEdges, nVertLevels
+
+ real (kind=RKIND) :: p0,tm,ptop,ptmp
+
+ h => s % h % array
+ theta => s % theta % array
+ pressure => s % pressure % array
+ qtot => grid % qtot % array
+ surface_pressure => s % surface_pressure % array
+ alpha => s % alpha % array
+ geopotential => s % geopotential % array
+ scalar => s % scalars % array
+ theta_old => grid % theta_old % array
+ u_old => grid % u_old % array
+ ww_old => grid % ww_old % array
+ h_old => grid % h_old % array
+ h_edge_old => grid % h_edge_old % array
+ h_edge => s % h_edge % array
+ u => s % u % array
+ ww => s % ww % array
+
+ dbn => grid % dbn % array
+ dnu => grid % dnu % array
+ dnw => grid % dnw % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+
+
+
+! ptop = grid % ptop
+! p0 = grid % p0
+! ptop = 219.4067
+ p0 = 1e+05
+ ptop = pressure(nVertLevels+1,1)
+
+! write(0,*) ' ptop in compute_state_diagnostics ',ptop
+
+!*****************************
+
+ do iCell = 1, nCells
+ do k=1,nVertLevels
+ h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
+ end do
+
+ do k = nVertLevels, 1, -1
+ pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
+ end do
+
+ do k=1, nVertLevels
+ ! note that theta is not coupled here
+ tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell) ! assume scalar(1) is qv here?
+ alpha(k,iCell) = (rgas/p0)*tm*(0.5*(pressure(k+1,iCell)+pressure(k,iCell))/p0)**cvpm
+ geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+ end do
+
+ theta_old(:,:) = theta(:,:)
+ ww_old(:,:) = ww(:,:)
+ u_old(:,:) = u(:,:)
+ h_edge_old(:,:) = h_edge(:,:)
+ h_old(:,:) = h(:,:)
+
+ end subroutine atmh_compute_state_diagnostics
+
+!------------------------------------------------------------------------------------------
+
+ subroutine atmh_compute_dyn_tend(tend, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute height and normal wind tendencies, as well as diagnostic variables
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed diagnostics (parallel velocities, v; mass fluxes, vh;
+ ! circulation; vorticity; and kinetic energy, ke) and the
+ ! tendencies for height (h) and u (u)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(inout) :: tend
+ type (state_type), intent(in) :: s
+ type (mesh_type), intent(in) :: grid
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND) :: h_mom_eddy_visc2, v_mom_eddy_visc2, h_mom_eddy_visc4
+ real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, h_theta_eddy_visc4
+ real (kind=RKIND) :: u_diffusion
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, p_s
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, divergence, vorticity, ke, pv_edge, geopotential, theta, ww, &
+ h_diabatic, tend_theta
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+
+ real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: wdtn, wdun
+ real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
+
+ real (kind=RKIND), dimension(:), pointer :: rdnu, rdnw, fnm, fnp
+
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_theta, delsq_divergence
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
+ real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
+
+ h => s % h % array
+ u => s % u % array
+ h_edge => s % h_edge % array
+ circulation => s % circulation % array
+ divergence => s % divergence % array
+ vorticity => s % vorticity % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ geopotential => s % geopotential % array
+ theta => s % theta % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ fEdge => grid % fEdge % array
+ deriv_two => grid % deriv_two % array
+
+ vh => tend % vh % array
+ tend_u => tend % u % array
+ tend_theta => tend % theta % array
+ h_diabatic => grid % h_diabatic % array
+
+ ww => s % ww % array
+ rdnu => grid % rdnu % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+ nVertices = grid % nVertices
+
+ h_mom_eddy_visc2 = config_h_mom_eddy_visc2
+ h_mom_eddy_visc4 = config_h_mom_eddy_visc4
+ v_mom_eddy_visc2 = config_v_mom_eddy_visc2
+ h_theta_eddy_visc2 = config_h_theta_eddy_visc2
+ h_theta_eddy_visc4 = config_h_theta_eddy_visc4
+ v_theta_eddy_visc2 = config_v_theta_eddy_visc2
+
+
+ !
+ ! Compute u (normal) velocity tendency for each edge (cell face)
+ !
+
+ tend_u(:,:) = 0.0
+
+#ifdef LANL_FORMULATION
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ q = 0.0
+ do j = 1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
+ q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
+ end do
+ tend_u(k,iEdge) = q - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
+ end do
+ end do
+
+#endif
+
+#ifdef NCAR_FORMULATION
+ !
+ ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
+ !
+ vh(:,:) = 0.0
+ do iEdge=1,grid % nEdgesSolve
+ do j=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(j,iEdge)
+ do k=1,nVertLevels
+ vh(k,iEdge) = vh(k,iEdge) + weightsOnEdge(j,iEdge) * u(k,eoe) * h_edge(k,eoe)
+ end do
+ end do
+ end do
+
+ do iEdge=1,grid % nEdgesSolve
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+ vorticity_abs = fEdge(iEdge) + (circulation(k,vertex1) + circulation(k,vertex2)) / &
+ (areaTriangle(vertex1) + areaTriangle(vertex2))
+
+ workpv = 2.0 * vorticity_abs / (h(k,cell1) + h(k,cell2))
+
+ tend_u(k,iEdge) = workpv * vh(k,iEdge) - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)
+ end do
+ end do
+#endif
+
+
+ !
+ ! horizontal mixing for u
+ !
+ if ( h_mom_eddy_visc2 > 0.0 ) then
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc2 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = h_mom_eddy_visc2 * u_diffusion
+
+ tend_u(k,iEdge) = tend_u(k,iEdge) + u_diffusion
+ end do
+ end do
+ end if
+
+ if ( h_mom_eddy_visc4 > 0.0 ) then
+
+ allocate(delsq_divergence(nVertLevels, nCells+1))
+ allocate(delsq_u(nVertLevels, nEdges+1))
+ allocate(delsq_circulation(nVertLevels, nVertices+1))
+ allocate(delsq_vorticity(nVertLevels, nVertices+1))
+
+ delsq_u(:,:) = 0.0
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
+ end do
+ end do
+
+ delsq_circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ do k=1,nVertLevels
+ delsq_circulation(k,verticesOnEdge(1,iEdge)) = delsq_circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * delsq_u(k,iEdge)
+ delsq_circulation(k,verticesOnEdge(2,iEdge)) = delsq_circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * delsq_u(k,iEdge)
+ end do
+ end do
+ do iVertex=1,nVertices
+ r = 1.0 / areaTriangle(iVertex)
+ do k=1,nVertLevels
+ delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
+ end do
+ end do
+
+ delsq_divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
+ delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
+ end do
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
+ end do
+ end do
+
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ vertex1 = verticesOnEdge(1,iEdge)
+ vertex2 = verticesOnEdge(2,iEdge)
+
+ do k=1,nVertLevels
+
+ !
+ ! Compute diffusion, computed as </font>
<font color="black">abla divergence - k \times </font>
<font color="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( delsq_divergence(k,cell2) - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ tend_u(k,iEdge) = tend_u(k,iEdge) - h_mom_eddy_visc4 * u_diffusion
+ end do
+ end do
+
+ deallocate(delsq_divergence)
+ deallocate(delsq_u)
+ deallocate(delsq_circulation)
+ deallocate(delsq_vorticity)
+
+ end if
+
+
+ !
+ ! vertical advection for u
+ !
+ do iEdge=1,grid % nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ wdun(1) = 0.
+ do k=2,nVertLevels
+ wdun(k) = &
+ (ww(k,cell1)/(h(k,cell1)+h(k-1,cell1)) +ww(k,cell2)/(h(k,cell2)+h(k-1,cell2)))* &
+ rdnu(k)*(u(k,iEdge)-u(k-1,iEdge))
+ end do
+ wdun(nVertLevels+1) = 0.
+
+ do k=1,nVertLevels
+ tend_u(k,iEdge) = tend_u(k,iEdge) - 0.5*(wdun(k+1)+wdun(k))
+ end do
+ end do
+
+
+ !
+ ! vertical mixing for u - 2nd order
+ !
+ if ( v_mom_eddy_visc2 > 0.0 ) then
+
+ do iEdge=1,grid % nEdgesSolve
+
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=2,nVertLevels-1
+
+ z1 = 0.5*(geopotential(k-1,cell1)+geopotential(k-1,cell2))/gravity
+ z2 = 0.5*(geopotential(k ,cell1)+geopotential(k ,cell2))/gravity
+ z3 = 0.5*(geopotential(k+1,cell1)+geopotential(k+1,cell2))/gravity
+ z4 = 0.5*(geopotential(k+2,cell1)+geopotential(k+2,cell2))/gravity
+
+ zm = 0.5*(z1+z2)
+ z0 = 0.5*(z2+z3)
+ zp = 0.5*(z3+z4)
+
+ tend_u(k,iEdge) = tend_u(k,iEdge) + v_mom_eddy_visc2*( &
+ (u(k+1,iEdge)-u(k ,iEdge))/(zp-z0) &
+ -(u(k ,iEdge)-u(k-1,iEdge))/(z0-zm) )/(0.5*(zp-zm))
+ end do
+ end do
+
+ end if
+
+
+!----------- rhs for theta
+
+ tend_theta(:,:) = 0.
+
+
+ !
+ ! horizontal mixing for theta - we could combine this with advection directly (i.e. as a turbulent flux),
+ ! but here we can also code in hyperdiffusion if we wish (2nd order at present)
+ !
+ if ( h_theta_eddy_visc2 > 0.0 ) then
+
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+
+ do k=1,grid % nVertLevels
+ theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
+ flux = dvEdge (iEdge) * h_edge(k,iEdge) * theta_turb_flux
+ tend_theta(k,cell1) = tend_theta(k,cell1) + flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) - flux
+ end do
+
+ end do
+
+ end if
+
+ if ( h_theta_eddy_visc4 > 0.0 ) then
+
+ allocate(delsq_theta(nVertLevels, nCells+1))
+
+ delsq_theta(:,:) = 0.
+
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+
+ do k=1,grid % nVertLevels
+ delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
+ delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*h_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
+ end do
+
+ end do
+
+ do iCell = 1, nCells
+ r = 1.0 / areaCell(iCell)
+ do k=1,nVertLevels
+ delsq_theta(k,iCell) = delsq_theta(k,iCell) * r
+ end do
+ end do
+
+ do iEdge=1,grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+
+ do k=1,grid % nVertLevels
+ theta_turb_flux = h_theta_eddy_visc4*prandtl*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
+ flux = dvEdge (iEdge) * theta_turb_flux
+
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+ end do
+
+ end do
+
+ deallocate(delsq_theta)
+
+ end if
+
+
+ !
+ ! horizontal advection for theta
+ !
+
+ if (config_theta_adv_order == 2) then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,grid % nVertLevels
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) )
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+ end do
+ end do
+
+ else if (config_theta_adv_order == 3) then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+! 3rd order stencil
+ if( u(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
+ else
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
+ end if
+
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+
+ end do
+ end do
+
+ else if (config_theta_adv_order == 4) then
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,grid % nVertLevels
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * theta(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * theta(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * theta(k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ flux = dvEdge(iEdge) * h_edge(k,iEdge) * u(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ tend_theta(k,cell1) = tend_theta(k,cell1) - flux
+ tend_theta(k,cell2) = tend_theta(k,cell2) + flux
+ end do
+
+ end do
+ end if
+
+
+ !
+ ! vertical advection plus diabatic term
+ ! Note: we are also dividing through by the cell area after the horizontal flux divergence
+ !
+ do iCell = 1, nCells
+ wdtn(1) = 0.
+ do k=2,nVertLevels
+ wdtn(k) = ww(k,icell)*(fnm(k)*theta(k,iCell)+fnp(k)*theta(k-1,iCell))
+ end do
+ wdtn(nVertLevels+1) = 0.
+ do k=1,nVertLevels
+ tend_theta(k,iCell) = tend_theta(k,iCell)/areaCell(iCell) -rdnw(k)*(wdtn(k+1)-wdtn(k))
+!! tend_theta(k,iCell) = tend_theta(k) + h(k,iCell)*h_diabatic(k,iCell)
+ end do
+ end do
+
+
+ !
+ ! vertical mixing for theta - 2nd order
+ !
+ if ( v_theta_eddy_visc2 > 0.0 ) then
+
+ do iCell = 1, grid % nCellsSolve
+ do k=2,nVertLevels-1
+ z1 = geopotential(k-1,iCell)/gravity
+ z2 = geopotential(k ,iCell)/gravity
+ z3 = geopotential(k+1,iCell)/gravity
+ z4 = geopotential(k+2,iCell)/gravity
+
+ zm = 0.5*(z1+z2)
+ z0 = 0.5*(z2+z3)
+ zp = 0.5*(z3+z4)
+
+ tend_theta(k,iCell) = tend_theta(k,iCell) + v_theta_eddy_visc2*prandtl*h(k,iCell)*( &
+ (theta(k+1,iCell)-theta(k ,iCell))/(zp-z0) &
+ -(theta(k ,iCell)-theta(k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
+ end do
+ end do
+
+ end if
+
+ end subroutine atmh_compute_dyn_tend
+
+!---------------------------------------------------------------------------------------------------------
+
+ subroutine atmh_advance_dynamics(tend, s, grid, small_step, number_small_steps, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance the dry dynamics a small timestep (forward-backward integration)
+ !
+ ! Input: s - current model state
+ ! tend - large-timestep tendency (d*/dt)
+ ! grid - grid metadata
+ ! dt - timestep
+ !
+ ! Output: s - model state advanced a timestep dt
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+ real (kind=RKIND), intent(in) :: dt
+ integer, intent(in) :: small_step, number_small_steps
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, upstream_bias
+
+ integer :: nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, dpsdt, &
+ surface_pressure
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, geopotential, alpha, theta, &
+ pressure, pressure_old, tend_theta, uhAvg, wwAvg, ww, u_old, &
+ theta_old, h_edge_old, qtot, ww_old, cqu, h_old
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar
+
+! real (kind=RKIND), pointer :: smext, p0, ptop
+ real (kind=RKIND) :: smext, smdiv, p0, ptop
+ real (kind=RKIND) :: tm, ptmp, he_old
+
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+
+ real (kind=RKIND), dimension( grid % nVertLevels + 1) :: wdtn
+
+ real (kind=RKIND), dimension(:), pointer :: dnw, dbn, rdnw, dnu, fnm, fnp
+ real (kind=RKIND) :: maxpdt,minpdt, maxww, minww
+ integer :: maxpt,minpt
+
+ h => s % h % array
+ u => s % u % array
+ h_edge => s % h_edge % array
+ theta => s % theta % array
+
+! u_old => s_old % u % array
+! h_edge_old => s_old % h_edge % array
+! theta_old => s_old % theta % array
+! ww_old => s_old % ww % array
+! h_old => s_old % h % array
+ u_old => grid % u_old % array
+ h_edge_old => grid % h_edge_old % array
+ theta_old => grid % theta_old % array
+ ww_old => grid % ww_old % array
+ h_old => grid % h_old % array
+
+ geopotential => s % geopotential % array
+ alpha => s % alpha % array
+ surface_pressure => s % surface_pressure % array
+ pressure => s % pressure % array
+ pressure_old => grid % pressure_old % array
+
+ cellsOnEdge => grid % cellsOnEdge % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ tend_h => tend % h % array
+ tend_u => tend % u % array
+ tend_theta => tend % theta % array
+
+
+ uhAvg => grid % uhAvg % array
+ wwAvg => grid % wwAvg % array
+ dpsdt => grid % dpsdt % array
+ qtot => grid % qtot % array
+ cqu => grid % cqu % array
+ ww => s % ww % array
+ scalar => s % scalars % array
+
+ dnw => grid % dnw % array
+ dbn => grid % dbn % array
+ dnu => grid % dnu % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+
+! p0 => grid % p0
+! ptop => grid % ptop
+! smext => grid % smext
+
+ nVertLevels = grid % nVertLevels
+ nEdges = grid % nEdges
+
+ p0 = 1.e+05
+ ptop = pressure(nVertLevels+1,1)
+ smext = 0.1
+ smdiv = 0.1
+
+! write(0,*) ' ptop in advance_dynamics ',ptop
+
+!--- begin computations
+
+! we assume that the pressure, alpha, geopotential are already properly set
+! in first small step of a set, couple theta
+
+ if(small_step == 1) then
+
+ do iCell=1,grid % nCells
+ do k=1,nVertLevels
+ theta(k,iCell) = theta(k,iCell)*h(k,iCell)
+ end do
+ end do
+
+ uhAvg = 0.
+ wwAvg = 0.
+ pressure_old(:,:) = pressure(:,:)
+ dpsdt(:) = 0.
+
+ end if
+
+ !
+ ! update horizontal momentum
+ !
+
+ do iEdge=1,grid % nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ u(k,iEdge) = u(k,iEdge) + dt*tend_u(k,iEdge) &
+ -(0.5*dt/dcEdge(iEdge))*( &
+ (geopotential(k+1,cell2)-geopotential(k+1,cell1)) &
+ +(geopotential(k ,cell2)-geopotential(k ,cell1)) &
+ +cqu(k,iEdge)*(alpha(k,cell2)+alpha(k,cell1))* &
+ 0.5*(pressure(k+1,cell2)-pressure(k+1,cell1) &
+ +pressure(k ,cell2)-pressure(k ,cell1))) &
+ -smext*dcEdge(iEdge)*(dpsdt(cell2)-dpsdt(cell1))/h_edge(k,iEdge)
+ end do
+ end do
+
+ !
+ ! calculate omega, update theta
+ !
+
+ tend_h = 0.
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
+ tend_h(k,cell1) = tend_h(k,cell1) + flux
+ tend_h(k,cell2) = tend_h(k,cell2) - flux
+ end do
+ do k=1,nVertLevels
+ uhAvg(k,iEdge) = uhAvg(k,iEdge) + u(k,iEdge) * h_edge(k,iEdge)
+ end do
+ end do
+
+ do iCell=1, grid % nCells
+ dpsdt(iCell) = 0.
+ do k=1,nVertLevels
+ dpsdt(iCell) = dpsdt(iCell) + dnw(k)*tend_h(k,iCell)
+ end do
+ dpsdt(iCell) = dpsdt(iCell)/areaCell(iCell)
+
+ surface_pressure(iCell) = surface_pressure(iCell) + dt*dpsdt(iCell)
+
+ do k=1,nVertLevels
+ h(k,iCell) = (1.-dbn(k))*(p0-ptop)+dbn(k)*(surface_pressure(iCell)-ptop)
+ end do
+
+ ! omega calculation
+
+ ww(1,iCell) = 0.
+ do k=2, nVertLevels
+ ww(k,iCell) = ww(k-1,iCell)-dnw(k-1)*(dbn(k-1)*dpsdt(iCell)+tend_h(k-1,iCell)/areaCell(iCell))
+ wwAvg(k,iCell) = wwAvg(k,iCell) + ww(k,iCell)
+ end do
+ ww(nVertLevels+1,iCell) = 0.
+
+ ! theta update - theta should be coupled at this point...
+
+ wdtn(1) = 0.
+ do k = 2, nVertLevels
+ wdtn(k) = (ww(k,iCell)-ww_old(k,iCell))*(fnm(k)*theta_old(k,iCell)+fnp(k)*theta_old(k-1,iCell))
+ end do
+ wdtn(nVertLevels+1) = 0.
+
+ do k = 1, nVertLevels
+ theta(k,iCell) = theta(k,iCell) + dt*tend_theta(k,iCell)
+ theta(k,iCell) = theta(k,iCell) - dt*rdnw(k)*(wdtn(k+1)-wdtn(k))
+ end do
+ end do
+
+ !
+ ! add in perturbation horizontal flux divergence
+ !
+
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = 0.5*(h(k,cell1)+h(k,cell2)) ! here is update of h_edge
+ he_old = 0.5*(h_old(k,cell1)+h_old(k,cell2))
+ flux = 0.5*(u(k,iEdge) * h_edge(k,iEdge) - u_old(k,iEdge) * he_old)* &
+ (theta_old(k,cell1)+theta_old(k,cell2))*dvEdge(iEdge)
+ theta(k,cell1) = theta(k,cell1) - dt*flux/areaCell(cell1)
+ theta(k,cell2) = theta(k,cell2) + dt*flux/areaCell(cell2)
+ end do
+ end do
+
+
+ ! compute some diagnostics using the new state
+
+ do iCell = 1, grid % nCells
+
+ do k = nVertLevels,1,-1
+ pressure(k,iCell) = pressure(k+1,iCell) - dnw(k)*(1.+qtot(k,iCell))*h(k,iCell)
+ end do
+
+ do k=1, nVertLevels
+ tm = (1.+1.61*scalar(1,k,iCell))*theta(k,iCell)/h(k,iCell) ! assume scalar(1) is qv here?
+ alpha(k,iCell) = (rgas/p0)*tm* &
+ (0.5*(pressure(k,iCell)+pressure(k+1,iCell))/p0)**cvpm
+ geopotential(k+1,iCell) = geopotential(k,iCell) - dnw(k)*h(k,iCell)*alpha(k,iCell)
+ end do
+
+ if(small_step /= number_small_steps) then
+ do k=1, nVertLevels+1
+ ptmp = pressure(k,iCell)
+ pressure(k,iCell) = pressure(k,iCell) + smdiv*(pressure(k,iCell)-pressure_old(k,iCell))
+ pressure_old(k,iCell) = ptmp
+ end do
+ end if
+
+ end do
+
+! if last small step of a set, decouple theta
+
+ if(small_step == number_small_steps) then
+ do iCell=1,grid % nCells
+ do k=1,nVertLevels
+ theta(k,iCell) = theta(k,iCell)/h(k,iCell)
+ end do
+ end do
+ uhAvg = uhAvg/real(number_small_steps)
+ wwAvg = wwAvg/real(number_small_steps)
+ end if
+
+ end subroutine atmh_advance_dynamics
+
+
+ subroutine atmh_advance_scalars( tend, s_old, s_new, grid, dt)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(in) :: s_old
+ type (state_type), intent(inout) :: s_new
+ type (mesh_type), intent(in) :: grid
+ real (kind=RKIND) :: dt
+
+ integer :: i, iCell, iEdge, k, iScalar, cell1, cell2, num_scalars
+ real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ integer, dimension(:,:), pointer :: cellsOnEdge
+
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nVertLevels + 1 ) :: wdtn
+ integer :: nVertLevels
+
+ real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
+ real (kind=RKIND) :: coef_3rd_order
+
+ num_scalars = s_old % num_scalars
+
+ coef_3rd_order = 0.
+ if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
+ if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ scalar_old => s_old % scalars % array
+ scalar_new => s_new % scalars % array
+ deriv_two => grid % deriv_two % array
+ uhAvg => grid % uhAvg % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ scalar_tend => tend % scalars % array
+ h_old => s_old % h % array
+ h_new => s_new % h % array
+ wwAvg => grid % wwAvg % array
+ areaCell => grid % areaCell % array
+
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+ rdnw => grid % rdnw % array
+
+ nVertLevels = grid % nVertLevels
+
+ scalar_tend = 0. ! testing purposes - we have no sources or sinks
+
+ !
+ ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts form scalar_old
+ !
+ !
+ ! horizontal flux divergence, accumulate in scalar_tend
+
+ if (config_scalar_adv_order == 2) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,grid % nVertLevels
+ do iScalar=1,num_scalars
+ scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
+ flux = uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
+ scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
+ scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
+ end do
+ end do
+ end do
+
+ else if (config_scalar_adv_order == 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,grid % nVertLevels
+
+ do iScalar=1,num_scalars
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ if (uhAvg(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ else
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
+! old version of the above code, with coef_3rd_order assumed to be 1.0
+! if (uhAvg(k,iEdge) > 0) then
+! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+! -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
+! else
+! flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+! 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+! -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
+! end if
+
+ scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
+ scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
+
+ end do
+ end do
+ end do
+
+ else if (config_scalar_adv_order == 4) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ do k=1,grid % nVertLevels
+
+ do iScalar=1,num_scalars
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
+
+ scalar_tend(iScalar,k,cell1) = scalar_tend(iScalar,k,cell1) - flux/areaCell(cell1)
+ scalar_tend(iScalar,k,cell2) = scalar_tend(iScalar,k,cell2) + flux/areaCell(cell2)
+ end do
+ end do
+
+ end do
+ end if
+
+
+ !
+ ! vertical flux divergence
+ !
+
+ do iCell=1,grid % nCells
+
+ wdtn(:,1) = 0.
+ do k = 2, nVertLevels
+ do iScalar=1,num_scalars
+ wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell))
+ end do
+ end do
+ wdtn(:,nVertLevels+1) = 0.
+
+ do k=1,grid % nVertLevelsSolve
+ do iScalar=1,num_scalars
+ scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*h_old(k,iCell) &
+ + dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) )/h_new(k,iCell)
+
+ end do
+ end do
+ end do
+
+ end subroutine atmh_advance_scalars
+
+
+ subroutine atmh_advance_scalars_mono( tend, s_old, s_new, grid, dt, rk_step, rk_order, dminfo, cellsToSend, cellsToRecv)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (tend_type), intent(in) :: tend
+ type (state_type), intent(in) :: s_old
+ type (state_type), intent(inout) :: s_new
+ type (mesh_type), intent(in) :: grid
+ integer, intent(in) :: rk_step, rk_order
+ real (kind=RKIND), intent(in) :: dt
+ type (dm_info), intent(in) :: dminfo
+ type (exchange_list), pointer :: cellsToSend, cellsToRecv
+
+ integer :: i, iCell, iEdge, k, iScalar, cell_upwind, cell1, cell2, num_scalars
+ real (kind=RKIND) :: flux, scalar_edge, d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND) :: fdir, flux_upwind, h_flux_upwind, s_upwind
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND), dimension(:,:), pointer :: uhAvg, h_old, h_new, wwAvg
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
+ integer, dimension(:,:), pointer :: cellsOnEdge
+
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nEdges+1) :: h_flux
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: v_flux, v_flux_upwind, s_update
+ real (kind=RKIND), dimension( s_old % num_scalars, grid % nCells+1, 2 ) :: scale_out, scale_in
+ real (kind=RKIND), dimension( s_old % num_scalars ) :: s_max, s_min, s_max_update, s_min_update
+
+ integer :: nVertLevels, km0, km1, ktmp, kcp1, kcm1
+
+ real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
+ real (kind=RKIND), parameter :: eps=1.e-20
+ real (kind=RKIND) :: coef_3rd_order
+
+ num_scalars = s_old % num_scalars
+
+ scalar_old => s_old % scalars % array
+ scalar_new => s_new % scalars % array
+ deriv_two => grid % deriv_two % array
+ uhAvg => grid % uhAvg % array
+ dvEdge => grid % dvEdge % array
+ dcEdge => grid % dcEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ scalar_tend => tend % scalars % array
+ h_old => s_old % h % array
+ h_new => s_new % h % array
+ wwAvg => grid % wwAvg % array
+ areaCell => grid % areaCell % array
+
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+ rdnw => grid % rdnw % array
+
+ nVertLevels = grid % nVertLevels
+
+ scalar_tend = 0. ! testing purposes - we have no sources or sinks
+
+ !
+ ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old
+ !
+
+ km1 = 1
+ km0 = 2
+ v_flux(:,:,km1) = 0.
+ v_flux_upwind(:,:,km1) = 0.
+ scale_out(:,:,:) = 1.
+ scale_in(:,:,:) = 1.
+
+ coef_3rd_order = 0.
+ if (config_scalar_adv_order == 3) coef_3rd_order = 1.0
+ if (config_scalar_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
+
+ do k = 1, grid % nVertLevels
+ kcp1 = min(k+1,grid % nVertLevels)
+ kcm1 = max(k-1,1)
+
+! vertical flux
+
+ do iCell=1,grid % nCells
+
+ if (k < grid % nVertLevels) then
+ cell_upwind = k
+ if (wwAvg(k+1,iCell) >= 0) cell_upwind = k+1
+ do iScalar=1,num_scalars
+ v_flux(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * &
+ (fnm(k+1) * scalar_new(iScalar,k+1,iCell) + fnp(k+1) * scalar_new(iScalar,k,iCell))
+ v_flux_upwind(iScalar,iCell,km0) = dt * wwAvg(k+1,iCell) * scalar_old(iScalar,cell_upwind,iCell)
+ v_flux(iScalar,iCell,km0) = v_flux(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km0)
+! v_flux(iScalar,iCell,km0) = 0. ! use only upwind - for testing
+ s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
+ - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
+ end do
+ else
+ do iScalar=1,num_scalars
+ v_flux(iScalar,iCell,km0) = 0.
+ v_flux_upwind(iScalar,iCell,km0) = 0.
+ s_update(iScalar,iCell,km0) = scalar_old(iScalar,k,iCell) * h_old(k,iCell) &
+ - rdnw(k) * (v_flux_upwind(iScalar,iCell,km0) - v_flux_upwind(iScalar,iCell,km1))
+ end do
+ end if
+
+ end do
+
+! horizontal flux
+
+ if (config_scalar_adv_order == 2) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ cell_upwind = cell2
+ if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
+ do iScalar=1,num_scalars
+ scalar_edge = 0.5 * (scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2))
+ h_flux(iScalar,iEdge) = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_edge
+ h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
+ h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
+! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
+ s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
+ s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
+ end do
+ end do
+
+ else if (config_scalar_adv_order >= 3) then
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ cell_upwind = cell2
+ if (uhAvg(k,iEdge) >= 0) cell_upwind = cell1
+ do iScalar=1,num_scalars
+
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * scalar_new(iScalar,k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * scalar_new(iScalar,k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell1))
+ end do
+ do i=1, grid % nEdgesOnCell % array (cell2)
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * scalar_new(iScalar,k,grid % CellsOnCell % array (i,cell2))
+ end do
+
+ if (uhAvg(k,iEdge) > 0) then
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ else
+ flux = dvEdge(iEdge) * uhAvg(k,iEdge) * ( &
+ 0.5*(scalar_new(iScalar,k,cell1) + scalar_new(iScalar,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ end if
+
+ h_flux(iScalar,iEdge) = dt * flux
+ h_flux_upwind = dt * uhAvg(k,iEdge) * dvEdge(iEdge) * scalar_old(iScalar,k,cell_upwind)
+ h_flux(iScalar,iEdge) = h_flux(iScalar,iEdge) - h_flux_upwind
+! h_flux(iScalar,iEdge) = 0. ! use only upwind - for testing
+ s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - h_flux_upwind / grid % areaCell % array(cell1)
+ s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + h_flux_upwind / grid % areaCell % array(cell2)
+ end do
+ end do
+
+ end if
+
+
+ if ( (rk_step == rk_order) .and. (config_monotonic .or. config_positive_definite) ) then
+
+!*************************************************************************************************************
+!--- limiter - we limit horizontal and vertical fluxes on level k
+!--- (these are h fluxes contributing to level k scalars, and v flux contributing to level k, k-1 scalars)
+
+ do iCell=1,grid % nCells
+
+ do iScalar=1,num_scalars
+
+ s_max(iScalar) = max(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
+ s_min(iScalar) = min(scalar_old(iScalar,k,iCell), scalar_old(iScalar,kcp1,iCell), scalar_old(iScalar,kcm1,iCell))
+ s_max_update(iScalar) = s_update(iScalar,iCell,km0)
+ s_min_update(iScalar) = s_update(iScalar,iCell,km0)
+
+ ! add in vertical flux to get max and min estimate
+ s_max_update(iScalar) = s_max_update(iScalar) &
+ - rdnw(k) * (max(0.,v_flux(iScalar,iCell,km0)) - min(0.,v_flux(iScalar,iCell,km1)))
+ s_min_update(iScalar) = s_min_update(iScalar) &
+ - rdnw(k) * (min(0.,v_flux(iScalar,iCell,km0)) - max(0.,v_flux(iScalar,iCell,km1)))
+
+ end do
+
+ do i = 1, grid % nEdgesOnCell % array(iCell) ! go around the edges of each cell
+ do iScalar=1,num_scalars
+
+ s_max(iScalar) = max(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_max(iScalar))
+ s_min(iScalar) = min(scalar_old(iScalar,k,grid % cellsOnCell % array(i,iCell)), s_min(iScalar))
+
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ if (iCell == cellsOnEdge(1,iEdge)) then
+ fdir = 1.0
+ else
+ fdir = -1.0
+ end if
+ flux = -fdir * h_flux(iScalar,iEdge)/grid % areaCell % array(iCell)
+ s_max_update(iScalar) = s_max_update(iScalar) + max(0.,flux)
+ s_min_update(iScalar) = s_min_update(iScalar) + min(0.,flux)
+
+ end do
+
+ end do
+
+ if( config_positive_definite ) s_min(:) = 0.
+
+ do iScalar=1,num_scalars
+ scale_out (iScalar,iCell,km0) = 1.
+ scale_in (iScalar,iCell,km0) = 1.
+ s_max_update (iScalar) = s_max_update (iScalar) / h_new (k,iCell)
+ s_min_update (iScalar) = s_min_update (iScalar) / h_new (k,iCell)
+ s_upwind = s_update(iScalar,iCell,km0) / h_new(k,iCell)
+ if ( s_max_update(iScalar) > s_max(iScalar) .and. config_monotonic) &
+ scale_in (iScalar,iCell,km0) = max(0.,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
+ if ( s_min_update(iScalar) < s_min(iScalar) ) &
+ scale_out (iScalar,iCell,km0) = max(0.,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
+ end do
+
+ end do ! end loop over cells to compute scale factor
+
+
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,1), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_out(:,:,2), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,1), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(dminfo, scale_in(:,:,2), &
+ num_scalars, grid % nCells, &
+ cellsToSend, cellsToRecv)
+
+ ! rescale the horizontal fluxes
+
+ do iEdge = 1, grid % nEdges
+ cell1 = grid % cellsOnEdge % array(1,iEdge)
+ cell2 = grid % cellsOnEdge % array(2,iEdge)
+ do iScalar=1,num_scalars
+ flux = h_flux(iScalar,iEdge)
+ if (flux > 0) then
+ flux = flux * min(scale_out(iScalar,cell1,km0), scale_in(iScalar,cell2,km0))
+ else
+ flux = flux * min(scale_in(iScalar,cell1,km0), scale_out(iScalar,cell2,km0))
+ end if
+ h_flux(iScalar,iEdge) = flux
+ end do
+ end do
+
+ ! rescale the vertical flux
+
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ flux = v_flux(iScalar,iCell,km1)
+ if (flux > 0) then
+ flux = flux * min(scale_out(iScalar,iCell,km0), scale_in(iScalar,iCell,km1))
+ else
+ flux = flux * min(scale_in(iScalar,iCell,km0), scale_out(iScalar,iCell,km1))
+ end if
+ v_flux(iScalar,iCell,km1) = flux
+ end do
+ end do
+
+! end of limiter
+!*******************************************************************************************************************
+
+ end if
+
+!--- update
+
+ do iCell=1,grid % nCells
+ ! add in upper vertical flux that was just renormalized
+ do iScalar=1,num_scalars
+ s_update(iScalar,iCell,km0) = s_update(iScalar,iCell,km0) + rdnw(k) * v_flux(iScalar,iCell,km1)
+ if (k > 1) s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) - rdnw(k-1)*v_flux(iScalar,iCell,km1)
+ end do
+ end do
+
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do iScalar=1,num_scalars
+ s_update(iScalar,cell1,km0) = s_update(iScalar,cell1,km0) - &
+ h_flux(iScalar,iEdge) / grid % areaCell % array(cell1)
+ s_update(iScalar,cell2,km0) = s_update(iScalar,cell2,km0) + &
+ h_flux(iScalar,iEdge) / grid % areaCell % array(cell2)
+ end do
+ end do
+
+ ! decouple from mass
+ if (k > 1) then
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ s_update(iScalar,iCell,km1) = s_update(iScalar,iCell,km1) / h_new(k-1,iCell)
+ end do
+ end do
+
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ scalar_new(iScalar,k-1,iCell) = s_update(iScalar,iCell,km1)
+ end do
+ end do
+ end if
+
+ ktmp = km1
+ km1 = km0
+ km0 = ktmp
+
+ end do
+
+ do iCell=1,grid % nCells
+ do iScalar=1,num_scalars
+ scalar_new(iScalar,grid % nVertLevels,iCell) = s_update(iScalar,iCell,km1) / h_new(grid%nVertLevels,iCell)
+ end do
+ end do
+
+ end subroutine atmh_advance_scalars_mono
+
+
+ subroutine atmh_compute_solve_diagnostics(dt, s, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields used in the tendency computations
+ !
+ ! Input: grid - grid metadata
+ !
+ ! Output: s - computed diagnostics
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: dt
+ type (state_type), intent(inout) :: s
+ type (mesh_type), intent(in) :: grid
+
+
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, r
+
+ integer :: nCells, nEdges, nVertices, nVertLevels
+ real (kind=RKIND), dimension(:), pointer :: h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
+ real (kind=RKIND), dimension(:,:), pointer :: vh, weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, tend_h, tend_u, &
+ circulation, vorticity, ke, pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, &
+ divergence
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge
+
+
+ h => s % h % array
+ u => s % u % array
+ v => s % v % array
+ vh => s % vh % array
+ h_edge => s % h_edge % array
+ tend_h => s % h % array
+ tend_u => s % u % array
+ circulation => s % circulation % array
+ vorticity => s % vorticity % array
+ divergence => s % divergence % array
+ ke => s % ke % array
+ pv_edge => s % pv_edge % array
+ pv_vertex => s % pv_vertex % array
+ pv_cell => s % pv_cell % array
+ gradPVn => s % gradPVn % array
+ gradPVt => s % gradPVt % array
+
+ weightsOnEdge => grid % weightsOnEdge % array
+ kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnVertex => grid % cellsOnVertex % array
+ verticesOnEdge => grid % verticesOnEdge % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ edgesOnCell => grid % edgesOnCell % array
+ nEdgesOnEdge => grid % nEdgesOnEdge % array
+ edgesOnEdge => grid % edgesOnEdge % array
+ edgesOnVertex => grid % edgesOnVertex % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaCell => grid % areaCell % array
+ areaTriangle => grid % areaTriangle % array
+ h_s => grid % h_s % array
+ fVertex => grid % fVertex % array
+ fEdge => grid % fEdge % array
+
+ nCells = grid % nCells
+ nEdges = grid % nEdges
+ nVertices = grid % nVertices
+ nVertLevels = grid % nVertLevels
+
+ !
+ ! Compute height on cell edges at velocity locations
+ !
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
+ end do
+ end do
+
+ !
+ ! Compute circulation and relative vorticity at each vertex
+ !
+ circulation(:,:) = 0.0
+ do iEdge=1,nEdges
+ do k=1,nVertLevels
+ circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
+ circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
+ end do
+ end do
+ do iVertex=1,nVertices
+ do k=1,nVertLevels
+ vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
+ end do
+ end do
+
+
+ !
+ ! Compute the divergence at each cell center
+ !
+ divergence(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,nVertLevels
+ divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
+ divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
+ end do
+ end do
+ do iCell = 1,nCells
+ r = 1.0 / areaCell(iCell)
+ do k = 1,nVertLevels
+ divergence(k,iCell) = divergence(k,iCell) * r
+ end do
+ end do
+
+
+ !
+ ! Compute kinetic energy in each cell
+ !
+ ke(:,:) = 0.0
+ do iCell=1,nCells
+ do i=1,nEdgesOnCell(iCell)
+ iEdge = edgesOnCell(i,iCell)
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
+ end do
+ end do
+ do k=1,nVertLevels
+ ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
+ end do
+ end do
+
+ !
+ ! Compute v (tangential) velocities
+ !
+ v(:,:) = 0.0
+ do iEdge = 1,nEdges
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ do k = 1,nVertLevels
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+ end do
+
+
+ ! tdr
+ !
+ ! Compute height at vertices, pv at vertices, and average pv to edge locations
+ ! ( this computes pv_vertex at all vertices bounding real cells )
+ !
+ do iVertex = 1,nVertices
+ do k=1,nVertLevels
+ h_vertex = 0.0
+ do i=1,grid % vertexDegree
+ h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
+ end do
+ h_vertex = h_vertex / areaTriangle(iVertex)
+
+ pv_vertex(k,iVertex) = (fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
+ end do
+ end do
+ ! tdr
+
+
+ ! tdr
+ !
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradPVt at all edges bounding real cells )
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ gradPVt(k,iEdge) = (pv_vertex(k,verticesOnEdge(2,iEdge)) - pv_vertex(k,verticesOnEdge(1,iEdge))) / &
+ dvEdge(iEdge)
+ end do
+ end do
+
+ ! tdr
+ !
+ ! Compute pv at the edges
+ ! ( this computes pv_edge at all edges bounding real cells )
+ !
+ pv_edge(:,:) = 0.0
+ do iVertex = 1,nVertices
+ do i=1,grid % vertexDegree
+ iEdge = edgesOnVertex(i,iVertex)
+ do k=1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
+ end do
+ end do
+ end do
+ ! tdr
+
+ ! tdr
+ !
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * v(k,iEdge) * dt * gradPVt(k,iEdge)
+ end do
+ end do
+
+
+ ! tdr
+ !
+ ! Compute pv at cell centers
+ ! ( this computes pv_cell for all real cells )
+ !
+ pv_cell(:,:) = 0.0
+ do iVertex = 1, nVertices
+ do i=1,grid % vertexDegree
+ iCell = cellsOnVertex(i,iVertex)
+ do k = 1,nVertLevels
+ pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
+ end do
+ end do
+ end do
+ ! tdr
+
+ ! tdr
+ !
+ ! Compute gradient of PV in normal direction
+ ! (tdr: 2009-10-02: this is not correct because the pv_cell in the halo is not correct)
+ !
+ gradPVn(:,:) = 0.0
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
+ dcEdge(iEdge)
+ end do
+ end do
+ ! tdr
+
+ ! Modify PV edge with upstream bias.
+ !
+ do iEdge = 1,nEdges
+ do k = 1,nVertLevels
+ pv_edge(k,iEdge) = pv_edge(k,iEdge) - config_apvm_upwinding * u(k,iEdge) * dt * gradPVn(k,iEdge)
+ end do
+ end do
+
+
+ end subroutine atmh_compute_solve_diagnostics
+
+
+ subroutine atmh_compute_w (s_new, s_old, grid, dt )
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute (diagnose) vertical velocity (used by physics)
+ !
+ ! Input: s_new - current model state
+ ! s_old - previous model state
+ ! grid - grid metadata
+ ! dt - timestep between new and old
+ !
+ ! Output: w (m/s)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ type (state_type), intent(inout) :: s_new
+ type (state_type), intent(in) :: s_old
+ type (mesh_type), intent(inout) :: grid
+
+ real (kind=RKIND), intent(in) :: dt
+
+ real (kind=RKIND), dimension(:,:), pointer :: geo_new, geo_old, u, ww, h, w
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, rdnw, fnm, fnp
+
+ integer :: iEdge, iCell, k, cell1, cell2
+ real (kind=RKIND), dimension( grid % nVertlevels + 1 ) :: wdwn
+ real (kind=RKIND) :: flux
+
+ geo_new => s_new % geopotential % array
+ geo_old => s_old % geopotential % array
+ u => s_new % u % array
+ ww => s_new % ww % array
+ h => s_new % h % array
+ w => s_new % w % array
+ dvEdge => grid % dvEdge % array
+ rdnw => grid % rdnw % array
+ fnm => grid % fnm % array
+ fnp => grid % fnp % array
+
+ w = 0.
+
+ do iCell=1, grid % nCellsSolve
+ wdwn(1) = 0.
+ do k=2,grid % nVertlevels + 1
+ wdwn(k) = (0.5*(ww(k,iCell)+ww(k-1,iCell))/h(k-1,iCell)) &
+ *rdnw(k-1)*(geo_new(k,iCell)-geo_new(k-1,iCell))
+ enddo
+ w(1,iCell) = 0.
+ do k=2, grid % nVertLevels
+ w(k,iCell) = (((geo_new(k,iCell)-geo_old(k,iCell))/dt)+ &
+ fnm(k)*wdwn(k+1)+fnp(k)*wdwn(k))/gravity
+ enddo
+ k = grid % nVertLevels + 1
+ w(k,iCell) = ((geo_new(k,iCell)-geo_old(k,iCell))/dt)/gravity
+ enddo
+
+ do iEdge=1, grid % nEdges
+ cell1 = grid % cellsOnEdge % array (1,iEdge)
+ cell2 = grid % cellsOnEdge % array (2,iEdge)
+ if (cell1 <= grid % nCellsSolve .or. cell2 <= grid % nCellsSolve ) then
+ do k=2, grid % nVertLevels
+ flux = 0.25*(u(k,iEdge)+u(k-1,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
+ w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
+ w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
+ enddo
+ k = 1
+ flux = 0.5*(1.5*u(1,iEdge)-0.5*u(2,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
+ w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
+ w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
+
+ k = grid % nVertLevels + 1
+ flux = 0.5*(1.5*u(k-1,iEdge)-0.5*u(k-2,iEdge)*(geo_new(k,cell2)-geo_new(k,cell1))) * dvEdge(iEdge) / gravity
+ w(k,cell1) = w(k,cell1) + flux/ grid % AreaCell % array (cell1)
+ w(k,cell2) = w(k,cell2) + flux/ grid % AreaCell % array (cell2)
+
+ end if
+ end do
+
+ end subroutine atmh_compute_w
+
+end module atmh_time_integration
</font>
</pre>