<p><b>duda</b> 2010-07-13 15:27:45 -0600 (Tue, 13 Jul 2010)</p><p>BRANCH COMMIT<br>
<br>
Remove unused alternate versions of non-hydrostatic core files.<br>
<br>
D src/core_nhyd_atmos/module_test_cases.F.100705<br>
D src/core_nhyd_atmos/module_time_integration.F.0531<br>
D src/core_nhyd_atmos/module_time_integration.F.sh0609<br>
D src/core_nhyd_atmos/module_test_cases.F.sh0614<br>
D src/core_nhyd_atmos/module_test_cases.F.0521<br>
D src/core_nhyd_atmos/module_test_cases.F.ok<br>
</p><hr noshade><pre><font color="gray">Deleted: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.0521
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.0521        2010-07-12 19:38:09 UTC (rev 372)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.0521        2010-07-13 21:27:45 UTC (rev 373)
@@ -1,964 +0,0 @@
-module test_cases
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine setup_nhyd_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 nonhydrostatic 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))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_jw(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 4 ) then
-
- write(0,*) ' squall line - super cell test case '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_squall_line(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
-
- write(0,*) ' Only test case 1, 2, 3 and 4 are currently supported for nonhydrostatic core '
- stop
- end if
-
- end subroutine setup_nhyd_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_jw(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
- real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
-
- !
- ! 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
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
-
- ppb => grid % pressure_base % array
- pp => state % pressure % array
-
- rho => state % rho % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
-
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- phi = grid % latCell % array (iCell)
- hx(k,iCell) = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.5
- zt = 45000.
- dz = zt/float(nz1)
-
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- sh(k) = (real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k) and define sh(k) = zc(k)/zt
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
- zw(k) = float(k-1)*dz
-! zw(k) = sh(k)*zt
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
- ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
-! ah(k) = 0.
-         write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = (1.-ah(k))*(sh(k)*(zt-hx(k,iCell))+hx(k,iCell)) &
- + ah(k) * sh(k)* zt        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-!---- baroclinc wave initialization ---------------------------------
-!
-! reference sounding based on dry isothermal atmosphere
-!
- do i=1, grid % nCells
- !write(0,*) ' thermodynamic setup, cell ',i
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
- pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz(k,i))
- tb (k,i) = t0b/pb(k,i)
- rtb(k,i) = rb(k,i)*tb(k,i)
- p (k,i) = pb(k,i)
- pp (k,i) = 0.
- rr (k,i) = 0.
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
- enddo
- end if
-!
-! iterations to converge temperature as a function of pressure
-!
- do itr = 1,10
-
- do k=1,nz1
- eta (k) = (ppb(k,i)+pp(k,i))/p0
- etav(k) = (eta(k)-.252)*pii/2.
- if(eta(k).ge.znut) then
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
- end if
- end do
- phi = grid % latCell % array (i)
- do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- *sqrt(cos(etav(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(etav(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
-
-
- !write(0,*) ' k, tt(k) ',k,tt(k)
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- ptemp = ppb(k,i) + pp(k,i)
-! qv(k,i) = env_qv( ztemp, tt(k), ptemp, 0 )
- qv(k,i) = 0.
-
- end do
-! do k=2,nz1
-! cqw(k,i) = 1./(1.+.5*(qv(k,i)+qv(k-1,i)))
-! end do
-                
- do itrp = 1,25
- do k=1,nz1                                
- rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
- end do
-
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
-
- ppi(1) = ppi(1)-ppb(1,i)
- do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
- end do
-
- do k=1,nz1
- pp(k,i) = .2*ppi(k)+.8*pp(k,i)
- end do
-
- end do ! end inner iteration loop itrp
-
- end do ! end outer iteration loop itr
-
- do k=1,nz1        
- p (k,i) = ((ppb(k,i)+pp(k,i))/p0)**(rgas/cp)
- t (k,i) = tt(k)/p(k,i)
- rt (k,i) = t(k,i)*rr(k,i)+rb(k,i)*(t(k,i)-tb(k,i))
- rho (k,i) = rb(k,i) + rr(k,i)
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, p, t, rt ',k,p(k,1),t(k,1),rt(k,1)
- enddo
- end if
-
- end do ! end loop over cells
-
- 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)
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- 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
- etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
-
- fluxk = u0*flux*(cos(etavs)**1.5)
-! 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
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
-
- end subroutine nhyd_test_case_jw
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_squall_line(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
- real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- real (kind=RKIND) :: 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv, rh
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt, thi
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
- real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, ptopb, rcp, rcv
- real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, temp, pres, yloc, ymid, a_scale
-
- !
- ! Scale all distances
- !
-
- a_scale = 1.0
-
- grid % xCell % array = grid % xCell % array * a_scale
- grid % yCell % array = grid % yCell % array * a_scale
- grid % zCell % array = grid % zCell % array * a_scale
- grid % xVertex % array = grid % xVertex % array * a_scale
- grid % yVertex % array = grid % yVertex % array * a_scale
- grid % zVertex % array = grid % zVertex % array * a_scale
- grid % xEdge % array = grid % xEdge % array * a_scale
- grid % yEdge % array = grid % yEdge % array * a_scale
- grid % zEdge % array = grid % zEdge % array * a_scale
- grid % dvEdge % array = grid % dvEdge % array * a_scale
- grid % dcEdge % array = grid % dcEdge % array * a_scale
- grid % areaCell % array = grid % areaCell % array * a_scale**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- ppb => grid % pressure_base % array
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
- cqw => grid % cqw % array
-
- rho => state % rho % array
-
- pp => state % pressure % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
- u => state % u % array
- ru => grid % ru % array
-
- scalars => state % scalars % array
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
- rcp = rgas/cp
- rcv = rgas/(cp-rgas)
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- hx(k,iCell) = 0. ! squall line or supercell on flat plane
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.0
- zt = 20000.
- dz = zt/float(nz1)
-
- write(0,*) ' dz = ',dz
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- zc(k) = zt*(real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k)
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
-! zw(k) = float(k-1)*dz
- zw(k) = zc(k)
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
-! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
- ah(k) = 1.
-         write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
- + (1.-ah(k)) * zc(k)        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-! convective initialization
-!
- ztr = 12000.
- thetar = 343.
- ttr = 213.
- thetas = 300.5
-
-! no flow
- um = 0.
- us = 0.
- zts = 5000.
-! supercell parameters
-! um = 30.
-! us = 15.
-! zts = 5000.
-! squall-line parameters
-! um = 12.
-! us = 10.
-! zts = 2500.
-
-
- do i=1,grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- if(ztemp .gt. ztr) then
- t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr))
- rh(k,i) = 0.25
- else
- t (k,i) = 300.+43.*(ztemp/ztr)**1.25
- rh(k,i) = (1.-0.75*(ztemp/ztr)**1.25)
- rh(k,i) = 0.
- if(t(k,i).lt.thetas) t(k,i) = thetas
- end if
- tb(k,i) = t(k,i)
- end do
- end do
-
-! set the velocity field - we are on a plane here.
-
- do i=1, grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
- +zgrid(k,cell2)+zgrid(k+1,cell2))
- if(ztemp.lt.zts) then
- u(k,i) = um*ztemp/zts
- else
- u(k,i) = um
- end if
- u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
- end do
- end if
- end do
-!
-! reference sounding based on dry atmosphere
-!
- pitop = 1.-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*.5*(tb(k,1)+tb(k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
-        
- write(0,*) k,pitop,tb(k,1),dzu(k),tb(k,1)
- end do
- pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
-
- ptopb = p0*pitop**(1./rcp)
- write(6,*) 'ptopb = ',.01*ptopb
-                
- do i=1, grid % nCells
- pb(nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
- p (nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
- do k=nz1-1,1,-1
- pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- end do
- do k=1,nz1
- rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
- rtb(k,i) = rb(k,i)*tb(k,i)
- rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
- cqw(k,i) = 1.
- end do
- end do
-
-
- write(0,*) ' base state sounding '
- do k=1,grid%nVertLevels
- write(0,*) ' k, pb,rb,tb,rtb,t,rr,p ', k,pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1)
- end do
-
-!-------------------------------------------------------------------
-! ITERATIONS TO CONVERGE MOIST SOUNDING
-!
-! delt = -15.
- delt = 0.
- radx = 10000.
- radz = 1500.
- zcent = 1500.
- xmid = 20000.
- ymid = 20000.
-
- do i = 1, grid % nCells
- xloc = grid % xCell % array(i) - xmid
- yloc = grid % yCell % array(i) - ymid
- do k = 1,nz1
- thi(k) = 0.
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- rad =sqrt((xloc/radx)**2+(yloc/radx)**2+((ztemp-zcent)/radz)**2)
- if(rad.lt.1) then
- thi(k) = t(k,i) + delt*cos(.5*pii*rad)**2
- end if
- end do
-
- do itr=1,30
-                
- if(i.eq.1) then
- pitop = 1.-.5*dzw(1)*gravity*(1.+qv(1,1))/(cp*t(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
- end do
- pitop = pitop - .5*dzw(nz1)*gravity*(1.+qv(nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- ptop = p0*pitop**(1./rcp)
- write(0,*) 'ptop = ',.01*ptop
- end if
-
- pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
- (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*qv(nz1,i))
- do k=nz1-1,1,-1
- pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
- end do
- do k=1,nz1
- rt(k,i) = (pp(k,i)/(r*zz(k,i)) &
- -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
- p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
- rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
- end do
-!
-! update water vapor mixing ratio from humitidty profile
-!
- do k=1,nz1
- temp = p(k,1)*thi(k)
- pres = p0*p(k,1)**(1./rcp)
- qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(k,i,index_qv) = amin1(0.014,rh(k,1)*qvs)
- end do
-                        
- do k=1,nz1
- t (k,i) = thi(k)*(1.+1.61*scalars(k,i,index_qv))
- end do
- do k=2,nz1
- cqw(k,i) = 1./(1.+.5*( scalars(k ,i,index_qv) &
- +scalars(k-1,i,index_qv)))
- end do
- end do ! iteration loop
- end do ! loop over cells
-!----------------------------------------------------------------------
-!
- write(0,*) ' sounding for the simulation '
- do k=1,nz1
- write(6,10) .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
- .01*p0*p(k,1)**(1./rcp),t(k,1)/(1.+1.61*scalars(k,1,index_qv)), &
- 1000.*scalars(k,1,index_qv),u(k,1)
- 10 format(1x,5f10.3)
- end do
-                
-!
- do i=1,grid % ncells
- do k=1,nz1
- rho(k,i) = rb(k,i)+rr(k,i)
- end do
- end do
-
- do i=1,grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ru (k,i) = 0.5*(rho(k,cell1)+rho(k,cell2))*u(k,i)
- end do
- end if
- end do
-
-!
-! CALCULATION OF OMEGA, RW = ZX * RU + ZZ * RW
-!
-! we are assuming w and rw are zero for this initialization
-! i.e., no terrain
-!
- grid % rw % array = 0.
-
-! DO I=1,NX
-! IM1=I-1
-! IF(IPER.EQ.1.AND.I.EQ.1) IM1=NX1
-! RW(1 ,I) = 0.
-! RW(NZ,I) = 0.
-! DO K=2,NZ1
-! RW(K ,I) = (FZM(K)*ZZ(K,I)+FZP(K)*ZZ(K-1,I))*(
-! & -RDX*(RUZ(K,I )*(ZUW(K,I )-ZGRID(K,I))
-! & -RUZ(K,IM1)*(ZUW(K,IM1)-ZGRID(K,I))))
-! END DO
-! DO K=1,NZ
-! RW1(K,I) = RW(K,I)
-! END DO
-! END DO
-
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 0.
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 0.
- end do
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
- end subroutine nhyd_test_case_squall_line
-
- 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
-
-end module test_cases
Deleted: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.100705
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.100705        2010-07-12 19:38:09 UTC (rev 372)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.100705        2010-07-13 21:27:45 UTC (rev 373)
@@ -1,1007 +0,0 @@
-module test_cases
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine setup_nhyd_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 nonhydrostatic 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))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_jw(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 4 ) then
-
- write(0,*) ' squall line - super cell test case '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_squall_line(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
-
- write(0,*) ' Only test case 1, 2, 3 and 4 are currently supported for nonhydrostatic core '
- stop
- end if
-
- end subroutine setup_nhyd_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_jw(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
- real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf
-
- !
- ! 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
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
-
- ppb => grid % pressure_base % array
- pp => state % pressure % array
-
- rho => state % rho % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
-
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- phi = grid % latCell % array (iCell)
- hx(k,iCell) = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.5
- zt = 45000.
- dz = zt/float(nz1)
-
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- sh(k) = (real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k) and define sh(k) = zc(k)/zt
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
- zw(k) = float(k-1)*dz
-! zw(k) = sh(k)*zt
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
- ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
-! ah(k) = 0.
-         write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2)
- COF2 = DZU(2) /(DZU(2)+DZU(3))*DZW(1)/DZU(3)
- CF1 = FZP(2) + COF1
- CF2 = FZM(2) - COF1 - COF2
- CF3 = COF2
-
-! d1 = .5*dzw(1)
-! d2 = dzw(1)+.5*dzw(2)
-! d3 = dzw(1)+dzw(2)+.5*dzw(3)
-! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- write(0,*) ' cf1, cf2, cf3 = ',cf1,cf2,cf3
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = (1.-ah(k))*(sh(k)*(zt-hx(k,iCell))+hx(k,iCell)) &
- + ah(k) * sh(k)* zt        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-!---- baroclinc wave initialization ---------------------------------
-!
-! reference sounding based on dry isothermal atmosphere
-!
- do i=1, grid % nCells
- !write(0,*) ' thermodynamic setup, cell ',i
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
- pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz(k,i))
- tb (k,i) = t0b/pb(k,i)
- rtb(k,i) = rb(k,i)*tb(k,i)
- p (k,i) = pb(k,i)
- pp (k,i) = 0.
- rr (k,i) = 0.
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
- enddo
- end if
-!
-! iterations to converge temperature as a function of pressure
-!
- do itr = 1,10
-
- do k=1,nz1
- eta (k) = (ppb(k,i)+pp(k,i))/p0
- etav(k) = (eta(k)-.252)*pii/2.
- if(eta(k).ge.znut) then
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
- end if
- end do
- phi = grid % latCell % array (i)
- do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- *sqrt(cos(etav(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(etav(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
-
-
- !write(0,*) ' k, tt(k) ',k,tt(k)
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- ptemp = ppb(k,i) + pp(k,i)
-! qv(k,i) = env_qv( ztemp, tt(k), ptemp, 0 )
- qv(k,i) = 0.
-
- end do
-! do k=2,nz1
-! cqw(k,i) = 1./(1.+.5*(qv(k,i)+qv(k-1,i)))
-! end do
-                
- do itrp = 1,25
- do k=1,nz1                                
- rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
- end do
-
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
-
- ppi(1) = ppi(1)-ppb(1,i)
- do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
- end do
-
- do k=1,nz1
- pp(k,i) = .2*ppi(k)+.8*pp(k,i)
- end do
-
- end do ! end inner iteration loop itrp
-
- end do ! end outer iteration loop itr
-
- do k=1,nz1        
- p (k,i) = ((ppb(k,i)+pp(k,i))/p0)**(rgas/cp)
- t (k,i) = tt(k)/p(k,i)
- rt (k,i) = t(k,i)*rr(k,i)+rb(k,i)*(t(k,i)-tb(k,i))
- rho (k,i) = rb(k,i) + rr(k,i)
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, p, t, rt ',k,p(k,1),t(k,1),rt(k,1)
- enddo
- end if
-
- end do ! end loop over cells
-
- 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)
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- 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
-!! etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
-! etavs = (0.5*(ppb(k,1)+ppb(k,1)+pp(k,1)+pp(k,1))/p0 - 0.252)*pii/2.
- etavs = (0.5*(ppb(k,440)+ppb(k,440)+pp(k,440)+pp(k,440))/p0 - 0.252)*pii/2. ! 10262 mesh
-! etavs = (0.5*(ppb(k,505)+ppb(k,505)+pp(k,505)+pp(k,505))/p0 - 0.252)*pii/2. ! 40962 mesh
-
- fluxk = u0*flux*(cos(etavs)**1.5)
-!! fluxk = u0*flux*(cos(znuv(k))**(1.5))
-!! fluxk = u0 * cos(grid % angleEdge % array(iEdge)) * (sin(lat1+lat2)**2) *(cos(etavs)**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
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
- do i=1,10
- psurf = (cf1*(ppb(1,i)+pp(1,i)) + cf2*(ppb(2,i)+pp(2,i)) + cf3*(ppb(3,i)+pp(3,i)))/100.
-
- psurf = (ppb(1,i)+pp(1,i)) + .5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
-
- write(0,*) ' i, psurf, lat ',i,psurf,grid%latCell%array(i)*180./3.1415828
- enddo
-! stop
-
- end subroutine nhyd_test_case_jw
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_squall_line(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup squall line and supercell test case
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
- real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- real (kind=RKIND) :: 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, rh, thi
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
- real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, ptopb, rcp, rcv
- real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, temp, pres, yloc, ymid, a_scale
-
- !
- ! Scale all distances
- !
-
- a_scale = 1.0
-
- grid % xCell % array = grid % xCell % array * a_scale
- grid % yCell % array = grid % yCell % array * a_scale
- grid % zCell % array = grid % zCell % array * a_scale
- grid % xVertex % array = grid % xVertex % array * a_scale
- grid % yVertex % array = grid % yVertex % array * a_scale
- grid % zVertex % array = grid % zVertex % array * a_scale
- grid % xEdge % array = grid % xEdge % array * a_scale
- grid % yEdge % array = grid % yEdge % array * a_scale
- grid % zEdge % array = grid % zEdge % array * a_scale
- grid % dvEdge % array = grid % dvEdge % array * a_scale
- grid % dcEdge % array = grid % dcEdge % array * a_scale
- grid % areaCell % array = grid % areaCell % array * a_scale**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- ppb => grid % pressure_base % array
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
- cqw => grid % cqw % array
-
- rho => state % rho % array
-
- pp => state % pressure % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
- u => state % u % array
- ru => grid % ru % array
-
- scalars => state % scalars % array
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
- rcp = rgas/cp
- rcv = rgas/(cp-rgas)
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- hx(k,iCell) = 0. ! squall line or supercell on flat plane
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.0
- zt = 20000.
- dz = zt/float(nz1)
-
- write(0,*) ' dz = ',dz
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- zc(k) = zt*(real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k)
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
-! zw(k) = float(k-1)*dz
- zw(k) = zc(k)
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
-! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
- ah(k) = 1.
-         write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
- + (1.-ah(k)) * zc(k)        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-! convective initialization
-!
- ztr = 12000.
- thetar = 343.
- ttr = 213.
- thetas = 300.5
-
- write(0,*) ' rgas, cp, gravity ',rgas,cp, gravity
-
-! no flow
-! um = 0.
-! us = 0.
-! zts = 5000.
-! supercell parameters
- um = 30.
- us = 15.
- zts = 5000.
-! squall-line parameters
- um = 12.
- us = 10.
- zts = 2500.
-
-
- do i=1,grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- if(ztemp .gt. ztr) then
- t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr))
- rh(k,i) = 0.25
- else
- t (k,i) = 300.+43.*(ztemp/ztr)**1.25
- rh(k,i) = (1.-0.75*(ztemp/ztr)**1.25)
- if(t(k,i).lt.thetas) t(k,i) = thetas
- end if
- tb(k,i) = t(k,i)
- end do
- end do
-
-! rh(:,:) = 0.
-
-! set the velocity field - we are on a plane here.
-
- do i=1, grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
- +zgrid(k,cell2)+zgrid(k+1,cell2))
- if(ztemp.lt.zts) then
- u(k,i) = um*ztemp/zts
- else
- u(k,i) = um
- end if
- if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
- u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
- end do
- end if
- end do
-!
-! reference sounding based on dry atmosphere
-!
- pitop = 1.-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*.5*(tb(k,1)+tb(k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
-        
- write(0,*) k,pitop,tb(k,1),dzu(k),tb(k,1)
- end do
- pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
-
- ptopb = p0*pitop**(1./rcp)
- write(6,*) 'ptopb = ',.01*ptopb
-                
- do i=1, grid % nCells
- pb(nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
- p (nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
- do k=nz1-1,1,-1
- pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- end do
- do k=1,nz1
- rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
- rtb(k,i) = rb(k,i)*tb(k,i)
- rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
- cqw(k,i) = 1.
- end do
- end do
-
- write(0,*) ' base state sounding '
- do k=1,grid%nVertLevels
- write(0,*) ' k, pb,rb,tb,rtb,t,rr,p ', k,pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1)
- end do
-
-!-------------------------------------------------------------------
-! ITERATIONS TO CONVERGE MOIST SOUNDING
-!
-! delt = -10.
-! delt = -0.01
- delt = 3.
- radx = 10000.
- radz = 1500.
- zcent = 1500.
- xmid = 150000.
- ymid = 50000.*cos(pii/6.)
-
- do i=1, grid % nCells
- xloc = grid % xCell % array(i) - xmid
- yloc = grid % yCell % array(i) - ymid
- yloc = 0.
-! xloc = 0.
- do k = 1,nz1
- thi(k,i) = t(k,i)
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- rad =sqrt((xloc/radx)**2+(yloc/radx)**2+((ztemp-zcent)/radz)**2)
- if(rad.lt.1) then
- thi(k,i) = t(k,i) + delt*cos(.5*pii*rad)**2
- end if
- end do
- end do
-
- do itr=1,30
- pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
- end do
- pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- ptop = p0*pitop**(1./rcp)
- write(0,*) 'ptop = ',.01*ptop
-
- do i = 1, grid % nCells
-
- pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
- (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
- do k=nz1-1,1,-1
- pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
- end do
- do k=1,nz1
- rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
- p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
- rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
- end do
-!
-! update water vapor mixing ratio from humitidty profile
-!
- do k=1,nz1
- temp = p(k,i)*thi(k,i)
- pres = p0*p(k,i)**(1./rcp)
- qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
- end do
-                        
- do k=1,nz1
- t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i))
- end do
- do k=2,nz1
- cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k-1,i) &
- +scalars(index_qv,k ,i)))
- end do
- end do ! iteration loop
-
- end do ! loop over cells
-!----------------------------------------------------------------------
-!
- write(0,*) ' sounding for the simulation '
- do k=1,nz1
- write(6,10) .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
- .01*p0*p(k,1)**(1./rcp),t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
- 1000.*scalars(index_qv,k,1),u(k,1)
- 10 format(1x,5f10.3)
-
- grid % t_init % array(k) = t(k,1)
- grid % qv_init % array(k) = scalars(index_qv,k,1)
-
- end do
-                
-!
- do i=1,grid % ncells
- do k=1,nz1
- rho(k,i) = rb(k,i)+rr(k,i)
- end do
- end do
-
- do i=1,grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ru (k,i) = 0.5*(rho(k,cell1)+rho(k,cell2))*u(k,i)
- end do
- end if
- end do
-
-!
-! CALCULATION OF OMEGA, RW = ZX * RU + ZZ * RW
-!
-! we are assuming w and rw are zero for this initialization
-! i.e., no terrain
-!
- grid % rw % array = 0.
- state % w % array = 0.
-
-! DO I=1,NX
-! IM1=I-1
-! IF(IPER.EQ.1.AND.I.EQ.1) IM1=NX1
-! RW(1 ,I) = 0.
-! RW(NZ,I) = 0.
-! DO K=2,NZ1
-! RW(K ,I) = (FZM(K)*ZZ(K,I)+FZP(K)*ZZ(K-1,I))*(
-! & -RDX*(RUZ(K,I )*(ZUW(K,I )-ZGRID(K,I))
-! & -RUZ(K,IM1)*(ZUW(K,IM1)-ZGRID(K,I))))
-! END DO
-! DO K=1,NZ
-! RW1(K,I) = RW(K,I)
-! END DO
-! END DO
-
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 0.
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 0.
- end do
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
-! do iCell = 1, grid % nCells
-! rt(5,iCell) = rt(5,iCell) + .1
-! enddo
-
-
- do k=1,grid%nVertLevels
- write(0,*) ' k,u_init, t_init, qv_init ',k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
- end do
-
- end subroutine nhyd_test_case_squall_line
-
- 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
-
-end module test_cases
Deleted: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.ok
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.ok        2010-07-12 19:38:09 UTC (rev 372)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.ok        2010-07-13 21:27:45 UTC (rev 373)
@@ -1,966 +0,0 @@
-module test_cases
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine setup_nhyd_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 nonhydrostatic 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))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_jw(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 4 ) then
-
- write(0,*) ' squall line - super cell test case '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_squall_line(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
-
- write(0,*) ' Only test case 1, 2, 3 and 4 are currently supported for nonhydrostatic core '
- stop
- end if
-
- end subroutine setup_nhyd_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_jw(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
- real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
-
- !
- ! 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
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
-
- ppb => grid % pressure_base % array
- pp => state % pressure % array
-
- rho => state % rho % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
-
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- phi = grid % latCell % array (iCell)
- hx(k,iCell) = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.5
- zt = 45000.
- dz = zt/float(nz1)
-
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- sh(k) = (real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k) and define sh(k) = zc(k)/zt
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
- zw(k) = float(k-1)*dz
-! zw(k) = sh(k)*zt
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
- ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
-! ah(k) = 0.
-         write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = (1.-ah(k))*(sh(k)*(zt-hx(k,iCell))+hx(k,iCell)) &
- + ah(k) * sh(k)* zt        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-!---- baroclinc wave initialization ---------------------------------
-!
-! reference sounding based on dry isothermal atmosphere
-!
- do i=1, grid % nCells
- !write(0,*) ' thermodynamic setup, cell ',i
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
- pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz(k,i))
- tb (k,i) = t0b/pb(k,i)
- rtb(k,i) = rb(k,i)*tb(k,i)
- p (k,i) = pb(k,i)
- pp (k,i) = 0.
- rr (k,i) = 0.
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
- enddo
- end if
-!
-! iterations to converge temperature as a function of pressure
-!
- do itr = 1,10
-
- do k=1,nz1
- eta (k) = (ppb(k,i)+pp(k,i))/p0
- etav(k) = (eta(k)-.252)*pii/2.
- if(eta(k).ge.znut) then
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
- end if
- end do
- phi = grid % latCell % array (i)
- do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- *sqrt(cos(etav(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(etav(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
-
-
- !write(0,*) ' k, tt(k) ',k,tt(k)
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- ptemp = ppb(k,i) + pp(k,i)
-! qv(k,i) = env_qv( ztemp, tt(k), ptemp, 0 )
- qv(k,i) = 0.
-
- end do
-! do k=2,nz1
-! cqw(k,i) = 1./(1.+.5*(qv(k,i)+qv(k-1,i)))
-! end do
-                
- do itrp = 1,25
- do k=1,nz1                                
- rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
- end do
-
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
-
- ppi(1) = ppi(1)-ppb(1,i)
- do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
- end do
-
- do k=1,nz1
- pp(k,i) = .2*ppi(k)+.8*pp(k,i)
- end do
-
- end do ! end inner iteration loop itrp
-
- end do ! end outer iteration loop itr
-
- do k=1,nz1        
- p (k,i) = ((ppb(k,i)+pp(k,i))/p0)**(rgas/cp)
- t (k,i) = tt(k)/p(k,i)
- rt (k,i) = t(k,i)*rr(k,i)+rb(k,i)*(t(k,i)-tb(k,i))
- rho (k,i) = rb(k,i) + rr(k,i)
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, p, t, rt ',k,p(k,1),t(k,1),rt(k,1)
- enddo
- end if
-
- end do ! end loop over cells
-
- 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)
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- 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
- etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
-
- fluxk = u0*flux*(cos(etavs)**1.5)
-! 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
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
-
- end subroutine nhyd_test_case_jw
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_squall_line(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
- real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- real (kind=RKIND) :: 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, rh
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt, thi
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
- real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, ptopb, rcp, rcv
- real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, temp, pres, yloc, ymid, a_scale
-
- !
- ! Scale all distances
- !
-
- a_scale = 1.0
-
- grid % xCell % array = grid % xCell % array * a_scale
- grid % yCell % array = grid % yCell % array * a_scale
- grid % zCell % array = grid % zCell % array * a_scale
- grid % xVertex % array = grid % xVertex % array * a_scale
- grid % yVertex % array = grid % yVertex % array * a_scale
- grid % zVertex % array = grid % zVertex % array * a_scale
- grid % xEdge % array = grid % xEdge % array * a_scale
- grid % yEdge % array = grid % yEdge % array * a_scale
- grid % zEdge % array = grid % zEdge % array * a_scale
- grid % dvEdge % array = grid % dvEdge % array * a_scale
- grid % dcEdge % array = grid % dcEdge % array * a_scale
- grid % areaCell % array = grid % areaCell % array * a_scale**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- ppb => grid % pressure_base % array
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
- cqw => grid % cqw % array
-
- rho => state % rho % array
-
- pp => state % pressure % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
- u => state % u % array
- ru => grid % ru % array
-
- scalars => state % scalars % array
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
- rcp = rgas/cp
- rcv = rgas/(cp-rgas)
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- hx(k,iCell) = 0. ! squall line or supercell on flat plane
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.0
- zt = 20000.
- dz = zt/float(nz1)
-
- write(0,*) ' dz = ',dz
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- zc(k) = zt*(real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k)
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
-! zw(k) = float(k-1)*dz
- zw(k) = zc(k)
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
-! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
- ah(k) = 1.
-         write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
- + (1.-ah(k)) * zc(k)        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-! convective initialization
-!
- ztr = 12000.
- thetar = 343.
- ttr = 213.
- thetas = 300.5
-
- write(0,*) ' rgas, cp, gravity ',rgas,cp, gravity
-
-! no flow
- um = 0.
- us = 0.
- zts = 5000.
-! supercell parameters
-! um = 30.
-! us = 15.
-! zts = 5000.
-! squall-line parameters
-! um = 12.
-! us = 10.
-! zts = 2500.
-
-
- do i=1,grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- if(ztemp .gt. ztr) then
- t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr))
- rh(k,i) = 0.25
- else
- t (k,i) = 300.+43.*(ztemp/ztr)**1.25
- rh(k,i) = (1.-0.75*(ztemp/ztr)**1.25)
- if(t(k,i).lt.thetas) t(k,i) = thetas
- end if
- tb(k,i) = t(k,i)
- end do
- end do
-
-! set the velocity field - we are on a plane here.
-
- do i=1, grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
- +zgrid(k,cell2)+zgrid(k+1,cell2))
- if(ztemp.lt.zts) then
- u(k,i) = um*ztemp/zts
- else
- u(k,i) = um
- end if
- u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
- end do
- end if
- end do
-!
-! reference sounding based on dry atmosphere
-!
- pitop = 1.-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*.5*(tb(k,1)+tb(k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
-        
- write(0,*) k,pitop,tb(k,1),dzu(k),tb(k,1)
- end do
- pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
-
- ptopb = p0*pitop**(1./rcp)
- write(6,*) 'ptopb = ',.01*ptopb
-                
- do i=1, grid % nCells
- pb(nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
- p (nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
- do k=nz1-1,1,-1
- pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- end do
- do k=1,nz1
- rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
- rtb(k,i) = rb(k,i)*tb(k,i)
- rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
- cqw(k,i) = 1.
- end do
- end do
-
- write(0,*) ' base state sounding '
- do k=1,grid%nVertLevels
- write(0,*) ' k, pb,rb,tb,rtb,t,rr,p ', k,pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1)
- end do
-
-!-------------------------------------------------------------------
-! ITERATIONS TO CONVERGE MOIST SOUNDING
-!
-! delt = -15.
- delt = 0.
- radx = 10000.
- radz = 1500.
- zcent = 1500.
- xmid = 20000.
- ymid = 20000.
-
- do i = 1, grid % nCells
- xloc = grid % xCell % array(i) - xmid
- yloc = grid % yCell % array(i) - ymid
- do k = 1,nz1
- thi(k) = t(k,i)
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- rad =sqrt((xloc/radx)**2+(yloc/radx)**2+((ztemp-zcent)/radz)**2)
- if(rad.lt.1) then
- thi(k) = t(k,i) + delt*cos(.5*pii*rad)**2
- end if
- end do
-
- do itr=1,30
-                
- if(i.eq.1) then
- pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
- end do
- pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- ptop = p0*pitop**(1./rcp)
- write(0,*) 'ptop = ',.01*ptop
- end if
-
- pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
- (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
- do k=nz1-1,1,-1
- pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
- end do
- do k=1,nz1
- rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
- p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
- rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
- end do
-!
-! update water vapor mixing ratio from humitidty profile
-!
- do k=1,nz1
- temp = p(k,1)*thi(k)
- pres = p0*p(k,1)**(1./rcp)
- qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,1) = amin1(0.014,rh(k,1)*qvs)
- end do
-
-                        
- do k=1,nz1
- t (k,i) = thi(k)*(1.+1.61*scalars(index_qv,k,i))
- end do
- do k=2,nz1
- cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k ,i) &
- +scalars(index_qv,k ,i)))
- end do
- end do ! iteration loop
-
- end do ! loop over cells
-!----------------------------------------------------------------------
-!
- write(0,*) ' sounding for the simulation '
- do k=1,nz1
- write(6,10) .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
- .01*p0*p(k,1)**(1./rcp),t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
- 1000.*scalars(index_qv,k,1),u(k,1)
- 10 format(1x,5f10.3)
- end do
-                
-!
- do i=1,grid % ncells
- do k=1,nz1
- rho(k,i) = rb(k,i)+rr(k,i)
- end do
- end do
-
- do i=1,grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ru (k,i) = 0.5*(rho(k,cell1)+rho(k,cell2))*u(k,i)
- end do
- end if
- end do
-
-!
-! CALCULATION OF OMEGA, RW = ZX * RU + ZZ * RW
-!
-! we are assuming w and rw are zero for this initialization
-! i.e., no terrain
-!
- grid % rw % array = 0.
-
-! DO I=1,NX
-! IM1=I-1
-! IF(IPER.EQ.1.AND.I.EQ.1) IM1=NX1
-! RW(1 ,I) = 0.
-! RW(NZ,I) = 0.
-! DO K=2,NZ1
-! RW(K ,I) = (FZM(K)*ZZ(K,I)+FZP(K)*ZZ(K-1,I))*(
-! & -RDX*(RUZ(K,I )*(ZUW(K,I )-ZGRID(K,I))
-! & -RUZ(K,IM1)*(ZUW(K,IM1)-ZGRID(K,I))))
-! END DO
-! DO K=1,NZ
-! RW1(K,I) = RW(K,I)
-! END DO
-! END DO
-
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 0.
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 0.
- end do
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
- end subroutine nhyd_test_case_squall_line
-
- 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
-
-end module test_cases
Deleted: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.sh0614
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.sh0614        2010-07-12 19:38:09 UTC (rev 372)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.sh0614        2010-07-13 21:27:45 UTC (rev 373)
@@ -1,998 +0,0 @@
-module test_cases
-
- use grid_types
- use configure
- use constants
-
-
- contains
-
-
- subroutine setup_nhyd_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 nonhydrostatic 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))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_jw(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else if (config_test_case == 4 ) then
-
- write(0,*) ' squall line - super cell test case '
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- write(0,*) ' calling test case setup '
- call nhyd_test_case_squall_line(block_ptr % mesh, block_ptr % time_levs(1) % state, config_test_case)
- write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call copy_state(block_ptr % time_levs(1) % state, block_ptr % time_levs(i) % state)
- end do
-
- block_ptr => block_ptr % next
- end do
-
- else
-
- write(0,*) ' Only test case 1, 2, 3 and 4 are currently supported for nonhydrostatic core '
- stop
- end if
-
- end subroutine setup_nhyd_test_case
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_jw(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
- real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
-
- !
- ! 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
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
-
- ppb => grid % pressure_base % array
- pp => state % pressure % array
-
- rho => state % rho % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
-
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- phi = grid % latCell % array (iCell)
- hx(k,iCell) = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.5
- zt = 45000.
- dz = zt/float(nz1)
-
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- sh(k) = (real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k) and define sh(k) = zc(k)/zt
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
- zw(k) = float(k-1)*dz
-! zw(k) = sh(k)*zt
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
- ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
-! ah(k) = 0.
-         write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = (1.-ah(k))*(sh(k)*(zt-hx(k,iCell))+hx(k,iCell)) &
- + ah(k) * sh(k)* zt        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
-
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
-
- write(0,*) ' grid metrics setup complete '
-!
-!---- baroclinc wave initialization ---------------------------------
-!
-! reference sounding based on dry isothermal atmosphere
-!
- do i=1, grid % nCells
- !write(0,*) ' thermodynamic setup, cell ',i
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
- pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz(k,i))
- tb (k,i) = t0b/pb(k,i)
- rtb(k,i) = rb(k,i)*tb(k,i)
- p (k,i) = pb(k,i)
- pp (k,i) = 0.
- rr (k,i) = 0.
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
- enddo
- end if
-!
-! iterations to converge temperature as a function of pressure
-!
- do itr = 1,10
-
- do k=1,nz1
- eta (k) = (ppb(k,i)+pp(k,i))/p0
- etav(k) = (eta(k)-.252)*pii/2.
- if(eta(k).ge.znut) then
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity)
- else
- teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
- end if
- end do
- phi = grid % latCell % array (i)
- do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- *sqrt(cos(etav(k)))* &
- ((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *2.*u0*cos(etav(k))**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
-
-
- !write(0,*) ' k, tt(k) ',k,tt(k)
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- ptemp = ppb(k,i) + pp(k,i)
-! qv(k,i) = env_qv( ztemp, tt(k), ptemp, 0 )
- qv(k,i) = 0.
-
- end do
-! do k=2,nz1
-! cqw(k,i) = 1./(1.+.5*(qv(k,i)+qv(k-1,i)))
-! end do
-                
- do itrp = 1,25
- do k=1,nz1                                
- rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
- end do
-
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
-
- ppi(1) = ppi(1)-ppb(1,i)
- do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
- end do
-
- do k=1,nz1
- pp(k,i) = .2*ppi(k)+.8*pp(k,i)
- end do
-
- end do ! end inner iteration loop itrp
-
- end do ! end outer iteration loop itr
-
- do k=1,nz1        
- p (k,i) = ((ppb(k,i)+pp(k,i))/p0)**(rgas/cp)
- t (k,i) = tt(k)/p(k,i)
- rt (k,i) = t(k,i)*rr(k,i)+rb(k,i)*(t(k,i)-tb(k,i))
- rho (k,i) = rb(k,i) + rr(k,i)
- end do
-
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, p, t, rt ',k,p(k,1),t(k,1),rt(k,1)
- enddo
- end if
-
- end do ! end loop over cells
-
- 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)
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- 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
- etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
-
- fluxk = u0*flux*(cos(etavs)**1.5)
-! 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
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
-
- end subroutine nhyd_test_case_jw
-
-!----------------------------------------------------------------------------------------------------------
-
- subroutine nhyd_test_case_squall_line(grid, state, test_case)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_meta), intent(inout) :: grid
- type (grid_state), 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 :: t0b = 250., 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 :: rdzw, dzu, rdzu, fzm, fzp
- real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx, cqw
- real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars
-
- integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
-
- !This is temporary variable here. It just need when calculate tangential velocity v.
- integer :: eoe, j
- integer, dimension(:), pointer :: nEdgesOnEdge
- integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
-
- real (kind=RKIND) :: 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) :: r_earth, etavs, ztemp, zd, zt, dz, gam, str
-
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, rh, thi
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
- integer :: iter
-
- 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
-
- real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
- real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
-
- real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3
- real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, ptopb, rcp, rcv
- real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, temp, pres, yloc, ymid, a_scale
-
- !
- ! Scale all distances
- !
-
- a_scale = 1.0
-
- grid % xCell % array = grid % xCell % array * a_scale
- grid % yCell % array = grid % yCell % array * a_scale
- grid % zCell % array = grid % zCell % array * a_scale
- grid % xVertex % array = grid % xVertex % array * a_scale
- grid % yVertex % array = grid % yVertex % array * a_scale
- grid % zVertex % array = grid % zVertex % array * a_scale
- grid % xEdge % array = grid % xEdge % array * a_scale
- grid % yEdge % array = grid % yEdge % array * a_scale
- grid % zEdge % array = grid % zEdge % array * a_scale
- grid % dvEdge % array = grid % dvEdge % array * a_scale
- grid % dcEdge % array = grid % dcEdge % array * a_scale
- grid % areaCell % array = grid % areaCell % array * a_scale**2.0
- grid % areaTriangle % array = grid % areaTriangle % array * a_scale**2.0
- grid % kiteAreasOnVertex % array = grid % kiteAreasOnVertex % array * a_scale**2.0
-
- weightsOnEdge => grid % weightsOnEdge % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
-
- nz1 = grid % nVertLevels
- nz = nz1 + 1
- nCellsSolve = grid % nCellsSolve
-
- zgrid => grid % zgrid % array
- rdzw => grid % rdzw % array
- dzu => grid % dzu % array
- rdzu => grid % rdzu % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zx => grid % zx % array
- zz => grid % zz % array
- hx => grid % hx % array
- dss => grid % dss % array
-
- ppb => grid % pressure_base % array
- pb => grid % exner_base % array
- rb => grid % rho_base % array
- tb => grid % theta_base % array
- rtb => grid % rtheta_base % array
- p => grid % exner % array
- cqw => grid % cqw % array
-
- rho => state % rho % array
-
- pp => state % pressure % array
- rr => state % rho_p % array
- t => state % theta % array
- rt => grid % rtheta_p % array
- u => state % u % array
- ru => grid % ru % array
-
- scalars => state % scalars % array
-
- scalars(:,:,:) = 0.
-
- xnutr = 0.
- zd = 12000.
- znut = eta_t
-
- etavs = (1.-0.252)*pii/2.
- r_earth = a
- p0 = 1.e+05
- rcp = rgas/cp
- rcv = rgas/(cp-rgas)
-
- write(0,*) ' point 1 in test case setup '
-
-! We may pass in an hx(:,:) that has been precomputed elsewhere.
-! For now it is independent of k
-
- do iCell=1,grid % nCells
- do k=1,nz
- hx(k,iCell) = 0. ! squall line or supercell on flat plane
- enddo
- enddo
-
- ! metrics for hybrid coordinate and vertical stretching
-
- str = 1.0
- zt = 20000.
- dz = zt/float(nz1)
-
- write(0,*) ' dz = ',dz
- write(0,*) ' hx computation complete '
-
- do k=1,nz
-                
-! sh(k) is the stretching specified for height surfaces
-
- zc(k) = zt*(real(k-1)*dz/zt)**str
-                                
-! to specify specific heights zc(k) for coordinate surfaces,
-! input zc(k)
-! zw(k) is the hieght of zeta surfaces
-! zw(k) = (k-1)*dz yields constant dzeta
-! and nonconstant dzeta/dz
-! zw(k) = sh(k)*zt yields nonconstant dzeta
-! and nearly constant dzeta/dz
-
-! zw(k) = float(k-1)*dz
- zw(k) = zc(k)
-!
-! ah(k) governs the transition between terrain-following
-! and pureheight coordinates
-! ah(k) = 0 is a terrain-following coordinate
-! ah(k) = 1 is a height coordinate
-
-! ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
- ah(k) = 1.
-         write(0,*) ' k, zc, zw, ah ',k,zc(k),zw(k),ah(k)                        
- end do
- do k=1,nz1
- dzw (k) = zw(k+1)-zw(k)
- rdzw(k) = 1./dzw(k)
- zu(k ) = .5*(zw(k)+zw(k+1))
- end do
- do k=2,nz1
- dzu (k) = .5*(dzw(k)+dzw(k-1))
- rdzu(k) = 1./dzu(k)
- fzp (k) = .5* dzw(k )/dzu(k)
- fzm (k) = .5* dzw(k-1)/dzu(k)
- rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1)))
- rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1)))
- end do
-
-!********** how are we storing cf1, cf2 and cf3?
-
- d1 = .5*dzw(1)
- d2 = dzw(1)+.5*dzw(2)
- d3 = dzw(1)+dzw(2)+.5*dzw(3)
- cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
-
- do iCell=1,grid % nCells
- do k=1,nz        
- zgrid(k,iCell) = ah(k)*(zc(k)*(1.-hx(k,iCell)/zt)+hx(k,iCell)) &
- + (1.-ah(k)) * zc(k)        
- end do
- do k=1,nz1
- zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell))
- end do
- end do
-
- do i=1, grid % nEdges
- iCell1 = grid % CellsOnEdge % array(1,i)
- iCell2 = grid % CellsOnEdge % array(2,i)
- do k=1,nz
- zx (k,i) = (zgrid(k,iCell2)-zgrid(k,iCell1)) / grid % dcEdge % array(i)
- end do
- end do
- do i=1, grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- dss(k,i) = 0.
- ztemp = zgrid(k,i)
- if(ztemp.gt.zd+.1) then
- dss(k,i) = dss(k,i)+xnutr*sin(.5*pii*(ztemp-zd)/(zt-zd))**2
- end if
- end do
- enddo
-
-! do k=1,nz1
-! write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
-! enddo
-
-! do k=1,nz1
-! write(0,*) ' k, zx(k,1) ',k,zx(k,1)
-! enddo
-
-! write(0,*) ' grid metrics setup complete '
-!
-! convective initialization
-!
- ztr = 12000.
- thetar = 343.
- ttr = 213.
- thetas = 300.5
-
- write(0,*) ' rgas, cp, gravity ',rgas,cp, gravity
-
-! no flow
-! um = 0.
-! us = 0.
-! zts = 5000.
-! supercell parameters
- um = 30.
- us = 15.
-! us = 0.
- zts = 5000.
-! squall-line parameters
-! um = 12.
-! us = 10.
-! zts = 2500.
-
-
- do i=1,grid % nCells
- do k=1,nz1
- ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
- if(ztemp .gt. ztr) then
- t (k,i) = thetar*exp(9.8*(ztemp-ztr)/(1003.*ttr))
- rh(k,i) = 0.25
- else
- t (k,i) = 300.+43.*(ztemp/ztr)**1.25
- rh(k,i) = (1.-0.75*(ztemp/ztr)**1.25)
- if(t(k,i).lt.thetas) t(k,i) = thetas
- end if
- tb(k,i) = t(k,i)
- end do
- end do
-
-! rh(:,:) = 0.
-
-! set the velocity field - we are on a plane here.
-
- do i=1, grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) &
- +zgrid(k,cell2)+zgrid(k+1,cell2))
- if(ztemp.lt.zts) then
- u(k,i) = um*ztemp/zts
- else
- u(k,i) = um
- end if
- if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
- u(k,i) = sin(grid % angleEdge % array(i)) * (u(k,i) - us)
- end do
- end if
- end do
-!
-! reference sounding based on dry atmosphere
-!
- write(0,*) "k, pitop, tb(k,1), dzu(k)"
- pitop = 1.-.5*dzw(1)*gravity/(cp*tb(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*.5*(tb(k,1)+tb(k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
-        
- write(0,*) k,pitop,tb(k,1),dzu(k)
- end do
- pitop = pitop-.5*dzw(nz1)*gravity/(cp*tb(nz1,1)*zz(nz1,1))
-
- ptopb = p0*pitop**(1./rcp)
- write(6,*) 'ptopb = ',.01*ptopb
-                
- do i=1, grid % nCells
- pb(nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*tb(nz1,i)*zz(nz1,i))
- p (nz1,i) = pitop+.5*dzw(nz1)*gravity/(cp*t (nz1,i)*zz(nz1,i))
- do k=nz1-1,1,-1
- pb(k,i) = pb(k+1,i) + dzu(k+1)*gravity/(cp*.5*(tb(k,i)+tb(k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- p (k,i) = p (k+1,i) + dzu(k+1)*gravity/(cp*.5*(t (k,i)+t (k+1,i)) &
- *.5*(zz(k,i)+zz(k+1,i)))
- end do
- do k=1,nz1
- rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
- rtb(k,i) = rb(k,i)*tb(k,i)
- rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
- cqw(k,i) = 1.
- end do
- end do
-
- write(0,*) ' base state sounding '
- do k=1,grid%nVertLevels
- write(0,*) ' k, pb,rb,tb,rtb,t,rr,p ', k,pb(k,1),rb(k,1),tb(k,1),rtb(k,1),t(k,1),rr(k,1),p(k,1)
- end do
-
-!-------------------------------------------------------------------
-! ITERATIONS TO CONVERGE MOIST SOUNDING
-!
-! delt = -10.
-! delt = -0.01
- delt = 3.
- radx = 10000.
- radz = 1500.
- zcent = 1500.
- !xmid = 50000.
- !ymid = 50000.*cos(pii/6.)
- xmid = maxval (grid % xCell % array(:))/2.
- ymid = maxval (grid % yCell % array(:))/2.
-
- do i=1, grid % nCells
- xloc = grid % xCell % array(i) - xmid
- yloc = grid % yCell % array(i) - ymid
-! yloc = 0.
-! xloc = 0.
- do k = 1,nz1
- thi(k,i) = t(k,i)
- ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
- rad =sqrt((xloc/radx)**2+(yloc/radx)**2+((ztemp-zcent)/radz)**2)
- if(rad.lt.1) then
- thi(k,i) = t(k,i) + delt*cos(.5*pii*rad)**2
- end if
- end do
- end do
-
- do itr=1,30
- pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1))
- do k=2,nz1
- pitop = pitop-dzu(k)*gravity/(cp*cqw(k,1)*.5*(t (k,1)+t (k-1,1)) &
- *.5*(zz(k,1)+zz(k-1,1)))
- end do
- pitop = pitop - .5*dzw(nz1)*gravity*(1.+scalars(index_qv,nz1,1))/(cp*t(nz1,1)*zz(nz1,1))
- ptop = p0*pitop**(1./rcp)
- write(0,*) 'ptop = ',.01*ptop
-
- do i = 1, grid % nCells
-
- pp(nz1,i) = ptop-ptopb+.5*dzw(nz1)*gravity* &
- (rr(nz1,i)+(rr(nz1,i)+rb(nz1,i))*scalars(index_qv,nz1,i))
- do k=nz1-1,1,-1
- pp(k,i) = pp(k+1,i)+.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
- end do
- do k=1,nz1
- rt(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rtb(k,i)*(p(k,i)-pb(k,i)))/p(k,i)
- p (k,i) = (zz(k,i)*(rgas/p0)*(rtb(k,i)+rt(k,i)))**rcv
- rr(k,i) = (rt(k,i)-rb(k,i)*(t(k,i)-tb(k,i)))/t(k,i)
- end do
-!
-! update water vapor mixing ratio from humitidty profile
-!
- do k=1,nz1
- temp = p(k,i)*thi(k,i)
- pres = p0*p(k,i)**(1./rcp)
- qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
- end do
-                        
- do k=1,nz1
- t (k,i) = thi(k,i)*(1.+1.61*scalars(index_qv,k,i))
- end do
- do k=2,nz1
- cqw(k,i) = 1./(1.+.5*( scalars(index_qv,k-1,i) &
- +scalars(index_qv,k ,i)))
- end do
- end do ! iteration loop
-
- end do ! loop over cells
-!----------------------------------------------------------------------
-!
- write(0,*) ' sounding for the simulation '
- do k=1,nz1
- write(6,166) .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
- t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
- 1000.*scalars(index_qv,k,1), &
- (rb(k,1)+rr(k,1))*(1.+scalars(index_qv,k,1)), &
- u(k,1)
- 166 format(1x,f7.3,2x,f9.5,2x,f8.5,2x,f7.5,2x,f9.5)
- end do
-
- do k=1,nz1
- write(6,10) .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
- .01*p0*p(k,1)**(1./rcp),t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
- 1000.*scalars(index_qv,k,1),u(k,1)
- 10 format(1x,5f10.3)
-
- grid % t_init % array(k) = t(k,1)
- grid % qv_init % array(k) = scalars(index_qv,k,1)
-
- end do
-                
-!
- do i=1,grid % ncells
- do k=1,nz1
- rho(k,i) = rb(k,i)+rr(k,i)
- end do
- end do
-
- do i=1,grid % nEdges
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- ru (k,i) = 0.5*(rho(k,cell1)+rho(k,cell2))*u(k,i)
- end do
- end if
- end do
-
-!
-! CALCULATION OF OMEGA, RW = ZX * RU + ZZ * RW
-!
-! we are assuming w and rw are zero for this initialization
-! i.e., no terrain
-!
- grid % rw % array = 0.
- state % w % array = 0.
-
-! DO I=1,NX
-! IM1=I-1
-! IF(IPER.EQ.1.AND.I.EQ.1) IM1=NX1
-! RW(1 ,I) = 0.
-! RW(NZ,I) = 0.
-! DO K=2,NZ1
-! RW(K ,I) = (FZM(K)*ZZ(K,I)+FZP(K)*ZZ(K-1,I))*(
-! & -RDX*(RUZ(K,I )*(ZUW(K,I )-ZGRID(K,I))
-! & -RUZ(K,IM1)*(ZUW(K,IM1)-ZGRID(K,I))))
-! END DO
-! DO K=1,NZ
-! RW1(K,I) = RW(K,I)
-! END DO
-! END DO
-
-
- !
- ! Generate rotated Coriolis field
- !
- do iEdge=1,grid % nEdges
- grid % fEdge % array(iEdge) = 0.
- end do
-
- do iVtx=1,grid % nVertices
- grid % fVertex % array(iVtx) = 0.
- end do
-
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
- state % v % array(:,:) = 0.0
- do iEdge = 1, grid%nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- state % v % array(k,iEdge) = state % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
- end do
- end do
-
-! do iCell = 1, grid % nCells
-! rt(5,iCell) = rt(5,iCell) + .1
-! enddo
-
-
- do k=1,grid%nVertLevels
- write(0,*) ' k,u_init, t_init, qv_init ',k,grid % u_init % array(k),grid % t_init% array(k),grid % qv_init % array(k)
- end do
-
- end subroutine nhyd_test_case_squall_line
-
- 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
-
-end module test_cases
Deleted: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.0531
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.0531        2010-07-12 19:38:09 UTC (rev 372)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.0531        2010-07-13 21:27:45 UTC (rev 373)
@@ -1,2861 +0,0 @@
-module time_integration
-
- use grid_types
- use configure
- use constants
- use dmpar
-
-
- contains
-
-
- subroutine timestep(domain, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! 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
-
- 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 % time_levs(2) % state % xtime % scalar = block % time_levs(1) % state % xtime % scalar + dt
- 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, iEdge
- 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 = .true.
- logical, parameter :: debug_mass_conservation = .true.
- logical, parameter :: do_microphysics = .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 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))
- ! We are setting values in the halo here, so no communications are needed.
- ! Alternatively, we could just set owned cells and edge values and communicate after this block loop.
- call rk_integration_setup( block % time_levs(2) % state, block % time_levs(1) % state, block % mesh )
- block => block % next
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- do rk_step = 1, 3 ! Runge-Kutta loop
-
- if(debug) write(0,*) ' rk substep ', rk_step
-
- block => domain % blocklist
- do while (associated(block))
- ! The coefficients are set for owned cells (cqw) and for all edges of owned cells,
- ! thus no communications should be needed after this call.
- ! We could consider combining this and the next block loop.
- call compute_moist_coefficients( block % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
-
- if (debug) write(0,*) ' compute_dyn_tend '
- block => domain % blocklist
- do while (associated(block))
- call compute_dyn_tend( block % intermediate_step(TEND), block % time_levs(2) % state, block % mesh )
- block => block % next
- end do
- if (debug) write(0,*) ' finished compute_dyn_tend '
-
-!***********************************
-! we will need to communicate the momentum tendencies here - we want tendencies for all edges of owned cells
-! because we are solving for all edges of owned cells
-!***********************************
-
- block => domain % blocklist
- do while (associated(block))
- call set_smlstep_pert_variables( block % time_levs(1) % state, block % time_levs(2) % state, &
- block % intermediate_step(TEND), block % mesh )
- call compute_vert_imp_coefs( block % time_levs(2) % state, block % mesh, rk_sub_timestep(rk_step) )
- block => block % next
- end do
-
- do small_step = 1, number_sub_steps(rk_step)
-
- if(debug) write(0,*) ' acoustic step ',small_step
-
- block => domain % blocklist
- do while (associated(block))
- call advance_acoustic_step( block % time_levs(2) % state, block % intermediate_step(TEND), &
- block % mesh, rk_sub_timestep(rk_step) )
- block => block % next
- end do
-
- if(debug) write(0,*) ' acoustic step complete '
-
- ! will need communications here for rtheta_pp
-
- end do ! end of small stimestep loop
-
- ! will need communications here for rho_pp
-
- block => domain % blocklist
- do while (associated(block))
- call recover_large_step_variables( block % time_levs(2) % state, &
- block % mesh, rk_sub_timestep(rk_step), &
- number_sub_steps(rk_step) )
- block => block % next
- end do
-
-! ************ advection of moist variables here...
-
- 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 % intermediate_step(TEND), &
- block % time_levs(1) % state, block % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step) )
- else
- call advance_scalars_mono( block % intermediate_step(TEND), &
- block % time_levs(1) % state, block % 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 compute_solve_diagnostics( dt, block % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
- if(debug) write(0,*) ' diagnostics complete '
-
-
- ! need communications here to fill out u, w, theta, p, and pp, scalars, etc
- ! so that they are available for next RK step or the first rk substep of the next timestep
-
- end do ! rk_step loop
-
-! microphysics here...
-
- if(do_microphysics) then
- block => domain % blocklist
- do while (associated(block))
- call qd_kessler( block % time_levs(1) % state, block % time_levs(2) % state, block % mesh, dt )
- block => block % next
- end do
- end if
-
-! if(debug) then
- block => domain % blocklist
- do while (associated(block))
- scalar_min = 0.
- scalar_max = 0.
- do iCell = 1, block % mesh % nCellsSolve
- do k = 1, block % mesh % nVertLevels
- scalar_min = min(scalar_min, block % time_levs(2) % state % w % array(k,iCell))
- scalar_max = max(scalar_max, block % time_levs(2) % state % w % array(k,iCell))
- enddo
- enddo
- write(6,*) ' min, max w ',scalar_min, scalar_max
-
- scalar_min = 0.
- scalar_max = 0.
- do iEdge = 1, block % mesh % nEdgesSolve
- do k = 1, block % mesh % nVertLevels
- scalar_min = min(scalar_min, block % time_levs(2) % state % u % array(k,iEdge))
- scalar_max = max(scalar_max, block % time_levs(2) % state % u % array(k,iEdge))
- enddo
- enddo
- write(6,*) ' min, max u ',scalar_min, scalar_max
-
- scalar_min = 0.
- scalar_max = 0.
- do iCell = 1, block % mesh % nCellsSolve
- do k = 1, block % mesh % nVertLevels
- scalar_min = min(scalar_min, block % time_levs(2) % state % scalars % array(index_qc,k,iCell))
- scalar_max = max(scalar_max, block % time_levs(2) % state % scalars % array(index_qc,k,iCell))
- enddo
- enddo
- write(6,*) ' min, max qc ',scalar_min, scalar_max
-
- block => block % next
-
- end do
-! end if
-
-
- end subroutine srk3
-
-!---
-
- subroutine rk_integration_setup( s_old, s_new, grid )
-
- implicit none
- type (grid_state) :: s_new, s_old
- type (grid_meta) :: grid
- integer :: iCell, k
-
- grid % ru_save % array = grid % ru % array
- grid % rw_save % array = grid % rw % array
- grid % rtheta_p_save % array = grid % rtheta_p % array
- grid % rho_p_save % array = s_new % rho_p % array
-
- s_old % u % array = s_new % u % array
- s_old % w % array = s_new % w % array
- s_old % theta % array = s_new % theta % array
- s_old % rho_p % array = s_new % rho_p % array
- s_old % rho % array = s_new % rho % array
- s_old % pressure % array = s_new % pressure % array
-
-
- s_old % scalars % array = s_new % scalars % array
-
- end subroutine rk_integration_setup
-
-!-----
-
- subroutine compute_moist_coefficients( state, grid )
-
- implicit none
- type (grid_state) :: state
- type (grid_meta) :: grid
-
- integer :: iEdge, iCell, k, cell1, cell2, iq
- integer :: nCells, nEdges, nVertLevels, nCellsSolve
- real (kind=RKIND) :: qtot
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
- nCellsSolve = grid % nCellsSolve
-
- do iCell = 1, nCellsSolve
- do k = 2, nVertLevels
- qtot = 0.
- do iq = moist_start, moist_end
- qtot = qtot + 0.5 * (state % scalars % array (iq, k, iCell) + state % scalars % array (iq, k-1, iCell))
- end do
- grid % cqw % array(k,iCell) = 1./(1.+qtot)
- end do
- end do
-
- do iEdge = 1, nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k = 1, nVertLevels
- qtot = 0.
- do iq = moist_start, moist_end
- qtot = qtot + 0.5 * ( state % scalars % array (iq, k, cell1) + state % scalars % array (iq, k, cell2) )
- end do
- grid % cqu % array(k,iEdge) = 1./( 1. + qtot)
- end do
- end if
- end do
-
- end subroutine compute_moist_coefficients
-
-!---
-
- subroutine compute_vert_imp_coefs(s, grid, dts)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute coefficients for vertically implicit gravity-wave/acoustic computations
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - cofrz, cofwr, cofwz, coftz, cofwt, a, alpha and gamma
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(inout) :: grid
- real (kind=RKIND), intent(in) :: dts
-
- integer :: i, k, iq
-
- integer :: nCells, nVertLevels, nCellsSolve
- real (kind=RKIND), dimension(:,:), pointer :: zz, cqw, p, t, rb, rtb, pb, rt
- real (kind=RKIND), dimension(:,:), pointer :: cofwr, cofwz, coftz, cofwt, a_tri, alpha_tri, gamma_tri
- real (kind=RKIND), dimension(:), pointer :: cofrz, rdzw, fzm, fzp, rdzu
-
- real (kind=RKIND), dimension( grid % nVertLevels ) :: b_tri,c_tri
- real (kind=RKIND) :: epssm, dtseps, c2, qtot, rcv
-
-! set coefficients
-
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
-! epssm = grid % epssm ! this should come in through the namelist ******************
- epssm = 0.2
-
- rdzu => grid % rdzu % array
- rdzw => grid % rdzw % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zz => grid % zz % array
- cqw => grid % cqw % array
-
- p => grid % exner % array
- pb => grid % exner_base % array
- rt => grid % rtheta_p % array
- rtb => grid % rtheta_base % array
- rb => grid % rho_base % array
-
- alpha_tri => grid % alpha_tri % array
- gamma_tri => grid % gamma_tri % array
- a_tri => grid % a_tri % array
- cofwr => grid % cofwr % array
- cofwz => grid % cofwz % array
- coftz => grid % coftz % array
- cofwt => grid % cofwt % array
- cofrz => grid % cofrz % array
-
- t => s % theta % array
-
- dtseps = .5*dts*(1.+epssm)
- rcv = rgas/(cp-rgas)
- c2 = cp*rcv
-
- do k=1,nVertLevels
- cofrz(k) = dtseps*rdzw(k)
- end do
-
- do i = 1, nCellsSolve ! we only need to do cells we are solving for, not halo cells
-
- do k=2,nVertLevels
- cofwr(k,i) =.5*dtseps*gravity*(fzm(k)*zz(k,i)+fzp(k)*zz(k-1,i))
- end do
- do k=2,nVertLevels
- cofwz(k,i) = dtseps*c2*(fzm(k)*zz(k,i)+fzp(k)*zz(k-1,i)) &
- *rdzu(k)*cqw(k,i)*(fzm(k)*p (k,i)+fzp(k)*p (k-1,i))
- coftz(k,i) = dtseps* (fzm(k)*t (k,i)+fzp(k)*t (k-1,i))
- end do
- do k=1,nVertLevels
-
- qtot = 0.
- do iq = moist_start, moist_end
- qtot = qtot + s % scalars % array (iq, k, i)
- end do
-
- cofwt(k,i) = .5*dtseps*rcv*zz(k,i)*gravity*rb(k,i)/(1.+qtot) &
- *p(k,i)/((rtb(k,i)+rt(k,i))*pb(k,i))
- end do
-
- a_tri(1,i) = 0. ! note, this value is never used
- b_tri(1) = 1. ! note, this value is never used
- c_tri(1) = 0. ! note, this value is never used
- gamma_tri(1,i) = 0.
- alpha_tri(1,i) = 0. ! note, this value is never used
-
- do k=2,nVertLevels
- a_tri(k,i) = -cofwz(k ,i)* coftz(k-1,i)*rdzw(k-1)*zz(k-1,i) &
- +cofwr(k ,i)* cofrz(k-1 ) &
- -cofwt(k-1,i)* coftz(k-1,i)*rdzw(k-1)
- b_tri(k) = 1. &
- +cofwz(k ,i)*(coftz(k ,i)*rdzw(k )*zz(k ,i) &
- +coftz(k ,i)*rdzw(k-1)*zz(k-1,i)) &
- -coftz(k ,i)*(cofwt(k ,i)*rdzw(k ) &
- -cofwt(k-1,i)*rdzw(k-1)) &
- +cofwr(k, i)*(cofrz(k )-cofrz(k-1))
- c_tri(k) = -cofwz(k ,i)* coftz(k+1,i)*rdzw(k )*zz(k ,i) &
- -cofwr(k ,i)* cofrz(k ) &
- +cofwt(k ,i)* coftz(k+1,i)*rdzw(k )
- end do
- do k=2,nVertLevels
- alpha_tri(k,i) = 1./(b_tri(k)-a_tri(k,i)*gamma_tri(k-1,i))
- gamma_tri(k,i) = c_tri(k)*alpha_tri(k,i)
- end do
-
- end do ! loop over cells
-
- end subroutine compute_vert_imp_coefs
-
-!------------------------
-
- subroutine set_smlstep_pert_variables( s_old, s_new, tend, grid )
-
- implicit none
- type (grid_state) :: s_new, s_old, tend
- type (grid_meta) :: grid
- integer :: iCell, k
-
- grid % rho_pp % array = grid % rho_p_save % array - s_new % rho_p % array
-
- grid % ru_p % array = grid % ru_save % array - grid % ru % array
- grid % rtheta_pp % array = grid % rtheta_p_save % array - grid % rtheta_p % array
- grid % rtheta_pp_old % array = grid % rtheta_pp % array
- grid % rw_p % array = grid % rw_save % array - grid % rw % array
-
- do iCell = 1, grid % nCellsSolve
- do k = 2, grid % nVertLevels
- tend % w % array(k,iCell) = ( grid % fzm % array (k) * grid % zz % array(k ,iCell) + &
- grid % fzp % array (k) * grid % zz % array(k-1,iCell) ) &
- * tend % w % array(k,iCell)
- end do
- end do
-
- grid % ruAvg % array = 0.
- grid % wwAvg % array = 0.
-
- end subroutine set_smlstep_pert_variables
-
-!-------------------------------
-
- subroutine advance_acoustic_step( s, tend, grid, dts )
-
- implicit none
-
- type (grid_state) :: s, tend
- type (grid_meta) :: grid
- real (kind=RKIND), intent(in) :: dts
-
- real (kind=RKIND), dimension(:,:), pointer :: rho, theta, ru_p, rw_p, rtheta_pp, &
- rtheta_pp_old, zz, exner, cqu, ruAvg, &
- wwAvg, rho_pp, cofwt, coftz, zx, &
- a_tri, alpha_tri, gamma_tri, dss, &
- tend_ru, tend_rho, tend_rt, tend_rw, &
- zgrid, cofwr, cofwz, w
- real (kind=RKIND), dimension(:), pointer :: fzm, fzp, rdzw, dcEdge, AreaCell, cofrz, dvEdge
-
- real (kind=RKIND) :: smdiv, c2, rcv
- real (kind=RKIND), dimension( grid % nVertLevels ) :: du
- real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: dpzx
- real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: ts, rs
- real (kind=RKIND), dimension( grid % nVertLevels + 1 , grid % nCells ) :: ws
-
- integer :: cell1, cell2, iEdge, iCell, k
- real (kind=RKIND) :: pgrad, flux1, flux2, flux, resm, epssm
-
- real (kind=RKIND) :: cf1, cf2, cf3
-
- integer :: nEdges, nCells, nCellsSolve, nVertLevels
-
- logical, parameter :: debug = .false.
-! logical, parameter :: debug = .true.
- logical, parameter :: debug1 = .false.
- real (kind=RKIND) :: wmax
- integer :: iwmax, kwmax
-
-!--
-
- rho => s % rho % array
- theta => s % theta % array
- w => s % w % array
-
- rtheta_pp => grid % rtheta_pp % array
- rtheta_pp_old => grid % rtheta_pp_old % array
- ru_p => grid % ru_p % array
- rw_p => grid % rw_p % array
- exner => grid % exner % array
- cqu => grid % cqu % array
- ruAvg => grid % ruAvg % array
- wwAvg => grid % wwAvg % array
- rho_pp => grid % rho_pp % array
- cofwt => grid % cofwt % array
- coftz => grid % coftz % array
- cofrz => grid % cofrz % array
- cofwr => grid % cofwr % array
- cofwz => grid % cofwz % array
- a_tri => grid % a_tri % array
- alpha_tri => grid % alpha_tri % array
- gamma_tri => grid % gamma_tri % array
- dss => grid % dss % array
-
- tend_ru => tend % u % array
- tend_rho => tend % rho % array
- tend_rt => tend % theta % array
- tend_rw => tend % w % array
-
- zz => grid % zz % array
- zx => grid % zx % array
- zgrid => grid % zgrid % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- rdzw => grid % rdzw % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- AreaCell => grid % AreaCell % array
-
-! might these be pointers instead? **************************
-
- nEdges = grid % nEdges
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
-
-! cf1, cf2 and cf3 should come from the initialization *************
-
- cf1 = 1.5
- cf2 = -0.5
- cf3 = 0.
-
-! these values should come from the namelist *****************
-
- epssm = 0.2
- smdiv = 0.1
-
- rcv = rgas/(cp-rgas)
- c2 = cp*rcv
- resm = (1.-epssm)/(1.+epssm)
-
- ts = 0.
- rs = 0.
- ws = 0.
-
- ! acoustic step divergence damping - forward weight rtheta_pp
- rtheta_pp_old = rtheta_pp + smdiv*(rtheta_pp - rtheta_pp_old)
-
- if(debug) write(0,*) ' updating ru_p '
-
- do iEdge = 1, nEdges
-
- cell1 = grid % cellsOnEdge % array (1,iEdge)
- cell2 = grid % cellsOnEdge % array (2,iEdge)
- ! update edge for block-owned cells
- if (cell1 <= grid % nCellsSolve .or. cell2 <= grid % nCellsSolve ) then
-
- k = 1
- dpzx(k) = .5*zx(k,iEdge)*(cf1*(zz(k ,cell2)*rtheta_pp_old(k ,cell2) &
- +zz(k ,cell1)*rtheta_pp_old(k ,cell1)) &
- +cf2*(zz(k+1,cell2)*rtheta_pp_old(k+1,cell2) &
- +zz(k+1,cell1)*rtheta_pp_old(k+1,cell1)) &
- +cf3*(zz(k+2,cell2)*rtheta_pp_old(k+2,cell2) &
- +zz(k+2,cell1)*rtheta_pp_old(k+2,cell1)))
- do k=2,grid % nVertLevels
- dpzx(k)=.5*zx(k,iEdge)*(fzm(k)*(zz(k ,cell2)*rtheta_pp_old(k ,cell2) &
- +zz(k ,cell1)*rtheta_pp_old(k ,cell1)) &
- +fzp(k)*(zz(k-1,cell2)*rtheta_pp_old(k-1,cell2) &
- +zz(k-1,cell1)*rtheta_pp_old(k-1,cell1)))
- end do
- dpzx(nVertLevels + 1) = 0.
-
- do k=1,nVertLevels
- pgrad = (rtheta_pp_old(k,cell2)-rtheta_pp_old(k,cell1))/dcEdge(iEdge) &
- - rdzw(k)*(dpzx(k+1)-dpzx(k))
- pgrad = 0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad
- du(k) = dts*(tend_ru(k,iEdge) - cqu(k,iEdge) * pgrad)
-
- ru_p(k,iEdge) = ru_p(k,iEdge) + du(k)
-
- if(debug) then
- if(iEdge == 3750) then
- write(0,*) ' k, pgrad, tend_ru ',k,pgrad,tend_ru(k,3750)
- end if
- end if
-
-! need to add horizontal fluxes into density update, rtheta update and w update
-
- flux = dts*dvEdge(iEdge)*ru_p(k,iEdge)
- rs(k,cell1) = rs(k,cell1)-flux/AreaCell(cell1)
- rs(k,cell2) = rs(k,cell2)+flux/AreaCell(cell2)
-
- flux = flux*0.5*(theta(k,cell2)+theta(k,cell1))
- ts(k,cell1) = ts(k,cell1)-flux/AreaCell(cell1)
- ts(k,cell2) = ts(k,cell2)+flux/AreaCell(cell2)
-
- ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge)
-
- end do
-
- do k=2,nVertLevels
- flux = dts*0.5*dvEdge(iEdge)*((zgrid(k,cell2)-zgrid(k,cell1))*(fzm(k)*du(k)+fzp(k)*du(k-1)) )
- flux2 = - (fzm(k)*zz(k ,cell2) +fzp(k)*zz(k-1,cell2))*flux/AreaCell(cell2)
- flux1 = - (fzm(k)*zz(k ,cell1) +fzp(k)*zz(k-1,cell1))*flux/AreaCell(cell1)
- ws(k,cell2) = ws(k,cell2) + flux2
- ws(k,cell1) = ws(k,cell1) + flux1
- enddo
-
- end if ! end test for block-owned cells
-
- end do ! end loop over edges
-
- ! saving rtheta_pp before update for use in divergence damping in next acoustic step
- rtheta_pp_old(:,:) = rtheta_pp(:,:)
-
- do iCell = 1, nCellsSolve
-
- do k=1, nVertLevels
- rs(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k,iCell) &
- - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell))
- ts(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k,iCell) &
- - resm*rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) &
- -coftz(k,iCell)*rw_p(k,iCell))
- enddo
-
- do k=2, nVertLevels
-
- wwavg(k,iCell) = wwavg(k,iCell) + 0.5*(1.-epssm)*rw_p(k,iCell)
-
- rw_p(k,iCell) = rw_p(k,iCell) + ws(k,iCell) + dts*tend_rw(k,iCell) &
- - cofwz(k,iCell)*((zz(k ,iCell)*ts (k ,iCell) &
- -zz(k-1,iCell)*ts (k-1,iCell)) &
- +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) &
- -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) &
- - cofwr(k,iCell)*((rs (k,iCell)+rs (k-1,iCell)) &
- +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) &
- + cofwt(k ,iCell)*(ts (k ,iCell)+resm*rtheta_pp(k ,iCell)) &
- + cofwt(k-1,iCell)*(ts (k-1,iCell)+resm*rtheta_pp(k-1,iCell))
- enddo
-
- do k=2,nVertLevels
- rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell)
- end do
-
- do k=nVertLevels,1,-1
- rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell)                
- end do
-
- do k=2,nVertLevels
- rw_p(k,iCell) = (rw_p(k,iCell)-dts*dss(k,iCell)* &
- (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) &
- *(fzm(k)*rho(k,iCell)+fzp(k)*rho(k-1,iCell)) &
- *w(k,iCell) )/(1.+dts*dss(k,iCell))
-
- wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.+epssm)*rw_p(k,iCell)
-
- end do
-
- do k=1,nVertLevels
- rho_pp(k,iCell) = rs(k,iCell) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell))
- rtheta_pp(k,iCell) = ts(k,iCell) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) &
- -coftz(k ,iCell)*rw_p(k ,iCell))
- end do
-
- end do ! end of loop over cells
-
- end subroutine advance_acoustic_step
-
-!------------------------
-
- subroutine recover_large_step_variables( s, grid, dt, ns )
-
- implicit none
- type (grid_state) :: s
- type (grid_meta) :: grid
- integer, intent(in) :: ns
- real (kind=RKIND), intent(in) :: dt
-
- real (kind=RKIND), dimension(:,:), pointer :: wwAvg, rw_save, w, rw, rw_p, rtheta_p, rtheta_pp, &
- rtheta_p_save, rt_diabatic_tend, rho_p, rho_p_save, &
- rho_pp, rho, rho_base, ruAvg, ru_save, ru_p, u, ru, &
- exner, exner_base, rtheta_base, pressure_p, &
- zz, theta, zgrid
- real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, AreaCell
- integer, dimension(:,:), pointer :: CellsOnEdge
-
- integer :: iCell, iEdge, k, cell1, cell2
- integer :: nVertLevels, nCells, nCellsSolve, nEdges, nEdgesSolve
- real (kind=RKIND) :: rcv, p0, cf1, cf2, cf3, flux
-
-! logical, parameter :: debug=.true.
- logical, parameter :: debug=.false.
-
-!---
-
- wwAvg => grid % wwAvg % array
- rw_save => grid % rw_save % array
- rw => grid % rw % array
- rw_p => grid % rw_p % array
- w => s % w % array
-
- rtheta_p => grid % rtheta_p % array
- rtheta_p_save => grid % rtheta_p_save % array
- rtheta_pp => grid % rtheta_pp % array
- rtheta_base => grid % rtheta_base % array
- rt_diabatic_tend => grid % rt_diabatic_tend % array
- theta => s % theta % array
-
- rho => s % rho % array
- rho_p => s % rho_p % array
- rho_p_save => grid % rho_p_save % array
- rho_pp => grid % rho_pp % array
- rho_base => grid % rho_base % array
-
- ruAvg => grid % ruAvg % array
- ru_save => grid % ru_save % array
- ru_p => grid % ru_p % array
- ru => grid % ru % array
- u => s % u % array
-
- exner => grid % exner % array
- exner_base => grid % exner_base % array
-
- pressure_p => s % pressure % array
-
- zz => grid % zz % array
- zgrid => grid % zgrid % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- dvEdge => grid % dvEdge % array
- AreaCell => grid % AreaCell % array
- CellsOnEdge => grid % CellsOnEdge % array
-
- nVertLevels = grid % nVertLevels
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nEdges = grid % nEdges
- nEdgesSolve = grid % nEdgesSolve
-
- rcv = rgas/(cp-rgas)
- p0 = 1.e+05 ! this should come from somewhere else...
- cf1 = 1.5
- cf2 = -0.5
- cf3 = 0.
-
- ! compute new density everywhere so we can compute u from ru.
- ! we will also need it to compute theta below
-
- do iCell = 1, nCells
-
- if(debug) then
- if( iCell == 479 ) then
- write(0,*) ' k,rho_old,rp_old, rho_pp '
- do k=1,nVertLevels
- write(0,*) k, rho(k,iCell) ,rho_p(k,iCell), rho_pp(k,iCell)
- enddo
- end if
- end if
-
- do k = 1, nVertLevels
-
- rho_p(k,iCell) = rho_p(k,iCell) + rho_pp(k,iCell)
-
- rho(k,iCell) = rho_p(k,iCell) + rho_base(k,iCell)
- end do
-
- ! recover owned-cell values in block
-
- if( iCell <= nCellsSolve ) then
-
- if(debug) then
- if( iCell == 479 ) then
- write(0,*) ' k, rw, rw_save, rw_p '
- do k=1,nVertLevels
- write(0,*) k, rw(k,iCell), rw_save(k,iCell) ,rw_p(k,iCell)
- enddo
- end if
- end if
-
- w(1,iCell) = 0.
- do k = 2, nVertLevels
- wwAvg(k,iCell) = rw(k,iCell) + (wwAvg(k,iCell) / float(ns))
-
- rw(k,iCell) = rw(k,iCell) + rw_p(k,iCell)
-
-
- ! pick up part of diagnosed w from omega
- w(k,iCell) = rw(k,iCell)/( (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) &
- *(fzm(k)*rho(k,iCell)+fzp(k)*rho(k-1,iCell)) )
- end do
- w(nVertLevels+1,iCell) = 0.
-
- if(debug) then
- if( iCell == 479 ) then
- write(0,*) ' k, rtheta_p_save, rtheta_pp, rtheta_base '
- do k=1,nVertLevels
- write(0,*) k, rtheta_p_save(k,iCell), rtheta_pp(k,iCell), rtheta_base(k,iCell)
- enddo
- end if
- end if
-
- do k = 1, nVertLevels
-
- rtheta_p(k,iCell) = rtheta_p(k,iCell) + rtheta_pp(k,iCell) ! - dt * rt_diabatic_tend(k,iCell)
-
-
- theta(k,iCell) = (rtheta_p(k,iCell) + rtheta_base(k,iCell))/rho(k,iCell)
- exner(k,iCell) = (zz(k,iCell)*(rgas/p0)*(rtheta_p(k,iCell)+rtheta_base(k,iCell)))**rcv
- ! pressure below is perturbation pressure - perhaps we should rename it in the Registry????
- pressure_p(k,iCell) = zz(k,iCell) * rgas * (exner(k,iCell)*rtheta_p(k,iCell)+rtheta_base(k,iCell) &
- * (exner(k,iCell)-exner_base(k,iCell)))
- end do
-
- end if
-
- end do
-
- ! recover time-averaged ruAvg on all edges of owned cells (for upcoming scalar transport).
- ! we solved for these in the acoustic-step loop.
- ! we will compute ru and u here also, given we are here, even though we only need them on nEdgesSolve
-
- do iEdge = 1, nEdges
-
- cell1 = CellsOnEdge(1,iEdge)
- cell2 = CellsOnEdge(2,iEdge)
-
- if( cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
-
- do k = 1, nVertLevels
- ruAvg(k,iEdge) = ru(k,iEdge) + (ruAvg(k,iEdge) / float(ns))
-
- ru(k,iEdge) = ru(k,iEdge) + ru_p(k,iEdge)
-
- u(k,iEdge) = 2.*ru(k,iEdge)/(rho(k,cell1)+rho(k,cell2))
- enddo
-
- flux = dvEdge(iEdge)*0.5*(cf1*u(1,iEdge)+cf2*u(2,iEdge)+cf3*u(3,iEdge))*(zgrid(1,cell2)-zgrid(1,cell1))
- w(1,cell2) = w(1,cell2)+flux/AreaCell(cell2)
- w(1,cell1) = w(1,cell1)+flux/AreaCell(cell1)
-
- do k = 2, nVertLevels
- flux = dvEdge(iEdge)*0.5*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge))*(zgrid(k,cell2)-zgrid(k,cell1))
- w(k,cell2) = w(k,cell2)+flux/AreaCell(cell2)
- w(k,cell1) = w(k,cell1)+flux/AreaCell(cell1)
- enddo
-
- end if
-
- enddo
-
- end subroutine recover_large_step_variables
-
-!---------------------------------------------------------------------------------------
-
- 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 (grid_state), intent(in) :: tend
- type (grid_state), intent(in) :: s_old
- type (grid_state), intent(out) :: s_new
- type (grid_meta), intent(in) :: grid
- real (kind=RKIND) :: dt
-
- integer :: i, iCell, iEdge, k, iScalar, cell1, cell2
- 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, rho_edge, rho, zgrid
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell, qv_init
- integer, dimension(:,:), pointer :: cellsOnEdge
-
- real (kind=RKIND), dimension( num_scalars, grid % nVertLevels + 1 ) :: wdtn
- integer :: nVertLevels
-
- real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
- real (kind=RKIND) :: coef_3rd_order
-
-
- real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, scalar_turb_flux, z1,z2,z3,z4,zm,z0,zp
- logical, parameter :: mix_full = .false.
-! logical, parameter :: mix_full = .true.
-
- 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
- uhAvg => grid % ruAvg % 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
- h_old => s_old % rho % array
- h_new => s_new % rho % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
-!**** fnm => grid % fnm % array
-!**** fnp => grid % fnp % array
-!**** rdnw => grid % rdnw % array
- fnm => grid % fzm % array
- fnp => grid % fzp % array
- rdnw => grid % rdzw % array
-
- nVertLevels = grid % nVertLevels
-
- h_theta_eddy_visc2 = config_h_theta_eddy_visc2
- v_theta_eddy_visc2 = config_v_theta_eddy_visc2
- rho_edge => s_new % rho_edge % array
- rho => s_new % rho % array
- qv_init => grid % qv_init % array
- zgrid => grid % zgrid % array
-
- 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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- end do
-
- else if (config_scalar_adv_order == 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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 if
- end do
-
- else if (config_scalar_adv_order == 4) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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 if
-
- end do
- end if
-
-! horizontal mixing for scalars - we could combine this with transport...
-
- 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)
- if (cell1 > 0 .and. cell2 > 0) then
-
- do k=1,grid % nVertLevels
- do iScalar=1,num_scalars
- scalar_turb_flux = h_theta_eddy_visc2*prandtl* &
- (scalar_new(iScalar,k,cell2) - scalar_new(iScalar,k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * rho_edge(k,iEdge) * scalar_turb_flux
- 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 if
- end do
-
- end if
-
- ! vertical mixing
-
- if ( v_theta_eddy_visc2 > 0.0 ) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- do iScalar=1,num_scalars
- scalar_tend(iScalar,k,iCell) = scalar_tend(iScalar,k,iCell) + v_theta_eddy_visc2*prandtl*rho(k,iCell)*(&
- (scalar_new(iScalar,k+1,iCell)-scalar_new(iScalar,k ,iCell))/(zp-z0) &
- -(scalar_new(iScalar,k ,iCell)-scalar_new(iScalar,k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- if ( .not. mix_full) then
- iScalar = index_qv
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- scalar_tend(iScalar,k,iCell) = scalar_tend(iScalar,k,iCell) + v_theta_eddy_visc2*prandtl*rho(k,iCell)*(&
- (-qv_init(k+1)+qv_init(k))/(zp-z0) &
- -(-qv_init(k)+qv_init(k-1))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end if
-
- 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 (grid_state), intent(in) :: tend
- type (grid_state), intent(in) :: s_old
- type (grid_state), intent(out) :: s_new
- type (grid_meta), 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
- 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( num_scalars, grid % nEdges) :: h_flux
- real (kind=RKIND), dimension( num_scalars, grid % nCells, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( num_scalars, grid % nCells, 2 ) :: scale_out, scale_in
- real (kind=RKIND), dimension( 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
-
- scalar_old => s_old % scalars % array
- scalar_new => s_new % scalars % array
- deriv_two => grid % deriv_two % array
-!**** uhAvg => grid % uhAvg % array
- uhAvg => grid % ruAvg % 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
- h_old => s_old % rho % array
- h_new => s_new % rho % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
-!**** fnm => grid % fnm % array
-!**** fnp => grid % fnp % array
-!**** rdnw => grid % rdnw % array
- fnm => grid % fzm % array
- fnp => grid % fzp % array
- rdnw => grid % rdzw % 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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- end do
-
- else if (config_scalar_adv_order >= 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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 if
- 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
- if (grid % cellsOnCell % array(i,iCell) > 0) then
- 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 if
-
- 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 dmpar_exch_halo_field2dReal(dminfo, scale_out(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_out(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_in(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- 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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- 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_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, rv;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
- real (kind=RKIND) :: flux, vorticity_abs, rho_vertex, workpv, q, upstream_bias
-
- integer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve
- 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 :: fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, kiteAreasOnVertex, zgrid, rho_edge, rho, ru, u, v, tend_u, &
- circulation, divergence, vorticity, ke, pv_edge, theta, rw, tend_rho, &
- h_diabatic, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zx, cqu
- 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 ) :: wduz, wdwz, wdtz, dpzx
- real (kind=RKIND), dimension( grid % nVertLevels ) :: u_mix
- real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, pgrad
-
- real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, t_init
-
- real (kind=RKIND), allocatable, dimension(:,:) :: rv, divergence_ru
- 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
- real (kind=RKIND) :: cf1, cf2, cf3
-
-! logical, parameter :: debug = .true.
- logical, parameter :: debug = .false.
- logical, parameter :: mix_full = .false.
-! logical, parameter :: mix_full = .true.
-
- rho => s % rho % array
- rho_edge => s % rho_edge % array
- rb => grid % rho_base % array
- rr => s % rho_p % array
- u => s % u % array
- ru => grid % ru % array
- w => s % w % array
- rw => grid % rw % array
- theta => s % theta % array
- circulation => s % circulation % array
- divergence => s % divergence % array
- vorticity => s % vorticity % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- pp => s % pressure % array
- pressure_b => grid % pressure_base % 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
- zz => grid % zz % array
- zx => grid % zx % array
-
- tend_u => tend % u % array
- tend_theta => tend % theta % array
- tend_w => tend % w % array
- tend_rho => tend % rho % array
- h_diabatic => grid % rt_diabatic_tend % array
-
- t_init => grid % t_init % array
-
- rdzu => grid % rdzu % array
- rdzw => grid % rdzw % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zgrid => grid % zgrid % array
- cqw => grid % cqw % array
- cqu => grid % cqu % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
- nVertices = grid % nVertices
- nCellsSolve = grid % nCellsSolve
-
- 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
-
- cf1 = 1.5
- cf2 = -.5
- cf3 = 0.
-
- ! tendency for density
- ! divergence_ru may calculated in the diagnostic subroutine - it is temporary
- allocate(divergence_ru(nVertLevels, nCells))
-
- divergence_ru(:,:) = 0.0
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- flux = ru(k,iEdge)*dvEdge(iEdge)
- divergence_ru(k,cell1) = divergence_ru(k,cell1) + flux
- divergence_ru(k,cell2) = divergence_ru(k,cell2) - flux
- end do
- end do
-
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- divergence_ru(k,iCell) = divergence_ru(k,iCell) * r
- tend_rho(k,iCell) = -divergence_ru(k,iCell)-rdzw(k)*(rw(k+1,iCell)-rw(k,iCell))
- end do
- end do
-
-#ifdef LANL_FORMULATION
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- ! horizontal pressure gradient, nonlinear Coriolis term and ke gradient
-
- k = 1
- dpzx(k) = .5*zx(k,iEdge)*(cf1*(pp(k ,cell2)+pp(k ,cell1)) &
- +cf2*(pp(k+1,cell2)+pp(k+1,cell1)) &
- +cf3*(pp(k+2,cell2)+pp(k+2,cell1)))
- do k = 2, nVertLevels
- dpzx(k) = .5*zx(k,iEdge)*(fzm(k)*(pp(k ,cell2)+pp(k ,cell1)) &
- +fzp(k)*(pp(k-1,cell2)+pp(k-1,cell1)))
- end do
- dpzx(nVertLevels+1) = 0.
-
-
- 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 * rho_edge(k,eoe)
- end do
- tend_u(k,iEdge) = rho_edge(k,iEdge)* (q - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)) &
- - u(k,iEdge)*0.5*(divergence_ru(k,cell1)+divergence_ru(k,cell2)) &
- - cqu(k,iEdge)*( (pp(k,cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) / dcEdge(iEdge) &
- -rdzw(k)*(dpzx(k+1)-dpzx(k)) )
- end do
-
- end do
-
-#endif
-
-#ifdef NCAR_FORMULATION
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
-
- allocate(rv(nVertLevels, nEdges))
- rv(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- k = 1
- dpzx(k) = .5*zx(k,iEdge)*(cf1*(pp(k ,cell2)+pp(k ,cell1)) &
- +cf2*(pp(k+1,cell2)+pp(k+1,cell1)) &
- +cf3*(pp(k+2,cell2)+pp(k+2,cell1)))
- do k = 2, nVertLevels
- dpzx(k) = .5*zx(k,iEdge)*(fzm(k)*(pp(k ,cell2)+pp(k ,cell1)) &
- +fzp(k)*(pp(k-1,cell2)+pp(k-1,cell1)))
- end do
- dpzx(nVertLevels+1) = 0.
-
- do j=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- do k=1,nVertLevels
- rv(k,iEdge) = rv(k,iEdge) + weightsOnEdge(j,iEdge) * ru(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 / (rho(k,cell1) + rho(k,cell2))
-
- tend_u(k,iEdge) = rho_edge(k,iEdge)* (workpv * rv(k,iEdge) - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)) &
- - u(k,iEdge)*0.5*(divergence_ru(k,cell1)+divergence_ru(k,cell2)) &
- - cqu(k,iEdge)*( (pp(k,Cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) / dcEdge(iEdge) &
- -rdzw(k)*(dpzx(k+1)-dpzx(k)) )
-
- end do
-
- end do
- deallocate(rv)
-#endif
- deallocate(divergence_ru)
-
- !
- ! vertical advection for u
- !
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- wduz(1) = 0.
- do k=2,nVertLevels
- wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2) )*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge))
- end do
- wduz(nVertLevels+1) = 0.
-
- do k=1,nVertLevels
- tend_u(k,iEdge) = tend_u(k,iEdge) - rdzw(k)*(wduz(k+1)-wduz(k))
- end do
- end do
-
- !
- ! 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 = rho_edge(k,iEdge)*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))
- allocate(delsq_u(nVertLevels, nEdges))
- allocate(delsq_circulation(nVertLevels, nVertices))
- allocate(delsq_vorticity(nVertLevels, nVertices))
-
- 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)
-
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- 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 if
- end do
-
- delsq_circulation(:,:) = 0.0
- do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) > 0) then
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(1,iEdge)) = delsq_circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) > 0) then
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(2,iEdge)) = delsq_circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end if
- 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)
- if (cell1 <= nCellsSolve) then
- do k=1,nVertLevels
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- if (cell2 <= nCellsSolve) then
- do k=1,nVertLevels
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- 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 = rho_edge(k,iEdge) * ( 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 mixing for u - 2nd order
- !
- if ( v_mom_eddy_visc2 > 0.0 ) then
-
- if (mix_full) then
-
- do iEdge=1,grid % nEdgesSolve
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=2,nVertLevels-1
-
- z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2))
- z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2))
- z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2))
- z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2))
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(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
-
- else ! idealized cases where we mix on the perturbation from the initial 1-D state
-
- do iEdge=1,grid % nEdgesSolve
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- u_mix = u(k,iEdge) - grid % u_init % array(k) * cos( grid % angleEdge % array(iEdge) )
- end do
-
- do k=2,nVertLevels-1
-
- z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2))
- z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2))
- z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2))
- z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2))
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( &
- (u_mix(k+1)-u_mix(k ))/(zp-z0) &
- -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
- end if
-
-!----------- rhs for w
-
- tend_w(:,:) = 0.
-
- !
- ! horizontal advection for w
- !
-
- if (config_theta_adv_order == 2) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=2,grid % nVertLevels
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) ) &
- *(w(k,cell1) + w(k,cell2))*0.5
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
- end do
- end if
- end do
-
- else if (config_theta_adv_order == 3) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * w(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * w(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * w(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * w(k,grid % CellsOnCell % array (i,cell2))
- end do
-
-! 3rd order stencil
- if( u(k,iEdge)+u(k-1,iEdge) > 0) then
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge))*( &
- 0.5*(w(k,cell1) + w(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
- else
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge))*( &
- 0.5*(w(k,cell1) + w(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
- end if
-
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
-
- end do
- end if
- end do
-
- else if (config_theta_adv_order == 4) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * w(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * w(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * w(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * w(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge)) * ( &
- 0.5*(w(k,cell1) + w(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
- end do
-
- end if
-
- end do
- end if
-
- !
- ! horizontal mixing for w - 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)
- !
-
- ! Note: we are using quite a bit of the theta code here - could be combined later???
-
- if ( h_mom_eddy_visc2 > 0.0 ) then
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
- theta_turb_flux = h_mom_eddy_visc2*(w(k,cell2) - w(k,cell1))/dcEdge(iEdge)
- flux = 0.5*dvEdge (iEdge) * (rho_edge(k,iEdge)+rho_edge(k-1,iEdge)) * theta_turb_flux
- tend_w(k,cell1) = tend_w(k,cell1) + flux
- tend_w(k,cell2) = tend_w(k,cell2) - flux
- end do
-
- end if
- end do
-
- end if
-
- if ( h_mom_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_theta(nVertLevels, nCells))
-
- delsq_theta(:,:) = 0.
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
- delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*0.5*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1))/dcEdge(iEdge)
- delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*0.5*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1))/dcEdge(iEdge)
- end do
-
- end if
- end do
-
- do iCell = 1, nCells
- r = 1.0 / areaCell(iCell)
- do k=2,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)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
- theta_turb_flux = h_mom_eddy_visc4*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * theta_turb_flux
-
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
- end do
-
- end if
- end do
-
- deallocate(delsq_theta)
-
- end if
-
- !
- ! vertical advection, pressure gradient and buoyancy for w
- ! Note: we are also dividing through by the cell area after the horizontal flux divergence
- !
-
- do iCell = 1, nCells
- wdwz(1) = 0.
- do k=2,nVertLevels
- wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell))
- end do
- wdwz(nVertLevels+1) = 0.
- do k=2,nVertLevels
- tend_w(k,iCell) = tend_w(k,iCell)/areaCell(iCell) -rdzu(k)*(wdwz(k+1)-wdwz(k)) &
- - cqw(k,iCell)*( rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
- - gravity*(fzm(k)*rb(k,iCell)+fzp(k)*rb(k-1,iCell)) ) &
- - gravity*( fzm(k)*(rr(k,iCell)+rb(k,iCell)) + fzp(k)*(rr(k-1,iCell)+rb(k-1,iCell)) )
-
-
-
-! - cqw(k,iCell)*rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
-! - gravity*( fzm(k)*rr(k,iCell)+fzp(k)*rr(k-1,iCell) &
-! +(1.-cqw(k,iCell))*(fzm(k)*rb(k,iCell)+fzp(k)*rb(k-1,iCell)))
-
-
-
-! WCS version - cqw(k,iCell)*rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
-! - gravity*0.5*(rr(k,iCell)+rr(k-1,iCell)+(1.-cqw(k,iCell))*(rb(k,iCell)+rb(k-1,iCell)))
-
-!Joe formulation
-! - cqw(k,iCell)*( rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
-! - gravity*(fzm(k)*rb(k,iCell)+fzp(k)*rb(k-1,iCell)) ) &
-! - gravity*( fzm(k)*(rr(k,iCell)+rb(k,iCell)) + fzp(k)*(rr(k-1,iCell)+rb(k-1,iCell)) )
-
- end do
- end do
-
- !
- ! vertical mixing for w - 2nd order
- !
- if ( v_mom_eddy_visc2 > 0.0 ) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- tend_w(k,iCell) = tend_w(k,iCell) + v_mom_eddy_visc2*0.5*(rho(k,iCell)+rho(k-1,iCell))*( &
- (w(k+1,iCell)-w(k ,iCell))*rdzw(k) &
- -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k)
- end do
- end do
-
- end if
-
-!----------- rhs for theta
-
- tend_theta(:,:) = 0.
-
- !
- ! horizontal advection for theta
- !
-
- if (config_theta_adv_order == 2) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,grid % nVertLevels
- flux = dvEdge(iEdge) * ru(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 if
- end do
-
- else if (config_theta_adv_order == 3) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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) * ru(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
- else
- flux = dvEdge(iEdge) * ru(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 if
- end do
-
- else if (config_theta_adv_order == 4) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * ru(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 if
-
- end do
- end if
-
-! write(0,*) ' pt 1 tend_theta(3,1120) ',tend_theta(3,1120)/AreaCell(1120)
-
- !
- ! 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)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * rho_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 if
- end do
-
- end if
-
- if ( h_theta_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_theta(nVertLevels, nCells))
-
- delsq_theta(:,:) = 0.
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=1,grid % nVertLevels
- delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*rho_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*rho_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- end do
-
- end if
- 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)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- 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 if
- end do
-
- deallocate(delsq_theta)
-
- 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
- wdtz(1) = 0.
- do k=2,nVertLevels
- wdtz(k) = rw(k,icell)*(fzm(k)*theta(k,iCell)+fzp(k)*theta(k-1,iCell))
- end do
- wdtz(nVertLevels+1) = 0.
- do k=1,nVertLevels
- tend_theta(k,iCell) = tend_theta(k,iCell)/areaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k))
-!! tend_theta(k,iCell) = tend_theta(k) + rho(k,iCell)*h_diabatic(k,iCell)
- end do
- end do
-
- !
- ! vertical mixing for theta - 2nd order
- !
- if ( v_theta_eddy_visc2 > 0.0 ) then
-
- if (mix_full) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- 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*rho(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
-
- else ! idealized cases where we mix on the perturbation from the initial 1-D state
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- 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*rho(k,iCell)*(&
- ((theta(k+1,iCell)-t_init(k+1))-(theta(k ,iCell)-t_init(k)))/(zp-z0) &
- -((theta(k ,iCell)-t_init(k))-(theta(k-1,iCell)-t_init(k-1)))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
- end if
-
- end subroutine compute_dyn_tend
-
-!-------
-
- 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 (grid_state), intent(inout) :: s
- type (grid_meta), 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
- h => s % rho % array
- u => s % u % array
- v => s % v % array
- vh => s % rv % array
- h_edge => s % rho_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)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end if
- end do
-
-
-
- !
- ! Compute circulation and relative vorticity at each vertex
- !
- circulation(:,:) = 0.0
- do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) > 0) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) > 0) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
- 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)
- if (cell1 > 0) then
- do k=1,nVertLevels
- divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- if(cell2 > 0) then
- do k=1,nVertLevels
- divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
-
- 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)
- if (eoe > 0) then
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end if
- 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 )
- !
- VTX_LOOP: do iVertex = 1,nVertices
- do i=1,grid % vertexDegree
- if (cellsOnVertex(i,iVertex) <= 0) cycle VTX_LOOP
- end do
- 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 VTX_LOOP
- ! 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)
- if(iEdge > 0) then
- do k=1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- end do
- end if
- 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) - 0.5 * 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)
- if( iCell > 0) then
- do k = 1,nVertLevels
- pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
- end do
- end if
- 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
- if( cellsOnEdge(1,iEdge) > 0 .and. cellsOnEdge(2,iEdge) > 0) then
- do k = 1,nVertLevels
- gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
- dcEdge(iEdge)
- end do
- end if
- 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) - 0.5 * u(k,iEdge) *dt * gradPVn(k,iEdge)
- end do
- end do
-
-
- end subroutine compute_solve_diagnostics
-
-!----------
-
- subroutine init_coupled_diagnostics( state, grid )
-
- implicit none
-
- type (grid_state), intent(inout) :: state
- type (grid_meta), intent(inout) :: grid
-
- integer :: k,iEdge,i,iCell1,iCell2
-
- do iEdge = 1, grid%nEdges
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- do k=1,grid % nVertLevels
- grid % ru % array(k,iEdge) = 0.5 * state % u % array(k,iEdge)*(state % rho % array(k,iCell1)+state % rho % array(k,iCell2))
- enddo
- enddo
-
- do i=1,grid%nCellsSolve
- do k=1,grid % nVertLevels + 1
- grid % rw % array (k,i) = 0.
- enddo
- enddo
-
- end subroutine init_coupled_diagnostics
-
-! ------------------------
-
- subroutine qd_kessler( state_old, state_new, grid, dt )
-
- implicit none
-
- type (grid_state), intent(inout) :: state_old, state_new
- type (grid_meta), intent(inout) :: grid
- real (kind=RKIND), intent(in) :: dt
-
- real (kind=RKIND), dimension( grid % nVertLevels ) :: t, rho, p, dzu, qv, qc, qr, qc1, qr1
-
- integer :: k,iEdge,i,iCell,nz1
- real (kind=RKIND) :: p0,rcv
-
-
- write(0,*) ' in qd_kessler '
-
- p0 = 1.e+05
- rcv = rgas/(cp-rgas)
- nz1 = grid % nVertLevels
-
- do iCell = 1, grid % nCellsSolve
-
- do k = 1, grid % nVertLevels
-
- grid % rt_diabatic_tend % array(k,iCell) = state_new % theta % array(k,iCell)
-
- t(k) = state_new % theta % array(k,iCell)/(1. + 1.61*state_new % scalars % array(index_qv,k,iCell))
- rho(k) = grid % zz % array(k,iCell)*state_new % rho % array(k,iCell)
- p(k) = grid % exner % array(k,iCell)
- qv(k) = max(0.,state_new % scalars % array(index_qv,k,iCell))
- qc(k) = max(0.,state_new % scalars % array(index_qc,k,iCell))
- qr(k) = max(0.,state_new % scalars % array(index_qr,k,iCell))
- qc1(k) = max(0.,state_old % scalars % array(index_qc,k,iCell))
- qr1(k) = max(0.,state_old % scalars % array(index_qr,k,iCell))
- dzu(k) = grid % dzu % array(k)
-
- end do
-
- call kessler( t,qv,qc,qc1,qr,qr1,rho,p,dt,dzu,nz1, 1)
-
- do k = 1, grid % nVertLevels
-
- grid % rt_diabatic_tend % array(k,iCell) = state_new % theta % array(k,iCell)
-
- state_new % theta % array(k,iCell) = t(k)*(1.+1.61*qv(k))
- grid % rt_diabatic_tend % array(k,iCell) = state_new % rho % array(k,iCell) * &
- (state_new % theta % array(k,iCell) - grid % rt_diabatic_tend % array(k,iCell))/dt
- grid % rtheta_p % array(k,iCell) = state_new % rho % array(k,iCell) * state_new % theta % array(k,iCell) &
- - grid % rtheta_base % array(k,iCell)
- state_new % scalars % array(index_qv,k,iCell) = qv(k)
- state_new % scalars % array(index_qc,k,iCell) = qc(k)
- state_new % scalars % array(index_qr,k,iCell) = qr(k)
-
- grid % exner % array(k,iCell) = &
- ( grid % zz % array(k,iCell)*(rgas/p0) * ( &
- grid % rtheta_p % array(k,iCell) &
- + grid % rtheta_base % array(k,iCell) ) )**rcv
-
- state_new % pressure % array(k,iCell) = &
- grid % zz % array(k,iCell) * rgas * ( &
- grid % exner % array(k,iCell)*grid % rtheta_p % array(k,iCell) &
- +grid % rtheta_base % array(k,iCell) * &
- (grid % exner % array(k,iCell) - grid % exner_base % array(k,iCell)) )
- end do
-
- end do
-
- write(0,*) ' exiting qd_kessler '
-
- end subroutine qd_kessler
-
-!-----------------------------------------------------------------------
- subroutine kessler( t1t, qv1t, qc1t, qc1, qr1t, qr1, &
- rho, pii, dt, dzu, nz1, nx )
-!-----------------------------------------------------------------------
-!
- implicit none
- integer :: nx, nz1
- real (kind=RKIND) :: t1t (nz1,nx), qv1t(nz1,nx), qc1t(nz1,nx), &
- qr1t(nz1,nx), qc1 (nz1,nx), qr1 (nz1,nx), &
- rho (nz1,nx), pii (nz1,nx), dzu(nz1)
- integer, parameter :: mz=200
- real (kind=RKIND) :: qrprod(mz), prod (mz), rcgs( mz), rcgsi (mz) &
- ,ern (mz), vt (mz), vtden(mz), gam (mz) &
- ,r (mz), rhalf(mz), velqr(mz), buoycy(mz) &
- ,pk (mz), pc (mz), f0 (mz), qvs (mz)
-
- real (kind=RKIND) :: c1, c2, c3, c4, f5, mxfall, dtfall, fudge, dt, velu, veld, artemp, artot
- real (kind=RKIND) :: cp, product, ackess, ckess, fvel, f2x, xk, xki, psl
- integer :: nfall
- integer :: i,k,n
-
- ackess = 0.001
- ckess = 2.2
- fvel = 36.34
- f2x = 17.27
- f5 = 237.3*f2x*2.5e6/1003.
- xk = .2875
- xki = 1./xk
- psl = 1000.
-
- do k=1,nz1
- r(k) = 0.001*rho(k,1)
- rhalf(k) = sqrt(rho(1,1)/rho(k,1))
- pk(k) = pii(k,1)
- pc(k) = 3.8/(pk(k)**xki*psl)
- f0(k) = 2.5e6/(1003.*pk(k))
- end do
-!
- do i=1,nx
- do k=1,nz1
- qrprod(k) = qc1t(k,i) &
- -(qc1t(k,i)-dt*amax1(ackess*(qc1(k,i)-.001), &
- 0.))/(1.+dt*ckess*qr1(k,i)**.875)
-                         velqr(k) = (qr1(k,i)*r(k))**1.1364*rhalf(k)
- qvs(k) = pc(k)*exp(f2x*(pk(k)*t1t(k,i)-273.) &
- /(pk(k)*t1t(k,i)- 36.))
- end do
- velu = (qr1(2,i)*r(2))**1.1364*rhalf(2)
- veld = (qr1(1,i)*r(1))**1.1364*rhalf(1)
- qr1t(1,i) = qr1t(1,i)+dt*(velu-veld)*fvel/(r(1)*dzu(2))
- do k=2,nz1-1
- qr1t(k,i) = qr1t(k,i)+dt*fvel/r(k) &
- *.5*((velqr(k+1)-velqr(k ))/dzu(k+1) &
- +(velqr(k )-velqr(k-1))/dzu(k ))
- end do
- qr1t(nz1,i) = qr1t(nz1,i)-dt*fvel*velqr(nz1-1) &
- /(r(nz1)*dzu(nz1)*(1.+1.))
- artemp = 36340.*(.5*(velqr(2)+velqr(1))+veld-velu)
- artot = artot+dt*artemp
- do k=1,nz1
- qc1t(k,i) = amax1(qc1t(k,i)-qrprod(k),0.)
- qr1t(k,i) = amax1(qr1t(k,i)+qrprod(k),0.)
- prod(k) = (qv1t(k,i)-qvs(k))/(1.+qvs(k)*f5 &
- /(pk(k)*t1t(k,i)-36.)**2)
- end do
- do k=1,nz1
- ern(k) = amin1(dt*(((1.6+124.9*(r(k)*qr1t(k,i))**.2046) &
- *(r(k)*qr1t(k,i))**.525)/(2.55e6*pc(k) &
- /(3.8 *qvs(k))+5.4e5))*(dim(qvs(k),qv1t(k,i)) &
- /(r(k)*qvs(k))), &
- amax1(-prod(k)-qc1t(k,i),0.),qr1t(k,i))
- end do
- do k=1,nz1
- buoycy(k) = f0(k)*(amax1(prod(k),-qc1t(k,i))-ern(k))
-                                qv1t(k,i) = amax1(qv1t(k,i) &
- -amax1(prod(k),-qc1t(k,i))+ern(k),0.)
- qc1t(k,i) = qc1t(k,i)+amax1(prod(k),-qc1t(k,i))
- qr1t(k,i) = qr1t(k,i)-ern(k)
- t1t (k,i) = t1t (k,i)+buoycy(k)
- end do
- end do
-
- end subroutine kessler
-
-end module time_integration
Deleted: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.sh0609
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.sh0609        2010-07-12 19:38:09 UTC (rev 372)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.sh0609        2010-07-13 21:27:45 UTC (rev 373)
@@ -1,2876 +0,0 @@
-module time_integration
-
- use grid_types
- use configure
- use constants
- use dmpar
-
-
- contains
-
-
- subroutine timestep(domain, dt)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! 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
-
- 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 % time_levs(2) % state % xtime % scalar = block % time_levs(1) % state % xtime % scalar + dt
- 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, iEdge
- 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 = .true.
- logical, parameter :: debug_mass_conservation = .true.
- logical, parameter :: do_microphysics = .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 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))
- ! We are setting values in the halo here, so no communications are needed.
- ! Alternatively, we could just set owned cells and edge values and communicate after this block loop.
- call rk_integration_setup( block % time_levs(2) % state, block % time_levs(1) % state, block % mesh )
- block => block % next
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN RK loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- do rk_step = 1, 3 ! Runge-Kutta loop
-
- if(debug) write(0,*) ' rk substep ', rk_step
-
- block => domain % blocklist
- do while (associated(block))
- ! The coefficients are set for owned cells (cqw) and for all edges of owned cells,
- ! thus no communications should be needed after this call.
- ! We could consider combining this and the next block loop.
- call compute_moist_coefficients( block % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
-
- if (debug) write(0,*) ' compute_dyn_tend '
- block => domain % blocklist
- do while (associated(block))
- call compute_dyn_tend( block % intermediate_step(TEND), block % time_levs(2) % state, block % mesh )
- block => block % next
- end do
- if (debug) write(0,*) ' finished compute_dyn_tend '
-
-!***********************************
-! we will need to communicate the momentum tendencies here - we want tendencies for all edges of owned cells
-! because we are solving for all edges of owned cells
-!***********************************
-
- block => domain % blocklist
- do while (associated(block))
- call set_smlstep_pert_variables( block % time_levs(1) % state, block % time_levs(2) % state, &
- block % intermediate_step(TEND), block % mesh )
- call compute_vert_imp_coefs( block % time_levs(2) % state, block % mesh, rk_sub_timestep(rk_step) )
- block => block % next
- end do
-
- do small_step = 1, number_sub_steps(rk_step)
-
- if(debug) write(0,*) ' acoustic step ',small_step
-
- block => domain % blocklist
- do while (associated(block))
- call advance_acoustic_step( block % time_levs(2) % state, block % intermediate_step(TEND), &
- block % mesh, rk_sub_timestep(rk_step) )
- block => block % next
- end do
-
- if(debug) write(0,*) ' acoustic step complete '
-
- ! will need communications here for rtheta_pp
-
- end do ! end of small stimestep loop
-
- ! will need communications here for rho_pp
-
- block => domain % blocklist
- do while (associated(block))
- call recover_large_step_variables( block % time_levs(2) % state, &
- block % mesh, rk_sub_timestep(rk_step), &
- number_sub_steps(rk_step) )
- block => block % next
- end do
-
-! ************ advection of moist variables here...
-
- 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 % intermediate_step(TEND), &
- block % time_levs(1) % state, block % time_levs(2) % state, &
- block % mesh, rk_timestep(rk_step) )
- else
- call advance_scalars_mono( block % intermediate_step(TEND), &
- block % time_levs(1) % state, block % 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 compute_solve_diagnostics( dt, block % time_levs(2) % state, block % mesh )
- block => block % next
- end do
-
- if(debug) write(0,*) ' diagnostics complete '
-
-
- ! need communications here to fill out u, w, theta, p, and pp, scalars, etc
- ! so that they are available for next RK step or the first rk substep of the next timestep
-
- end do ! rk_step loop
-
-! microphysics here...
-
- if(do_microphysics) then
- block => domain % blocklist
- do while (associated(block))
- call qd_kessler( block % time_levs(1) % state, block % time_levs(2) % state, block % mesh, dt )
- block => block % next
- end do
- end if
-
-! if(debug) then
- block => domain % blocklist
- do while (associated(block))
- scalar_min = 0.
- scalar_max = 0.
- do iCell = 1, block % mesh % nCellsSolve
- do k = 1, block % mesh % nVertLevels
- scalar_min = min(scalar_min, block % time_levs(2) % state % w % array(k,iCell))
- scalar_max = max(scalar_max, block % time_levs(2) % state % w % array(k,iCell))
- enddo
- enddo
- write(6,*) ' min, max w ',scalar_min, scalar_max
-
- scalar_min = 0.
- scalar_max = 0.
- do iEdge = 1, block % mesh % nEdgesSolve
- do k = 1, block % mesh % nVertLevels
- scalar_min = min(scalar_min, block % time_levs(2) % state % u % array(k,iEdge))
- scalar_max = max(scalar_max, block % time_levs(2) % state % u % array(k,iEdge))
- enddo
- enddo
- write(6,*) ' min, max u ',scalar_min, scalar_max
-
- scalar_min = 0.
- scalar_max = 0.
- do iCell = 1, block % mesh % nCellsSolve
- do k = 1, block % mesh % nVertLevels
- scalar_min = min(scalar_min, block % time_levs(2) % state % scalars % array(index_qc,k,iCell))
- scalar_max = max(scalar_max, block % time_levs(2) % state % scalars % array(index_qc,k,iCell))
- enddo
- enddo
- write(6,*) ' min, max qc ',scalar_min, scalar_max
-
- block => block % next
-
- end do
-! end if
-
-
- end subroutine srk3
-
-!---
-
- subroutine rk_integration_setup( s_old, s_new, grid )
-
- implicit none
- type (grid_state) :: s_new, s_old
- type (grid_meta) :: grid
- integer :: iCell, k
-
- grid % ru_save % array = grid % ru % array
- grid % rw_save % array = grid % rw % array
- grid % rtheta_p_save % array = grid % rtheta_p % array
- grid % rho_p_save % array = s_new % rho_p % array
-
- s_old % u % array = s_new % u % array
- s_old % w % array = s_new % w % array
- s_old % theta % array = s_new % theta % array
- s_old % rho_p % array = s_new % rho_p % array
- s_old % rho % array = s_new % rho % array
- s_old % pressure % array = s_new % pressure % array
-
-
- s_old % scalars % array = s_new % scalars % array
-
- end subroutine rk_integration_setup
-
-!-----
-
- subroutine compute_moist_coefficients( state, grid )
-
- implicit none
- type (grid_state) :: state
- type (grid_meta) :: grid
-
- integer :: iEdge, iCell, k, cell1, cell2, iq
- integer :: nCells, nEdges, nVertLevels, nCellsSolve
- real (kind=RKIND) :: qtot
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
- nCellsSolve = grid % nCellsSolve
-
- do iCell = 1, nCellsSolve
- do k = 2, nVertLevels
- qtot = 0.
- do iq = moist_start, moist_end
- qtot = qtot + 0.5 * (state % scalars % array (iq, k, iCell) + state % scalars % array (iq, k-1, iCell))
- end do
- grid % cqw % array(k,iCell) = 1./(1.+qtot)
- end do
- end do
-
- do iEdge = 1, nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k = 1, nVertLevels
- qtot = 0.
- do iq = moist_start, moist_end
- qtot = qtot + 0.5 * ( state % scalars % array (iq, k, cell1) + state % scalars % array (iq, k, cell2) )
- end do
- grid % cqu % array(k,iEdge) = 1./( 1. + qtot)
- end do
- end if
- end do
-
- end subroutine compute_moist_coefficients
-
-!---
-
- subroutine compute_vert_imp_coefs(s, grid, dts)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute coefficients for vertically implicit gravity-wave/acoustic computations
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - cofrz, cofwr, cofwz, coftz, cofwt, a, alpha and gamma
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(inout) :: grid
- real (kind=RKIND), intent(in) :: dts
-
- integer :: i, k, iq
-
- integer :: nCells, nVertLevels, nCellsSolve
- real (kind=RKIND), dimension(:,:), pointer :: zz, cqw, p, t, rb, rtb, pb, rt
- real (kind=RKIND), dimension(:,:), pointer :: cofwr, cofwz, coftz, cofwt, a_tri, alpha_tri, gamma_tri
- real (kind=RKIND), dimension(:), pointer :: cofrz, rdzw, fzm, fzp, rdzu
-
- real (kind=RKIND), dimension( grid % nVertLevels ) :: b_tri,c_tri
- real (kind=RKIND) :: epssm, dtseps, c2, qtot, rcv
-
-! set coefficients
-
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
-! epssm = grid % epssm ! this should come in through the namelist ******************
- epssm = 0.1
-
- rdzu => grid % rdzu % array
- rdzw => grid % rdzw % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zz => grid % zz % array
- cqw => grid % cqw % array
-
- p => grid % exner % array
- pb => grid % exner_base % array
- rt => grid % rtheta_p % array
- rtb => grid % rtheta_base % array
- rb => grid % rho_base % array
-
- alpha_tri => grid % alpha_tri % array
- gamma_tri => grid % gamma_tri % array
- a_tri => grid % a_tri % array
- cofwr => grid % cofwr % array
- cofwz => grid % cofwz % array
- coftz => grid % coftz % array
- cofwt => grid % cofwt % array
- cofrz => grid % cofrz % array
-
- t => s % theta % array
-
- dtseps = .5*dts*(1.+epssm)
- rcv = rgas/(cp-rgas)
- c2 = cp*rcv
-
- do k=1,nVertLevels
- cofrz(k) = dtseps*rdzw(k)
- end do
-
- do i = 1, nCellsSolve ! we only need to do cells we are solving for, not halo cells
-
- do k=2,nVertLevels
- cofwr(k,i) =.5*dtseps*gravity*(fzm(k)*zz(k,i)+fzp(k)*zz(k-1,i))
- end do
- do k=2,nVertLevels
- cofwz(k,i) = dtseps*c2*(fzm(k)*zz(k,i)+fzp(k)*zz(k-1,i)) &
- *rdzu(k)*cqw(k,i)*(fzm(k)*p (k,i)+fzp(k)*p (k-1,i))
- coftz(k,i) = dtseps* (fzm(k)*t (k,i)+fzp(k)*t (k-1,i))
- end do
- do k=1,nVertLevels
-
- qtot = 0.
- do iq = moist_start, moist_end
- qtot = qtot + s % scalars % array (iq, k, i)
- end do
-
- cofwt(k,i) = .5*dtseps*rcv*zz(k,i)*gravity*rb(k,i)/(1.+qtot) &
- *p(k,i)/((rtb(k,i)+rt(k,i))*pb(k,i))
- end do
-
- a_tri(1,i) = 0. ! note, this value is never used
- b_tri(1) = 1. ! note, this value is never used
- c_tri(1) = 0. ! note, this value is never used
- gamma_tri(1,i) = 0.
- alpha_tri(1,i) = 0. ! note, this value is never used
-
- do k=2,nVertLevels
- a_tri(k,i) = -cofwz(k ,i)* coftz(k-1,i)*rdzw(k-1)*zz(k-1,i) &
- +cofwr(k ,i)* cofrz(k-1 ) &
- -cofwt(k-1,i)* coftz(k-1,i)*rdzw(k-1)
- b_tri(k) = 1. &
- +cofwz(k ,i)*(coftz(k ,i)*rdzw(k )*zz(k ,i) &
- +coftz(k ,i)*rdzw(k-1)*zz(k-1,i)) &
- -coftz(k ,i)*(cofwt(k ,i)*rdzw(k ) &
- -cofwt(k-1,i)*rdzw(k-1)) &
- +cofwr(k, i)*(cofrz(k )-cofrz(k-1))
- c_tri(k) = -cofwz(k ,i)* coftz(k+1,i)*rdzw(k )*zz(k ,i) &
- -cofwr(k ,i)* cofrz(k ) &
- +cofwt(k ,i)* coftz(k+1,i)*rdzw(k )
- end do
- do k=2,nVertLevels
- alpha_tri(k,i) = 1./(b_tri(k)-a_tri(k,i)*gamma_tri(k-1,i))
- gamma_tri(k,i) = c_tri(k)*alpha_tri(k,i)
- end do
-
- end do ! loop over cells
-
- end subroutine compute_vert_imp_coefs
-
-!------------------------
-
- subroutine set_smlstep_pert_variables( s_old, s_new, tend, grid )
-
- implicit none
- type (grid_state) :: s_new, s_old, tend
- type (grid_meta) :: grid
- integer :: iCell, k
-
- grid % rho_pp % array = grid % rho_p_save % array - s_new % rho_p % array
-
- grid % ru_p % array = grid % ru_save % array - grid % ru % array
- grid % rtheta_pp % array = grid % rtheta_p_save % array - grid % rtheta_p % array
- grid % rtheta_pp_old % array = grid % rtheta_pp % array
- grid % rw_p % array = grid % rw_save % array - grid % rw % array
-
- do iCell = 1, grid % nCellsSolve
- do k = 2, grid % nVertLevels
- tend % w % array(k,iCell) = ( grid % fzm % array (k) * grid % zz % array(k ,iCell) + &
- grid % fzp % array (k) * grid % zz % array(k-1,iCell) ) &
- * tend % w % array(k,iCell)
- end do
- end do
-
- grid % ruAvg % array = 0.
- grid % wwAvg % array = 0.
-
- end subroutine set_smlstep_pert_variables
-
-!-------------------------------
-
- subroutine advance_acoustic_step( s, tend, grid, dts )
-
- implicit none
-
- type (grid_state) :: s, tend
- type (grid_meta) :: grid
- real (kind=RKIND), intent(in) :: dts
-
- real (kind=RKIND), dimension(:,:), pointer :: rho, theta, ru_p, rw_p, rtheta_pp, &
- rtheta_pp_old, zz, exner, cqu, ruAvg, &
- wwAvg, rho_pp, cofwt, coftz, zx, &
- a_tri, alpha_tri, gamma_tri, dss, &
- tend_ru, tend_rho, tend_rt, tend_rw, &
- zgrid, cofwr, cofwz, w
- real (kind=RKIND), dimension(:), pointer :: fzm, fzp, rdzw, dcEdge, AreaCell, cofrz, dvEdge
-
- real (kind=RKIND) :: smdiv, c2, rcv
- real (kind=RKIND), dimension( grid % nVertLevels ) :: du
- real (kind=RKIND), dimension( grid % nVertLevels + 1 ) :: dpzx
- real (kind=RKIND), dimension( grid % nVertLevels, grid % nCells ) :: ts, rs
- real (kind=RKIND), dimension( grid % nVertLevels + 1 , grid % nCells ) :: ws
-
- integer :: cell1, cell2, iEdge, iCell, k
- real (kind=RKIND) :: pgrad, flux1, flux2, flux, resm, epssm
-
- real (kind=RKIND) :: cf1, cf2, cf3
-
- integer :: nEdges, nCells, nCellsSolve, nVertLevels
-
- logical, parameter :: debug = .false.
-! logical, parameter :: debug = .true.
- logical, parameter :: debug1 = .false.
- real (kind=RKIND) :: wmax
- integer :: iwmax, kwmax
-
-!--
-
- rho => s % rho % array
- theta => s % theta % array
- w => s % w % array
-
- rtheta_pp => grid % rtheta_pp % array
- rtheta_pp_old => grid % rtheta_pp_old % array
- ru_p => grid % ru_p % array
- rw_p => grid % rw_p % array
- exner => grid % exner % array
- cqu => grid % cqu % array
- ruAvg => grid % ruAvg % array
- wwAvg => grid % wwAvg % array
- rho_pp => grid % rho_pp % array
- cofwt => grid % cofwt % array
- coftz => grid % coftz % array
- cofrz => grid % cofrz % array
- cofwr => grid % cofwr % array
- cofwz => grid % cofwz % array
- a_tri => grid % a_tri % array
- alpha_tri => grid % alpha_tri % array
- gamma_tri => grid % gamma_tri % array
- dss => grid % dss % array
-
- tend_ru => tend % u % array
- tend_rho => tend % rho % array
- tend_rt => tend % theta % array
- tend_rw => tend % w % array
-
- zz => grid % zz % array
- zx => grid % zx % array
- zgrid => grid % zgrid % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- rdzw => grid % rdzw % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- AreaCell => grid % AreaCell % array
-
-! might these be pointers instead? **************************
-
- nEdges = grid % nEdges
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
-
-! cf1, cf2 and cf3 should come from the initialization *************
-
- cf1 = 1.5
- cf2 = -0.5
- cf3 = 0.
-
-! these values should come from the namelist *****************
-
- epssm = 0.1
- smdiv = 0.1
-
- rcv = rgas/(cp-rgas)
- c2 = cp*rcv
- resm = (1.-epssm)/(1.+epssm)
-
- ts = 0.
- rs = 0.
- ws = 0.
-
- ! acoustic step divergence damping - forward weight rtheta_pp
- rtheta_pp_old = rtheta_pp + smdiv*(rtheta_pp - rtheta_pp_old)
-
- if(debug) write(0,*) ' updating ru_p '
-
- do iEdge = 1, nEdges
-
- cell1 = grid % cellsOnEdge % array (1,iEdge)
- cell2 = grid % cellsOnEdge % array (2,iEdge)
- ! update edge for block-owned cells
- if (cell1 <= grid % nCellsSolve .or. cell2 <= grid % nCellsSolve ) then
-
- k = 1
- dpzx(k) = .5*zx(k,iEdge)*(cf1*(zz(k ,cell2)*rtheta_pp_old(k ,cell2) &
- +zz(k ,cell1)*rtheta_pp_old(k ,cell1)) &
- +cf2*(zz(k+1,cell2)*rtheta_pp_old(k+1,cell2) &
- +zz(k+1,cell1)*rtheta_pp_old(k+1,cell1)) &
- +cf3*(zz(k+2,cell2)*rtheta_pp_old(k+2,cell2) &
- +zz(k+2,cell1)*rtheta_pp_old(k+2,cell1)))
- do k=2,grid % nVertLevels
- dpzx(k)=.5*zx(k,iEdge)*(fzm(k)*(zz(k ,cell2)*rtheta_pp_old(k ,cell2) &
- +zz(k ,cell1)*rtheta_pp_old(k ,cell1)) &
- +fzp(k)*(zz(k-1,cell2)*rtheta_pp_old(k-1,cell2) &
- +zz(k-1,cell1)*rtheta_pp_old(k-1,cell1)))
- end do
- dpzx(nVertLevels + 1) = 0.
-
- do k=1,nVertLevels
- pgrad = (rtheta_pp_old(k,cell2)-rtheta_pp_old(k,cell1))/dcEdge(iEdge) &
- - rdzw(k)*(dpzx(k+1)-dpzx(k))
- pgrad = 0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad
- du(k) = dts*(tend_ru(k,iEdge) - cqu(k,iEdge) * pgrad)
-
- ru_p(k,iEdge) = ru_p(k,iEdge) + du(k)
-
- if(debug) then
- if(iEdge == 3750) then
- write(0,*) ' k, pgrad, tend_ru ',k,pgrad,tend_ru(k,3750)
- end if
- end if
-
-! need to add horizontal fluxes into density update, rtheta update and w update
-
- flux = dts*dvEdge(iEdge)*ru_p(k,iEdge)
- rs(k,cell1) = rs(k,cell1)-flux/AreaCell(cell1)
- rs(k,cell2) = rs(k,cell2)+flux/AreaCell(cell2)
-
- flux = flux*0.5*(theta(k,cell2)+theta(k,cell1))
- ts(k,cell1) = ts(k,cell1)-flux/AreaCell(cell1)
- ts(k,cell2) = ts(k,cell2)+flux/AreaCell(cell2)
-
- ruAvg(k,iEdge) = ruAvg(k,iEdge) + ru_p(k,iEdge)
-
- end do
-
- do k=2,nVertLevels
- flux = dts*0.5*dvEdge(iEdge)*((zgrid(k,cell2)-zgrid(k,cell1))*(fzm(k)*du(k)+fzp(k)*du(k-1)) )
- flux2 = - (fzm(k)*zz(k ,cell2) +fzp(k)*zz(k-1,cell2))*flux/AreaCell(cell2)
- flux1 = - (fzm(k)*zz(k ,cell1) +fzp(k)*zz(k-1,cell1))*flux/AreaCell(cell1)
- ws(k,cell2) = ws(k,cell2) + flux2
- ws(k,cell1) = ws(k,cell1) + flux1
- enddo
-
- end if ! end test for block-owned cells
-
- end do ! end loop over edges
-
- ! saving rtheta_pp before update for use in divergence damping in next acoustic step
- rtheta_pp_old(:,:) = rtheta_pp(:,:)
-
- do iCell = 1, nCellsSolve
-
- do k=1, nVertLevels
- rs(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rs(k,iCell) &
- - cofrz(k)*resm*(rw_p(k+1,iCell)-rw_p(k,iCell))
- ts(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + ts(k,iCell) &
- - resm*rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) &
- -coftz(k,iCell)*rw_p(k,iCell))
- enddo
-
- do k=2, nVertLevels
-
- wwavg(k,iCell) = wwavg(k,iCell) + 0.5*(1.-epssm)*rw_p(k,iCell)
-
- rw_p(k,iCell) = rw_p(k,iCell) + ws(k,iCell) + dts*tend_rw(k,iCell) &
- - cofwz(k,iCell)*((zz(k ,iCell)*ts (k ,iCell) &
- -zz(k-1,iCell)*ts (k-1,iCell)) &
- +resm*(zz(k ,iCell)*rtheta_pp(k ,iCell) &
- -zz(k-1,iCell)*rtheta_pp(k-1,iCell))) &
- - cofwr(k,iCell)*((rs (k,iCell)+rs (k-1,iCell)) &
- +resm*(rho_pp(k,iCell)+rho_pp(k-1,iCell))) &
- + cofwt(k ,iCell)*(ts (k ,iCell)+resm*rtheta_pp(k ,iCell)) &
- + cofwt(k-1,iCell)*(ts (k-1,iCell)+resm*rtheta_pp(k-1,iCell))
- enddo
-
- do k=2,nVertLevels
- rw_p(k,iCell) = (rw_p(k,iCell)-a_tri(k,iCell)*rw_p(k-1,iCell))*alpha_tri(k,iCell)
- end do
-
- do k=nVertLevels,1,-1
- rw_p(k,iCell) = rw_p(k,iCell) - gamma_tri(k,iCell)*rw_p(k+1,iCell)                
- end do
-
- do k=2,nVertLevels
- rw_p(k,iCell) = (rw_p(k,iCell)-dts*dss(k,iCell)* &
- (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) &
- *(fzm(k)*rho(k,iCell)+fzp(k)*rho(k-1,iCell)) &
- *w(k,iCell) )/(1.+dts*dss(k,iCell))
-
- wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.+epssm)*rw_p(k,iCell)
-
- end do
-
- do k=1,nVertLevels
- rho_pp(k,iCell) = rs(k,iCell) - cofrz(k) *(rw_p(k+1,iCell)-rw_p(k ,iCell))
- rtheta_pp(k,iCell) = ts(k,iCell) - rdzw(k)*(coftz(k+1,iCell)*rw_p(k+1,iCell) &
- -coftz(k ,iCell)*rw_p(k ,iCell))
- end do
-
- end do ! end of loop over cells
-
- end subroutine advance_acoustic_step
-
-!------------------------
-
- subroutine recover_large_step_variables( s, grid, dt, ns )
-
- implicit none
- type (grid_state) :: s
- type (grid_meta) :: grid
- integer, intent(in) :: ns
- real (kind=RKIND), intent(in) :: dt
-
- real (kind=RKIND), dimension(:,:), pointer :: wwAvg, rw_save, w, rw, rw_p, rtheta_p, rtheta_pp, &
- rtheta_p_save, rt_diabatic_tend, rho_p, rho_p_save, &
- rho_pp, rho, rho_base, ruAvg, ru_save, ru_p, u, ru, &
- exner, exner_base, rtheta_base, pressure_p, &
- zz, theta, zgrid
- real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, AreaCell
- integer, dimension(:,:), pointer :: CellsOnEdge
-
- integer :: iCell, iEdge, k, cell1, cell2
- integer :: nVertLevels, nCells, nCellsSolve, nEdges, nEdgesSolve
- real (kind=RKIND) :: rcv, p0, cf1, cf2, cf3, flux
-
-! logical, parameter :: debug=.true.
- logical, parameter :: debug=.false.
-
-!---
-
- wwAvg => grid % wwAvg % array
- rw_save => grid % rw_save % array
- rw => grid % rw % array
- rw_p => grid % rw_p % array
- w => s % w % array
-
- rtheta_p => grid % rtheta_p % array
- rtheta_p_save => grid % rtheta_p_save % array
- rtheta_pp => grid % rtheta_pp % array
- rtheta_base => grid % rtheta_base % array
- rt_diabatic_tend => grid % rt_diabatic_tend % array
- theta => s % theta % array
-
- rho => s % rho % array
- rho_p => s % rho_p % array
- rho_p_save => grid % rho_p_save % array
- rho_pp => grid % rho_pp % array
- rho_base => grid % rho_base % array
-
- ruAvg => grid % ruAvg % array
- ru_save => grid % ru_save % array
- ru_p => grid % ru_p % array
- ru => grid % ru % array
- u => s % u % array
-
- exner => grid % exner % array
- exner_base => grid % exner_base % array
-
- pressure_p => s % pressure % array
-
- zz => grid % zz % array
- zgrid => grid % zgrid % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- dvEdge => grid % dvEdge % array
- AreaCell => grid % AreaCell % array
- CellsOnEdge => grid % CellsOnEdge % array
-
- nVertLevels = grid % nVertLevels
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nEdges = grid % nEdges
- nEdgesSolve = grid % nEdgesSolve
-
- rcv = rgas/(cp-rgas)
- p0 = 1.e+05 ! this should come from somewhere else...
- cf1 = 1.5
- cf2 = -0.5
- cf3 = 0.
-
- ! compute new density everywhere so we can compute u from ru.
- ! we will also need it to compute theta below
-
- do iCell = 1, nCells
-
- if(debug) then
- if( iCell == 479 ) then
- write(0,*) ' k,rho_old,rp_old, rho_pp '
- do k=1,nVertLevels
- write(0,*) k, rho(k,iCell) ,rho_p(k,iCell), rho_pp(k,iCell)
- enddo
- end if
- end if
-
- do k = 1, nVertLevels
-
- rho_p(k,iCell) = rho_p(k,iCell) + rho_pp(k,iCell)
-
- rho(k,iCell) = rho_p(k,iCell) + rho_base(k,iCell)
- end do
-
- ! recover owned-cell values in block
-
- if( iCell <= nCellsSolve ) then
-
- if(debug) then
- if( iCell == 479 ) then
- write(0,*) ' k, rw, rw_save, rw_p '
- do k=1,nVertLevels
- write(0,*) k, rw(k,iCell), rw_save(k,iCell) ,rw_p(k,iCell)
- enddo
- end if
- end if
-
- w(1,iCell) = 0.
- do k = 2, nVertLevels
- wwAvg(k,iCell) = rw(k,iCell) + (wwAvg(k,iCell) / float(ns))
-
- rw(k,iCell) = rw(k,iCell) + rw_p(k,iCell)
-
-
- ! pick up part of diagnosed w from omega
- w(k,iCell) = rw(k,iCell)/( (fzm(k)*zz (k,iCell)+fzp(k)*zz (k-1,iCell)) &
- *(fzm(k)*rho(k,iCell)+fzp(k)*rho(k-1,iCell)) )
- end do
- w(nVertLevels+1,iCell) = 0.
-
- if(debug) then
- if( iCell == 479 ) then
- write(0,*) ' k, rtheta_p_save, rtheta_pp, rtheta_base '
- do k=1,nVertLevels
- write(0,*) k, rtheta_p_save(k,iCell), rtheta_pp(k,iCell), rtheta_base(k,iCell)
- enddo
- end if
- end if
-
- do k = 1, nVertLevels
-
- rtheta_p(k,iCell) = rtheta_p(k,iCell) + rtheta_pp(k,iCell) ! - dt * rt_diabatic_tend(k,iCell)
-
-
- theta(k,iCell) = (rtheta_p(k,iCell) + rtheta_base(k,iCell))/rho(k,iCell)
- exner(k,iCell) = (zz(k,iCell)*(rgas/p0)*(rtheta_p(k,iCell)+rtheta_base(k,iCell)))**rcv
- ! pressure below is perturbation pressure - perhaps we should rename it in the Registry????
- pressure_p(k,iCell) = zz(k,iCell) * rgas * (exner(k,iCell)*rtheta_p(k,iCell)+rtheta_base(k,iCell) &
- * (exner(k,iCell)-exner_base(k,iCell)))
- end do
-
- end if
-
- end do
-
- ! recover time-averaged ruAvg on all edges of owned cells (for upcoming scalar transport).
- ! we solved for these in the acoustic-step loop.
- ! we will compute ru and u here also, given we are here, even though we only need them on nEdgesSolve
-
- do iEdge = 1, nEdges
-
- cell1 = CellsOnEdge(1,iEdge)
- cell2 = CellsOnEdge(2,iEdge)
-
- if( cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
-
- do k = 1, nVertLevels
- ruAvg(k,iEdge) = ru(k,iEdge) + (ruAvg(k,iEdge) / float(ns))
-
- ru(k,iEdge) = ru(k,iEdge) + ru_p(k,iEdge)
-
- u(k,iEdge) = 2.*ru(k,iEdge)/(rho(k,cell1)+rho(k,cell2))
- enddo
-
- flux = dvEdge(iEdge)*0.5*(cf1*u(1,iEdge)+cf2*u(2,iEdge)+cf3*u(3,iEdge))*(zgrid(1,cell2)-zgrid(1,cell1))
- w(1,cell2) = w(1,cell2)+flux/AreaCell(cell2)
- w(1,cell1) = w(1,cell1)+flux/AreaCell(cell1)
-
- do k = 2, nVertLevels
- flux = dvEdge(iEdge)*0.5*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge))*(zgrid(k,cell2)-zgrid(k,cell1))
- w(k,cell2) = w(k,cell2)+flux/AreaCell(cell2)
- w(k,cell1) = w(k,cell1)+flux/AreaCell(cell1)
- enddo
-
- end if
-
- enddo
-
- end subroutine recover_large_step_variables
-
-!---------------------------------------------------------------------------------------
-
- 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 (grid_state), intent(in) :: tend
- type (grid_state), intent(in) :: s_old
- type (grid_state), intent(out) :: s_new
- type (grid_meta), intent(in) :: grid
- real (kind=RKIND) :: dt
-
- integer :: i, iCell, iEdge, k, iScalar, cell1, cell2
- 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, rho_edge, rho, zgrid
- real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell, qv_init
- integer, dimension(:,:), pointer :: cellsOnEdge
-
- real (kind=RKIND), dimension( num_scalars, grid % nVertLevels + 1 ) :: wdtn
- integer :: nVertLevels
-
- real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw
- real (kind=RKIND) :: coef_3rd_order
-
-
- real (kind=RKIND) :: h_theta_eddy_visc2, v_theta_eddy_visc2, scalar_turb_flux, z1,z2,z3,z4,zm,z0,zp
- logical, parameter :: mix_full = .false.
-! logical, parameter :: mix_full = .true.
-
- 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
- uhAvg => grid % ruAvg % 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
- h_old => s_old % rho % array
- h_new => s_new % rho % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
-!**** fnm => grid % fnm % array
-!**** fnp => grid % fnp % array
-!**** rdnw => grid % rdnw % array
- fnm => grid % fzm % array
- fnp => grid % fzp % array
- rdnw => grid % rdzw % array
-
- nVertLevels = grid % nVertLevels
-
- h_theta_eddy_visc2 = config_h_theta_eddy_visc2
- v_theta_eddy_visc2 = config_v_theta_eddy_visc2
- rho_edge => s_new % rho_edge % array
- rho => s_new % rho % array
- qv_init => grid % qv_init % array
- zgrid => grid % zgrid % array
-
- 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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- end do
-
- else if (config_scalar_adv_order == 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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 if
- end do
-
- else if (config_scalar_adv_order == 4) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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 if
-
- end do
- end if
-
-! horizontal mixing for scalars - we could combine this with transport...
-
- 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)
- if (cell1 > 0 .and. cell2 > 0) then
-
- do k=1,grid % nVertLevels
- do iScalar=1,num_scalars
- scalar_turb_flux = h_theta_eddy_visc2*prandtl* &
- (scalar_new(iScalar,k,cell2) - scalar_new(iScalar,k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * rho_edge(k,iEdge) * scalar_turb_flux
- 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 if
- end do
-
- end if
-
- ! vertical mixing
-
- if ( v_theta_eddy_visc2 > 0.0 ) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- do iScalar=1,num_scalars
- scalar_tend(iScalar,k,iCell) = scalar_tend(iScalar,k,iCell) + v_theta_eddy_visc2*prandtl*rho(k,iCell)*(&
- (scalar_new(iScalar,k+1,iCell)-scalar_new(iScalar,k ,iCell))/(zp-z0) &
- -(scalar_new(iScalar,k ,iCell)-scalar_new(iScalar,k-1,iCell))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- if ( .not. mix_full) then
- iScalar = index_qv
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- scalar_tend(iScalar,k,iCell) = scalar_tend(iScalar,k,iCell) + v_theta_eddy_visc2*prandtl*rho(k,iCell)*(&
- (-qv_init(k+1)+qv_init(k))/(zp-z0) &
- -(-qv_init(k)+qv_init(k-1))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end if
-
- 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 (grid_state), intent(in) :: tend
- type (grid_state), intent(in) :: s_old
- type (grid_state), intent(out) :: s_new
- type (grid_meta), 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
- 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( num_scalars, grid % nEdges) :: h_flux
- real (kind=RKIND), dimension( num_scalars, grid % nCells, 2 ) :: v_flux, v_flux_upwind, s_update
- real (kind=RKIND), dimension( num_scalars, grid % nCells, 2 ) :: scale_out, scale_in
- real (kind=RKIND), dimension( 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
-
- scalar_old => s_old % scalars % array
- scalar_new => s_new % scalars % array
- deriv_two => grid % deriv_two % array
-!**** uhAvg => grid % uhAvg % array
- uhAvg => grid % ruAvg % 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
- h_old => s_old % rho % array
- h_new => s_new % rho % array
- wwAvg => grid % wwAvg % array
- areaCell => grid % areaCell % array
-
-!**** fnm => grid % fnm % array
-!**** fnp => grid % fnp % array
-!**** rdnw => grid % rdnw % array
- fnm => grid % fzm % array
- fnp => grid % fzp % array
- rdnw => grid % rdzw % 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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- end do
-
- else if (config_scalar_adv_order >= 3) then
-
- do iEdge=1,grid%nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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 if
- 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
- if (grid % cellsOnCell % array(i,iCell) > 0) then
- 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 if
-
- 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 dmpar_exch_halo_field2dReal(dminfo, scale_out(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_out(:,:,2), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(dminfo, scale_in(:,:,1), &
- num_scalars, grid % nCells, &
- cellsToSend, cellsToRecv)
- call dmpar_exch_halo_field2dReal(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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- 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)
- if (cell1 > 0 .and. cell2 > 0) then
- 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 if
- 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_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, rv;
- ! circulation; vorticity; and kinetic energy, ke) and the
- ! tendencies for height (h) and u (u)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- type (grid_state), intent(inout) :: tend
- type (grid_state), intent(in) :: s
- type (grid_meta), intent(in) :: grid
-
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, iq
- real (kind=RKIND) :: flux, vorticity_abs, rho_vertex, workpv, q, upstream_bias
-
- integer :: nCells, nEdges, nVertices, nVertLevels, nCellsSolve
- 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 :: fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
- real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, kiteAreasOnVertex, zgrid, rho_edge, rho, ru, u, v, tend_u, &
- circulation, divergence, vorticity, ke, pv_edge, theta, rw, tend_rho, &
- h_diabatic, tend_theta, tend_w, w, cqw, rb, rr, pp, pressure_b, zz, zx, cqu
- 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 ) :: wduz, wdwz, wdtz, dpzx
- real (kind=RKIND), dimension( grid % nVertLevels ) :: u_mix
- real (kind=RKIND) :: theta_edge, theta_turb_flux, z1, z2, z3, z4, zm, z0, zp, r
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, pgrad
-
- real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, t_init
-
- real (kind=RKIND), allocatable, dimension(:,:) :: rv, divergence_ru, qtot
- 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
- real (kind=RKIND) :: cf1, cf2, cf3
-
-! logical, parameter :: debug = .true.
- logical, parameter :: debug = .false.
- logical, parameter :: mix_full = .false.
-! logical, parameter :: mix_full = .true.
-
- rho => s % rho % array
- rho_edge => s % rho_edge % array
- rb => grid % rho_base % array
- rr => s % rho_p % array
- u => s % u % array
- ru => grid % ru % array
- w => s % w % array
- rw => grid % rw % array
- theta => s % theta % array
- circulation => s % circulation % array
- divergence => s % divergence % array
- vorticity => s % vorticity % array
- ke => s % ke % array
- pv_edge => s % pv_edge % array
- pp => s % pressure % array
- pressure_b => grid % pressure_base % 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
- zz => grid % zz % array
- zx => grid % zx % array
-
- tend_u => tend % u % array
- tend_theta => tend % theta % array
- tend_w => tend % w % array
- tend_rho => tend % rho % array
- h_diabatic => grid % rt_diabatic_tend % array
-
- t_init => grid % t_init % array
-
- rdzu => grid % rdzu % array
- rdzw => grid % rdzw % array
- fzm => grid % fzm % array
- fzp => grid % fzp % array
- zgrid => grid % zgrid % array
- cqw => grid % cqw % array
- cqu => grid % cqu % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertLevels = grid % nVertLevels
- nVertices = grid % nVertices
- nCellsSolve = grid % nCellsSolve
-
- 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
-
- cf1 = 1.5
- cf2 = -.5
- cf3 = 0.
-
- ! tendency for density
- ! divergence_ru may calculated in the diagnostic subroutine - it is temporary
- allocate(divergence_ru(nVertLevels, nCells))
- allocate(qtot(nVertLevels, nCells))
-
- divergence_ru(:,:) = 0.0
- do iEdge=1,grid % nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- flux = ru(k,iEdge)*dvEdge(iEdge)
- divergence_ru(k,cell1) = divergence_ru(k,cell1) + flux
- divergence_ru(k,cell2) = divergence_ru(k,cell2) - flux
- end do
- end do
-
- qtot(:,:)=0.
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,nVertLevels
- divergence_ru(k,iCell) = divergence_ru(k,iCell) * r
- tend_rho(k,iCell) = -divergence_ru(k,iCell)-rdzw(k)*(rw(k+1,iCell)-rw(k,iCell))
-
- do iq = moist_start, moist_end
- qtot(k,iCell) = qtot(k,iCell) + s % scalars % array (iq, k, iCell)
- end do
-
- end do
- end do
-
-#ifdef LANL_FORMULATION
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- ! horizontal pressure gradient, nonlinear Coriolis term and ke gradient
-
- k = 1
- dpzx(k) = .5*zx(k,iEdge)*(cf1*(pp(k ,cell2)+pp(k ,cell1)) &
- +cf2*(pp(k+1,cell2)+pp(k+1,cell1)) &
- +cf3*(pp(k+2,cell2)+pp(k+2,cell1)))
- do k = 2, nVertLevels
- dpzx(k) = .5*zx(k,iEdge)*(fzm(k)*(pp(k ,cell2)+pp(k ,cell1)) &
- +fzp(k)*(pp(k-1,cell2)+pp(k-1,cell1)))
- end do
- dpzx(nVertLevels+1) = 0.
-
-
- 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 * rho_edge(k,eoe)
- end do
- tend_u(k,iEdge) = rho_edge(k,iEdge)* (q - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)) &
- - u(k,iEdge)*0.5*(divergence_ru(k,cell1)+divergence_ru(k,cell2)) &
- - cqu(k,iEdge)*( (pp(k,cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) / dcEdge(iEdge) &
- -rdzw(k)*(dpzx(k+1)-dpzx(k)) )
- end do
-
- end do
-
-#endif
-
-#ifdef NCAR_FORMULATION
- !
- ! Compute mass fluxes tangential to each edge (i.e., through the faces of dual grid cells)
- !
-
- allocate(rv(nVertLevels, nEdges))
- rv(:,:) = 0.0
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- k = 1
- dpzx(k) = .5*zx(k,iEdge)*(cf1*(pp(k ,cell2)+pp(k ,cell1)) &
- +cf2*(pp(k+1,cell2)+pp(k+1,cell1)) &
- +cf3*(pp(k+2,cell2)+pp(k+2,cell1)))
- do k = 2, nVertLevels
- dpzx(k) = .5*zx(k,iEdge)*(fzm(k)*(pp(k ,cell2)+pp(k ,cell1)) &
- +fzp(k)*(pp(k-1,cell2)+pp(k-1,cell1)))
- end do
- dpzx(nVertLevels+1) = 0.
-
- do j=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(j,iEdge)
- do k=1,nVertLevels
- rv(k,iEdge) = rv(k,iEdge) + weightsOnEdge(j,iEdge) * ru(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 / (rho(k,cell1) + rho(k,cell2))
-
- tend_u(k,iEdge) = rho_edge(k,iEdge)* (workpv * rv(k,iEdge) - (ke(k,cell2) - ke(k,cell1)) / dcEdge(iEdge)) &
- - u(k,iEdge)*0.5*(divergence_ru(k,cell1)+divergence_ru(k,cell2)) &
- - cqu(k,iEdge)*( (pp(k,Cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) / dcEdge(iEdge) &
- -rdzw(k)*(dpzx(k+1)-dpzx(k)) )
-
- end do
-
- end do
- deallocate(rv)
-#endif
- deallocate(divergence_ru)
-
- !
- ! vertical advection for u
- !
- do iEdge=1,grid % nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- wduz(1) = 0.
- do k=2,nVertLevels
- wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2) )*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge))
- end do
- wduz(nVertLevels+1) = 0.
-
- do k=1,nVertLevels
- tend_u(k,iEdge) = tend_u(k,iEdge) - rdzw(k)*(wduz(k+1)-wduz(k))
- end do
- end do
-
- !
- ! 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 = rho_edge(k,iEdge)*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))
- allocate(delsq_u(nVertLevels, nEdges))
- allocate(delsq_circulation(nVertLevels, nVertices))
- allocate(delsq_vorticity(nVertLevels, nVertices))
-
- 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)
-
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- 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 if
- end do
-
- delsq_circulation(:,:) = 0.0
- do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) > 0) then
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(1,iEdge)) = delsq_circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) > 0) then
- do k=1,nVertLevels
- delsq_circulation(k,verticesOnEdge(2,iEdge)) = delsq_circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end if
- 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)
- if (cell1 <= nCellsSolve) then
- do k=1,nVertLevels
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) + delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- if (cell2 <= nCellsSolve) then
- do k=1,nVertLevels
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) - delsq_u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- 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="red">abla vorticity
- ! only valid for h_mom_eddy_visc4 == constant
- !
- u_diffusion = rho_edge(k,iEdge) * ( 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 mixing for u - 2nd order
- !
- if ( v_mom_eddy_visc2 > 0.0 ) then
-
- if (mix_full) then
-
- do iEdge=1,grid % nEdgesSolve
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=2,nVertLevels-1
-
- z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2))
- z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2))
- z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2))
- z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2))
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(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
-
- else ! idealized cases where we mix on the perturbation from the initial 1-D state
-
- do iEdge=1,grid % nEdgesSolve
-
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
-
- do k=1,nVertLevels
- u_mix = u(k,iEdge) - grid % u_init % array(k) * cos( grid % angleEdge % array(iEdge) )
- end do
-
- do k=2,nVertLevels-1
-
- z1 = 0.5*(zgrid(k-1,cell1)+zgrid(k-1,cell2))
- z2 = 0.5*(zgrid(k ,cell1)+zgrid(k ,cell2))
- z3 = 0.5*(zgrid(k+1,cell1)+zgrid(k+1,cell2))
- z4 = 0.5*(zgrid(k+2,cell1)+zgrid(k+2,cell2))
-
- zm = 0.5*(z1+z2)
- z0 = 0.5*(z2+z3)
- zp = 0.5*(z3+z4)
-
- tend_u(k,iEdge) = tend_u(k,iEdge) + rho_edge(k,iEdge) * v_mom_eddy_visc2*( &
- (u_mix(k+1)-u_mix(k ))/(zp-z0) &
- -(u_mix(k )-u_mix(k-1))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
- end if
-
-!----------- rhs for w
-
- tend_w(:,:) = 0.
-
- !
- ! horizontal advection for w
- !
-
- if (config_theta_adv_order == 2) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=2,grid % nVertLevels
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge) ) &
- *(w(k,cell1) + w(k,cell2))*0.5
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
- end do
- end if
- end do
-
- else if (config_theta_adv_order == 3) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * w(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * w(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * w(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * w(k,grid % CellsOnCell % array (i,cell2))
- end do
-
-! 3rd order stencil
- if( u(k,iEdge)+u(k-1,iEdge) > 0) then
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge))*( &
- 0.5*(w(k,cell1) + w(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
- else
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge))*( &
- 0.5*(w(k,cell1) + w(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell2) / 6. )
- end if
-
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
-
- end do
- end if
- end do
-
- else if (config_theta_adv_order == 4) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
-
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * w(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * w(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * w(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * w(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * (fzm(k)*ru(k,iEdge) + fzp(k)*ru(k-1,iEdge)) * ( &
- 0.5*(w(k,cell1) + w(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
-
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
- end do
-
- end if
-
- end do
- end if
-
- !
- ! horizontal mixing for w - 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)
- !
-
- ! Note: we are using quite a bit of the theta code here - could be combined later???
-
- if ( h_mom_eddy_visc2 > 0.0 ) then
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
- theta_turb_flux = h_mom_eddy_visc2*(w(k,cell2) - w(k,cell1))/dcEdge(iEdge)
- flux = 0.5*dvEdge (iEdge) * (rho_edge(k,iEdge)+rho_edge(k-1,iEdge)) * theta_turb_flux
- tend_w(k,cell1) = tend_w(k,cell1) + flux
- tend_w(k,cell2) = tend_w(k,cell2) - flux
- end do
-
- end if
- end do
-
- end if
-
- if ( h_mom_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_theta(nVertLevels, nCells))
-
- delsq_theta(:,:) = 0.
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
- delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*0.5*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1))/dcEdge(iEdge)
- delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*0.5*(rho_edge(k,iEdge)+rho_edge(k-1,iEdge))*(w(k,cell2) - w(k,cell1))/dcEdge(iEdge)
- end do
-
- end if
- end do
-
- do iCell = 1, nCells
- r = 1.0 / areaCell(iCell)
- do k=2,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)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=2,grid % nVertLevels
- theta_turb_flux = h_mom_eddy_visc4*(delsq_theta(k,cell2) - delsq_theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * theta_turb_flux
-
- tend_w(k,cell1) = tend_w(k,cell1) - flux
- tend_w(k,cell2) = tend_w(k,cell2) + flux
- end do
-
- end if
- end do
-
- deallocate(delsq_theta)
-
- end if
-
- !
- ! vertical advection, pressure gradient and buoyancy for w
- ! Note: we are also dividing through by the cell area after the horizontal flux divergence
- !
-
- do iCell = 1, nCells
- wdwz(1) = 0.
- do k=2,nVertLevels
- wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell))
- end do
- wdwz(nVertLevels+1) = 0.
- do k=2,nVertLevels
-
-
- tend_w(k,iCell) = tend_w(k,iCell)/areaCell(iCell) -rdzu(k)*(wdwz(k+1)-wdwz(k)) &
- - cqw(k,iCell)*( rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
- + gravity* &
-!shpark
- ( fzm(k)*rr(k,iCell) + fzm(k)*(rb(k,iCell)+rr(k,iCell))*qtot(k,iCell) &
- +fzp(k)*rr(k-1,iCell) + fzp(k)*(rb(k-1,iCell)+rr(k-1,iCell))*qtot(k-1,iCell) ))
-
-! - gravity*(fzm(k)*rb(k,iCell)+fzp(k)*rb(k-1,iCell)) ) &
-! - gravity*( fzm(k)*(rr(k,iCell)+rb(k,iCell)) + fzp(k)*(rr(k-1,iCell)+rb(k-1,iCell)) )
-
-
-
-! - cqw(k,iCell)*rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
-! - gravity*( fzm(k)*rr(k,iCell)+fzp(k)*rr(k-1,iCell) &
-! +(1.-cqw(k,iCell))*(fzm(k)*rb(k,iCell)+fzp(k)*rb(k-1,iCell)))
-
-
-
-! WCS version - cqw(k,iCell)*rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
-! - gravity*0.5*(rr(k,iCell)+rr(k-1,iCell)+(1.-cqw(k,iCell))*(rb(k,iCell)+rb(k-1,iCell)))
-
-!Joe formulation
-! - cqw(k,iCell)*( rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
-! - gravity*(fzm(k)*rb(k,iCell)+fzp(k)*rb(k-1,iCell)) ) &
-! - gravity*( fzm(k)*(rr(k,iCell)+rb(k,iCell)) + fzp(k)*(rr(k-1,iCell)+rb(k-1,iCell)) )
-
- end do
- end do
-
- !
- ! vertical mixing for w - 2nd order
- !
- if ( v_mom_eddy_visc2 > 0.0 ) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- tend_w(k,iCell) = tend_w(k,iCell) + v_mom_eddy_visc2*0.5*(rho(k,iCell)+rho(k-1,iCell))*( &
- (w(k+1,iCell)-w(k ,iCell))*rdzw(k) &
- -(w(k ,iCell)-w(k-1,iCell))*rdzw(k-1) )*rdzu(k)
- end do
- end do
-
- end if
- deallocate(qtot)
-
-!----------- rhs for theta
-
- tend_theta(:,:) = 0.
-
- !
- ! horizontal advection for theta
- !
-
- if (config_theta_adv_order == 2) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,grid % nVertLevels
- flux = dvEdge(iEdge) * ru(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 if
- end do
-
- else if (config_theta_adv_order == 3) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- 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) * ru(k,iEdge) * ( &
- 0.5*(theta(k,cell1) + theta(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1) / 6. )
- else
- flux = dvEdge(iEdge) * ru(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 if
- end do
-
- else if (config_theta_adv_order == 4) then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- if (cell1 > 0 .and. cell2 > 0) then
-
- 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)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- 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)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * theta(k,grid % CellsOnCell % array (i,cell2))
- end do
-
- flux = dvEdge(iEdge) * ru(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 if
-
- end do
- end if
-
-! write(0,*) ' pt 1 tend_theta(3,1120) ',tend_theta(3,1120)/AreaCell(1120)
-
- !
- ! 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)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=1,grid % nVertLevels
- theta_turb_flux = h_theta_eddy_visc2*prandtl*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- flux = dvEdge (iEdge) * rho_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 if
- end do
-
- end if
-
- if ( h_theta_eddy_visc4 > 0.0 ) then
-
- allocate(delsq_theta(nVertLevels, nCells))
-
- delsq_theta(:,:) = 0.
-
- do iEdge=1,grid % nEdges
- cell1 = grid % cellsOnEdge % array(1,iEdge)
- cell2 = grid % cellsOnEdge % array(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- do k=1,grid % nVertLevels
- delsq_theta(k,cell1) = delsq_theta(k,cell1) + dvEdge(iEdge)*rho_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- delsq_theta(k,cell2) = delsq_theta(k,cell2) - dvEdge(iEdge)*rho_edge(k,iEdge)*(theta(k,cell2) - theta(k,cell1))/dcEdge(iEdge)
- end do
-
- end if
- 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)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
-
- 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 if
- end do
-
- deallocate(delsq_theta)
-
- 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
- wdtz(1) = 0.
- do k=2,nVertLevels
- wdtz(k) = rw(k,icell)*(fzm(k)*theta(k,iCell)+fzp(k)*theta(k-1,iCell))
- end do
- wdtz(nVertLevels+1) = 0.
- do k=1,nVertLevels
- tend_theta(k,iCell) = tend_theta(k,iCell)/areaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k))
-!! tend_theta(k,iCell) = tend_theta(k) + rho(k,iCell)*h_diabatic(k,iCell)
- end do
- end do
-
- !
- ! vertical mixing for theta - 2nd order
- !
- if ( v_theta_eddy_visc2 > 0.0 ) then
-
- if (mix_full) then
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- 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*rho(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
-
- else ! idealized cases where we mix on the perturbation from the initial 1-D state
-
- do iCell = 1, grid % nCellsSolve
- do k=2,nVertLevels-1
- z1 = zgrid(k-1,iCell)
- z2 = zgrid(k ,iCell)
- z3 = zgrid(k+1,iCell)
- z4 = zgrid(k+2,iCell)
-
- 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*rho(k,iCell)*(&
- ((theta(k+1,iCell)-t_init(k+1))-(theta(k ,iCell)-t_init(k)))/(zp-z0) &
- -((theta(k ,iCell)-t_init(k))-(theta(k-1,iCell)-t_init(k-1)))/(z0-zm) )/(0.5*(zp-zm))
- end do
- end do
-
- end if
-
- end if
-
- end subroutine compute_dyn_tend
-
-!-------
-
- 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 (grid_state), intent(inout) :: s
- type (grid_meta), 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
- h => s % rho % array
- u => s % u % array
- v => s % v % array
- vh => s % rv % array
- h_edge => s % rho_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)
- if (cell1 > 0 .and. cell2 > 0) then
- do k=1,nVertLevels
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
- end if
- end do
-
-
-
- !
- ! Compute circulation and relative vorticity at each vertex
- !
- circulation(:,:) = 0.0
- do iEdge=1,nEdges
- if (verticesOnEdge(1,iEdge) > 0) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(1,iEdge)) = circulation(k,verticesOnEdge(1,iEdge)) - dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
- if (verticesOnEdge(2,iEdge) > 0) then
- do k=1,nVertLevels
- circulation(k,verticesOnEdge(2,iEdge)) = circulation(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end if
- 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)
- if (cell1 > 0) then
- do k=1,nVertLevels
- divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
- if(cell2 > 0) then
- do k=1,nVertLevels
- divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
- end do
- end if
-
- 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)
- if (eoe > 0) then
- do k = 1,nVertLevels
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end if
- 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 )
- !
- VTX_LOOP: do iVertex = 1,nVertices
- do i=1,grid % vertexDegree
- if (cellsOnVertex(i,iVertex) <= 0) cycle VTX_LOOP
- end do
- 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 VTX_LOOP
- ! 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)
- if(iEdge > 0) then
- do k=1,nVertLevels
- pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
- end do
- end if
- 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) - 0.5 * 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)
- if( iCell > 0) then
- do k = 1,nVertLevels
- pv_cell(k,iCell) = pv_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) / areaCell(iCell)
- end do
- end if
- 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
- if( cellsOnEdge(1,iEdge) > 0 .and. cellsOnEdge(2,iEdge) > 0) then
- do k = 1,nVertLevels
- gradPVn(k,iEdge) = (pv_cell(k,cellsOnEdge(2,iEdge)) - pv_cell(k,cellsOnEdge(1,iEdge))) / &
- dcEdge(iEdge)
- end do
- end if
- 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) - 0.5 * u(k,iEdge) *dt * gradPVn(k,iEdge)
- end do
- end do
-
-
- end subroutine compute_solve_diagnostics
-
-!----------
-
- subroutine init_coupled_diagnostics( state, grid )
-
- implicit none
-
- type (grid_state), intent(inout) :: state
- type (grid_meta), intent(inout) :: grid
-
- integer :: k,iEdge,i,iCell1,iCell2
-
- do iEdge = 1, grid%nEdges
- iCell1 = grid % cellsOnEdge % array(1,iEdge)
- iCell2 = grid % cellsOnEdge % array(2,iEdge)
- do k=1,grid % nVertLevels
- grid % ru % array(k,iEdge) = 0.5 * state % u % array(k,iEdge)*(state % rho % array(k,iCell1)+state % rho % array(k,iCell2))
- enddo
- enddo
-
- do i=1,grid%nCellsSolve
- do k=1,grid % nVertLevels + 1
- grid % rw % array (k,i) = 0.
- enddo
- enddo
-
- end subroutine init_coupled_diagnostics
-
-! ------------------------
-
- subroutine qd_kessler( state_old, state_new, grid, dt )
-
- implicit none
-
- type (grid_state), intent(inout) :: state_old, state_new
- type (grid_meta), intent(inout) :: grid
- real (kind=RKIND), intent(in) :: dt
-
- real (kind=RKIND), dimension( grid % nVertLevels ) :: t, rho, p, dzu, qv, qc, qr, qc1, qr1
-
- integer :: k,iEdge,i,iCell,nz1
- real (kind=RKIND) :: p0,rcv
-
-
- write(0,*) ' in qd_kessler '
-
- p0 = 1.e+05
- rcv = rgas/(cp-rgas)
- nz1 = grid % nVertLevels
-
- do iCell = 1, grid % nCellsSolve
-
- do k = 1, grid % nVertLevels
-
- grid % rt_diabatic_tend % array(k,iCell) = state_new % theta % array(k,iCell)
-
- t(k) = state_new % theta % array(k,iCell)/(1. + 1.61*state_new % scalars % array(index_qv,k,iCell))
- rho(k) = grid % zz % array(k,iCell)*state_new % rho % array(k,iCell)
- p(k) = grid % exner % array(k,iCell)
- qv(k) = max(0.,state_new % scalars % array(index_qv,k,iCell))
- qc(k) = max(0.,state_new % scalars % array(index_qc,k,iCell))
- qr(k) = max(0.,state_new % scalars % array(index_qr,k,iCell))
- qc1(k) = max(0.,state_old % scalars % array(index_qc,k,iCell))
- qr1(k) = max(0.,state_old % scalars % array(index_qr,k,iCell))
- dzu(k) = grid % dzu % array(k)
-
- end do
-
- call kessler( t,qv,qc,qc1,qr,qr1,rho,p,dt,dzu,nz1, 1)
-
- do k = 1, grid % nVertLevels
-
- grid % rt_diabatic_tend % array(k,iCell) = state_new % theta % array(k,iCell)
-
- state_new % theta % array(k,iCell) = t(k)*(1.+1.61*qv(k))
- grid % rt_diabatic_tend % array(k,iCell) = state_new % rho % array(k,iCell) * &
- (state_new % theta % array(k,iCell) - grid % rt_diabatic_tend % array(k,iCell))/dt
- grid % rtheta_p % array(k,iCell) = state_new % rho % array(k,iCell) * state_new % theta % array(k,iCell) &
- - grid % rtheta_base % array(k,iCell)
- state_new % scalars % array(index_qv,k,iCell) = qv(k)
- state_new % scalars % array(index_qc,k,iCell) = qc(k)
- state_new % scalars % array(index_qr,k,iCell) = qr(k)
-
- grid % exner % array(k,iCell) = &
- ( grid % zz % array(k,iCell)*(rgas/p0) * ( &
- grid % rtheta_p % array(k,iCell) &
- + grid % rtheta_base % array(k,iCell) ) )**rcv
-
- state_new % pressure % array(k,iCell) = &
- grid % zz % array(k,iCell) * rgas * ( &
- grid % exner % array(k,iCell)*grid % rtheta_p % array(k,iCell) &
- +grid % rtheta_base % array(k,iCell) * &
- (grid % exner % array(k,iCell) - grid % exner_base % array(k,iCell)) )
- end do
-
- end do
-
- write(0,*) ' exiting qd_kessler '
-
- end subroutine qd_kessler
-
-!-----------------------------------------------------------------------
- subroutine kessler( t1t, qv1t, qc1t, qc1, qr1t, qr1, &
- rho, pii, dt, dzu, nz1, nx )
-!-----------------------------------------------------------------------
-!
- implicit none
- integer :: nx, nz1
- real (kind=RKIND) :: t1t (nz1,nx), qv1t(nz1,nx), qc1t(nz1,nx), &
- qr1t(nz1,nx), qc1 (nz1,nx), qr1 (nz1,nx), &
- rho (nz1,nx), pii (nz1,nx), dzu(nz1)
- integer, parameter :: mz=200
- real (kind=RKIND) :: qrprod(mz), prod (mz), rcgs( mz), rcgsi (mz) &
- ,ern (mz), vt (mz), vtden(mz), gam (mz) &
- ,r (mz), rhalf(mz), velqr(mz), buoycy(mz) &
- ,pk (mz), pc (mz), f0 (mz), qvs (mz)
-
- real (kind=RKIND) :: c1, c2, c3, c4, f5, mxfall, dtfall, fudge, dt, velu, veld, artemp, artot
- real (kind=RKIND) :: cp, product, ackess, ckess, fvel, f2x, xk, xki, psl
- integer :: nfall
- integer :: i,k,n
-
- ackess = 0.001
- ckess = 2.2
- fvel = 36.34
- f2x = 17.27
- f5 = 237.3*f2x*2.5e6/1003.
- xk = .2875
- xki = 1./xk
- psl = 1000.
-
- do k=1,nz1
- r(k) = 0.001*rho(k,1)
- rhalf(k) = sqrt(rho(1,1)/rho(k,1))
- pk(k) = pii(k,1)
- pc(k) = 3.8/(pk(k)**xki*psl)
- f0(k) = 2.5e6/(1003.*pk(k))
- end do
-!
- do i=1,nx
- do k=1,nz1
- qrprod(k) = qc1t(k,i) &
- -(qc1t(k,i)-dt*amax1(ackess*(qc1(k,i)-.001), &
- 0.))/(1.+dt*ckess*qr1(k,i)**.875)
-                         velqr(k) = (qr1(k,i)*r(k))**1.1364*rhalf(k)
- qvs(k) = pc(k)*exp(f2x*(pk(k)*t1t(k,i)-273.) &
- /(pk(k)*t1t(k,i)- 36.))
- end do
- velu = (qr1(2,i)*r(2))**1.1364*rhalf(2)
- veld = (qr1(1,i)*r(1))**1.1364*rhalf(1)
- qr1t(1,i) = qr1t(1,i)+dt*(velu-veld)*fvel/(r(1)*dzu(2))
- do k=2,nz1-1
- qr1t(k,i) = qr1t(k,i)+dt*fvel/r(k) &
- *.5*((velqr(k+1)-velqr(k ))/dzu(k+1) &
- +(velqr(k )-velqr(k-1))/dzu(k ))
- end do
- qr1t(nz1,i) = qr1t(nz1,i)-dt*fvel*velqr(nz1-1) &
- /(r(nz1)*dzu(nz1)*(1.+1.))
- artemp = 36340.*(.5*(velqr(2)+velqr(1))+veld-velu)
- artot = artot+dt*artemp
- do k=1,nz1
- qc1t(k,i) = amax1(qc1t(k,i)-qrprod(k),0.)
- qr1t(k,i) = amax1(qr1t(k,i)+qrprod(k),0.)
- prod(k) = (qv1t(k,i)-qvs(k))/(1.+qvs(k)*f5 &
- /(pk(k)*t1t(k,i)-36.)**2)
- end do
- do k=1,nz1
- ern(k) = amin1(dt*(((1.6+124.9*(r(k)*qr1t(k,i))**.2046) &
- *(r(k)*qr1t(k,i))**.525)/(2.55e6*pc(k) &
- /(3.8 *qvs(k))+5.4e5))*(dim(qvs(k),qv1t(k,i)) &
- /(r(k)*qvs(k))), &
- amax1(-prod(k)-qc1t(k,i),0.),qr1t(k,i))
- end do
- do k=1,nz1
- buoycy(k) = f0(k)*(amax1(prod(k),-qc1t(k,i))-ern(k))
-                                qv1t(k,i) = amax1(qv1t(k,i) &
- -amax1(prod(k),-qc1t(k,i))+ern(k),0.)
- qc1t(k,i) = qc1t(k,i)+amax1(prod(k),-qc1t(k,i))
- qr1t(k,i) = qr1t(k,i)-ern(k)
- t1t (k,i) = t1t (k,i)+buoycy(k)
- end do
- end do
-
- end subroutine kessler
-
-end module time_integration
</font>
</pre>