<p><b>duda</b> 2011-03-24 12:01:46 -0600 (Thu, 24 Mar 2011)</p><p>Changes from Sang-Hun for rebalancing in the J&W test case<br>
in the non-hydrostatic core.<br>
<br>
<br>
M src/core_nhyd_atmos/module_test_cases.F<br>
</p><hr noshade><pre><font color="gray">Modified: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F 2011-03-24 17:43:19 UTC (rev 764)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F 2011-03-24 18:01:46 UTC (rev 765)
@@ -128,11 +128,10 @@
!.. initialization of moisture:
integer:: index_qv
-! real (kind=RKIND),parameter :: rh_max = 0.40 ! Maximum relative humidity
- real (kind=RKIND),parameter :: rh_max = 0.70 ! Maximum relative humidity
- real (kind=RKIND),dimension(:,:), pointer:: qsat,relhum
+ real (kind=RKIND),parameter :: rh_max = 0.40 ! Maximum relative humidity
+! real (kind=RKIND),parameter :: rh_max = 0.70 ! Maximum relative humidity
+ real (kind=RKIND),dimension(:,:), pointer:: qsat, relhum
real (kind=RKIND),dimension(:,:,:),pointer:: scalars
- real (kind=RKIND),dimension(grid%nVertLevels,grid%nCells):: qv
!.. end initialization of moisture.
integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
@@ -151,8 +150,7 @@
real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
- real (kind=RKIND), dimension(grid % nVertLevels) :: temperature
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp, ttemp
+ real (kind=RKIND) :: es, qvs, xnutr, znut, ptemp
integer :: iter
real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
@@ -160,20 +158,23 @@
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), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt, temperature_1d
real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf
! storage for (lat,z) arrays for zonal velocity calculation
- integer, parameter :: nlat=361
- real (kind=RKIND), dimension(grid % nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d
+ logical, parameter :: rebalance = .true.
+ integer, parameter :: nlat=721
real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal
- real (kind=RKIND), dimension(nlat, grid % nVertLevels) :: u_2d, etavs_2d
+ real (kind=RKIND), dimension(grid % nVertLevels + 1, nlat) :: zgrid_2d
+ real (kind=RKIND), dimension(grid % nVertLevels, nlat) :: u_2d, pp_2d, rho_2d, qv_2d, etavs_2d, zz_2d
+ real (kind=RKIND), dimension(grid % nVertLevels, nlat-1) :: zx_2d
real (kind=RKIND), dimension(nlat) :: lat_2d
- real (kind=RKIND) :: dlat
+ real (kind=RKIND) :: dlat, hx_1d
real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
+ logical, parameter :: moisture = .true.
!
! Scale all distances and areas from a unit sphere to one with radius a
!
@@ -243,7 +244,7 @@
scalars(:,:,:) = 0.0
qsat(:,:) = 0.0
relhum(:,:) = 0.0
- qv(:,:) = 0.0
+ qv_2d(:,:) = 0.0
!.. end initialization of moisture.
surface_pressure(:) = 0.0
@@ -280,7 +281,7 @@
! Metrics for hybrid coordinate and vertical stretching
- str = 1.5
+ str = 1.8
zt = 45000.
dz = zt/float(nz1)
@@ -375,47 +376,43 @@
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, 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
+ !do k=1,nz1
+ ! write(0,*) ' k, zx(k,1) ',k,zx(k,1)
+ !enddo
write(0,*) ' grid metrics setup complete '
-!************** section for 2d (lat,z) calc for zonal velocity
+!************** section for 2d (z,lat) calc for zonal velocity
dlat = 0.5*pii/float(nlat-1)
do i = 1,nlat
lat_2d(i) = float(i-1)*dlat
-! write(0,*) ' zonal setup, latitude = ',lat_2d(i)*180./pii
+ phi = lat_2d(i)
+ hx_1d = 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)
- do k=1,nz
- phi = lat_2d(i)
- hx_1d(k) = 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
-
do k=1,nz
- zgrid_1d(k) = (1.-ah(k))*(sh(k)*(zt-hx_1d(k))+hx_1d(k)) &
+ zgrid_2d(k,i) = (1.-ah(k))*(sh(k)*(zt-hx_1d)+hx_1d) &
+ ah(k) * sh(k)* zt
end do
do k=1,nz1
- zz_1d (k) = (zw(k+1)-zw(k))/(zgrid_1d(k+1)-zgrid_1d(k))
+ zz_2d (k,i) = (zw(k+1)-zw(k))/(zgrid_2d(k+1,i)-zgrid_2d(k,i))
end do
do k=1,nz1
- ztemp = .5*(zgrid_1d(k+1)+zgrid_1d(k))
+ ztemp = .5*(zgrid_2d(k+1,i)+zgrid_2d(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_1d(k))
+ rb (k,i) = ppb(k,i)/(rgas*t0b*zz_2d(k,i))
tb (k,i) = t0b/pb(k,i)
rtb(k,i) = rb(k,i)*tb(k,i)
p (k,i) = pb(k,i)
@@ -435,40 +432,43 @@
teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
end if
end do
- ! phi = grid % latCell % array (i)
+
phi = lat_2d (i)
do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
+ temperature_1d(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)
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)/(1.+0.61*qv_2d(k,i))
- ztemp = .5*(zgrid_1d(k)+zgrid_1d(k+1))
+ ztemp = .5*(zgrid_2d(k,i)+zgrid_2d(k+1,i))
ptemp = ppb(k,i) + pp(k,i)
- qv(k,i) = 0.
+ !get moisture
+ if (moisture) then
+ qv_2d(k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max )
+ end if
+
+ tt(k) = temperature_1d(k)*(1.+1.61*qv_2d(k,i))
end do
-
+
do itrp = 1,25
do k=1,nz1
- rr(k,i) = (pp(k,i)/(rgas*zz_1d(k)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
+ rr(k,i) = (pp(k,i)/(rgas*zz_2d(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) = p0-.5*dzw(1)*gravity &
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+qv_2d(1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+qv_2d(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))
+ ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
+ (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv_2d(k ,i) &
+ +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv_2d(k+1,i))
end do
do k=1,nz1
@@ -480,21 +480,28 @@
end do ! end outer iteration loop itr
do k=1,nz1
- etavs_2d(i,k) = (0.5*(ppb(k,i)+ppb(k,i)+pp(k,i)+pp(k,i))/p0 - 0.252)*pii/2.
-! u_2d(i,k) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(i,k))**1.5)
- u_2d(i,k) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(i,k))**1.5)*(rb(k,i)+rr(k,i))
+ rho_2d(k,i) = rr(k,i)+rb(k,i)
+ pp_2d(k,i) = pp(k,i)
+ etavs_2d(k,i) = ((ppb(k,i)+pp(k,i))/p0 - 0.252)*pii/2.
+ u_2d(k,i) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(k,i))**1.5)
end do
end do ! end loop over latitudes for 2D zonal wind field calc
-! do i=1,nlat
-! do k=1,nz1
-! u_2d(i,k) = u_2d(i,k) - u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(nlat/2,k))**1.5)
-! end do
-! end do
-!
-! write(22,*) nz1,nlat,u_2d
+ !SHP-balance:: in case of rebalacing for geostrophic wind component
+ if (rebalance) then
+ do i=1,nlat-1
+ do k=1,nz1
+ zx_2d(k,i) = (zgrid_2d(k,i+1)-zgrid_2d(k,i))/(dlat*r_earth)
+ end do
+ end do
+
+ call recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
+ cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
+
+ end if
+
!******************************************************************
!
@@ -503,7 +510,6 @@
! 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))
@@ -529,7 +535,7 @@
! iterations to converge temperature as a function of pressure
!
- do itr = 1,30
+ do itr = 1,10
do k=1,nz1
eta (k) = (ppb(k,i)+pp(k,i))/p0
@@ -542,24 +548,22 @@
end do
phi = grid % latCell % array (i)
do k=1,nz1
-! tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
- temperature(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
+ temperature_1d(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)
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)/(1.+0.61*scalars(index_qv,k,i))
ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
ptemp = ppb(k,i) + pp(k,i)
- if (config_mp_physics /= 0) then
+ !get moisture
+ if (moisture) then
+
+ !scalars(index_qv,k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max )
- !.. ldf (11-15-2010): move calculation of the relative humidity inside iteration loop to
- !.. calculate the saturation mixing ratio and initialize the water vapor mixing ratio.
- !.. We assume the temperature computed above is the virtual temperature when moisture is
- !.. present:
if(ptemp < 50000.) then
relhum(k,i) = 0.0
elseif(ptemp > p0) then
@@ -568,46 +572,36 @@
relhum(k,i) = (1.-((p0-ptemp)/50000.)**1.25)
endif
relhum(k,i) = min(rh_max,relhum(k,i))
-
- !.. conversion from virtual temperature to temperature:
- ttemp = temperature(k)/(1.+0.608*scalars(index_qv,k,i))
-
+
!.. calculation of water vapor mixing ratio:
- if (ttemp > 273.15) then
- es = 1000.*0.6112*exp(17.67*(ttemp-273.15)/(ttemp-29.65))
+ if (temperature_1d(k) > 273.15) then
+ es = 1000.*0.6112*exp(17.67*(temperature_1d(k)-273.15)/(temperature_1d(k)-29.65))
else
- es = 1000.*0.6112*exp(21.8745584*(ttemp-273.15)/(ttemp-7.66))
- end if
+ es = 1000.*0.6112*exp(21.8745584*(temperature_1d(k)-273.15)/(temperature_1d(k)-7.66))
+ end if
qsat(k,i) = (287.04/461.6)*es/(ptemp-es)
if(relhum(k,i) .eq. 0.0) qsat(k,i) = 0.0
scalars(index_qv,k,i) = relhum(k,i)*qsat(k,i)
- qv(k,i) = scalars(index_qv,k,i)
-
end if
- !.. conversion from virtual temperature to "modified" temperature:
- tt(k) = temperature(k)*(1+scalars(index_qv,k,i))
+ tt(k) = temperature_1d(k)*(1.+1.61*scalars(index_qv,k,i))
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)
+ 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)))
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+scalars(index_qv,1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+scalars(index_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))
+ (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
@@ -626,29 +620,23 @@
end do
!calculation of surface pressure:
- surface_pressure(i) = 0.5*dzw(1)*gravity &
+ surface_pressure(i) = 0.5*dzw(1)*gravity &
* (1.25*(rr(1,i) + rb(1,i)) * (1. + scalars(index_qv,1,i)) &
- 0.25*(rr(2,i) + rb(2,i)) * (1. + scalars(index_qv,2,i)))
surface_pressure(i) = surface_pressure(i) + pp(1,i) + ppb(1,i)
-! 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
- write(0,*)
- write(0,*) '--- initialization of water vapor:'
- do iCell = 1, grid % nCells
- if(iCell == 1 .or. iCell == grid % nCells) then
- do k = nz1, 1, -1
- write(0,202) iCell,k,t(k,iCell),relhum(k,iCell),qsat(k,iCell),scalars(index_qv,k,iCell)
- enddo
- write(0,*)
- endif
- enddo
+ !write(0,*)
+ !write(0,*) '--- initialization of water vapor:'
+ !do iCell = 1, grid % nCells
+ ! if(iCell == 1 .or. iCell == grid % nCells) then
+ ! do k = nz1, 1, -1
+ ! write(0,202) iCell,k,t(k,iCell),relhum(k,iCell),qsat(k,iCell),scalars(index_qv,k,iCell)
+ ! enddo
+ ! write(0,*)
+ ! endif
+ !enddo
lat_pert = latitude_pert*pii/180.
lon_pert = longitude_pert*pii/180.
@@ -676,26 +664,24 @@
u_pert = 0.0
end if
- call calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
+ if (rebalance) then
- 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)
+ call calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
+ do k=1,grid % nVertLevels
+ fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
- fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
+ else
-! if(k.eq.18) then
-! write(21,*) ' iEdge, u1, u2 ',iEdge,fluxk,u0*flux_zonal(k)
-! end if
-!! 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
+ 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)
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
+ end if
+
cell1 = grid % CellsOnEdge % array(1,iEdge)
cell2 = grid % CellsOnEdge % array(2,iEdge)
do k=1,nz1
@@ -742,8 +728,6 @@
d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
do i=1, grid % nEdgesOnCell % array (cell1)
d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
end do
@@ -816,7 +800,7 @@
eoe = edgesOnEdge(i,iEdge)
do k = 1, grid%nVertLevels
diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
+ end do
end do
end do
@@ -824,8 +808,8 @@
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)))
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+scalars(index_qv,1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+scalars(index_qv,2,i)))
write(0,*) ' i, psurf, lat ',i,psurf,grid%latCell%array(i)*180./3.1415828
enddo
@@ -836,7 +820,7 @@
implicit none
integer, intent(in) :: nz1,nlat
- real (kind=RKIND), dimension(nlat,nz1), intent(in) :: u_2d,etavs_2d
+ real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_2d,etavs_2d
real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
real (kind=RKIND), dimension(nz1), intent(out) :: flux_zonal
real (kind=RKIND), intent(in) :: lat1_in, lat2_in, dvEdge, a, u0
@@ -866,7 +850,7 @@
w2 = 0.5*(db-da)**2
do k=1,nz1
- flux_zonal(k) = flux_zonal(k) + w1*u_2d(i,k) + w2*u_2d(i+1,k)
+ flux_zonal(k) = flux_zonal(k) + w1*u_2d(k,i) + w2*u_2d(k,i+1)
end do
end if
@@ -881,7 +865,100 @@
end subroutine calc_flux_zonal
+ !SHP-balance
+ subroutine recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
+ cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
+ implicit none
+ integer, intent(in) :: nz1,nlat
+ real (kind=RKIND), dimension(nz1,nlat), intent(inout) :: u_2d
+ real (kind=RKIND), dimension(nz1,nlat), intent(in) :: rho_2d, pp_2d, qv_2d, zz_2d
+ real (kind=RKIND), dimension(nz1,nlat-1), intent(in) :: zx_2d
+ real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
+ real (kind=RKIND), dimension(nz1), intent(in) :: fzm, fzp, rdzw
+ real (kind=RKIND), intent(in) :: cf1, cf2, cf3, dlat
+
+ !local variable
+ real (kind=RKIND), dimension(nz1,nlat-1) :: pgrad, ru, u
+ real (kind=RKIND), dimension(nlat-1) :: f
+ real (kind=RKIND), dimension(nz1+1) :: dpzx
+
+ real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND) :: rdx, qtot, r_earth, phi
+ integer :: k,i, itr
+
+ r_earth = a
+ rdx = 1./(dlat*r_earth)
+
+ do i=1,nlat-1
+ do k=1,nz1
+ pgrad(k,i) = rdx*(pp_2d(k,i+1)/zz_2d(k,i+1)-pp_2d(k,i)/zz_2d(k,i))
+ end do
+
+ dpzx(:) = 0.
+
+ k=1
+ dpzx(k) = .5*zx_2d(k,i)*(cf1*(pp_2d(k ,i+1)+pp_2d(k ,i)) &
+ +cf2*(pp_2d(k+1,i+1)+pp_2d(k+1,i)) &
+ +cf3*(pp_2d(k+2,i+1)+pp_2d(k+2,i)))
+ do k=2,nz1
+ dpzx(k) = .5*zx_2d(k,i)*(fzm(k)*(pp_2d(k ,i+1)+pp_2d(k ,i)) &
+ +fzp(k)*(pp_2d(k-1,i+1)+pp_2d(k-1,i)))
+ end do
+
+ do k=1,nz1
+ pgrad(k,i) = pgrad(k,i) - rdzw(k)*(dpzx(k+1)-dpzx(k))
+ end do
+ end do
+
+
+ !initial value of v and rv -> that is from analytic sln.
+ do i=1,nlat-1
+ do k=1,nz1
+ u(k,i) = .5*(u_2d(k,i)+u_2d(k,i+1))
+ ru(k,i) = u(k,i)*(rho_2d(k,i)+rho_2d(k,i+1))*.5
+ end do
+ end do
+
+ write(0,*) "MAX U wind before REBALANCING ---->", maxval(abs(u))
+
+ !re-calculate geostrophic wind using iteration
+ do itr=1,50
+ do i=1,nlat-1
+ phi = (lat_2d(i)+lat_2d(i+1))/2.
+ f(i) = 2.*omega_e*sin(phi)
+ do k=1,nz1
+ if (f(i).eq.0.) then
+ ru(k,i) = 0.
+ else
+ qtot = .5*(qv_2d(k,i)+qv_2d(k,i+1))
+ ru(k,i) = - ( 1./(1.+qtot)*pgrad(k,i) + tan(phi)/r_earth*u(k,i)*ru(k,i) )/f(i)
+ end if
+ u(k,i) = ru(k,i)*2./(rho_2d(k,i)+rho_2d(k,i+1))
+ end do
+ end do
+ end do
+
+ write(0,*) "MAX U wind after REBALANCING ---->", maxval(abs(u))
+
+ !update 2d ru
+ do i=2,nlat-1
+ do k=1,nz1
+ u_2d(k,i) = (ru(k,i-1)+ru(k,i))*.5
+ end do
+ end do
+
+ i=1
+ do k=1,nz1
+ u_2d(k,i) = (3.*u_2d(k,i+1)-u_2d(k,i+2))*.5
+ end do
+ i=nlat
+ do k=1,nz1
+ u_2d(k,i) = (3.*u_2d(k,i-1)-u_2d(k,i-2))*.5
+ end do
+
+
+ end subroutine recompute_geostrophic_wind
!----------------------------------------------------------------------------------------------------------
subroutine nhyd_test_case_squall_line(dminfo, grid, state, diag, test_case)
@@ -1322,7 +1399,7 @@
end do
if (itr==1.and.i==1) then
do k=1,nz1
- print *, "pp-check", pp(k,i)
+ write(0,*) "pp-check", pp(k,i)
end do
end if
do k=1,nz1
@@ -1446,7 +1523,7 @@
real (kind=RKIND) :: ztemp, zd, zt, dz, str
real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, ptemp
+ real (kind=RKIND) :: es, qvs, xnutr, ptemp
integer :: iter
real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
@@ -1687,7 +1764,7 @@
end if
end do !end of iteration for smoothing
-99 print *,"PASS-SHP"
+99 write(0,*) "PASS-SHP"
end do
do iCell=1,grid % nCells
@@ -2031,4 +2108,46 @@
end function sphere_distance
+!--------------------------------------------------------------------
+ real function env_qv( z, temperature, pressure, rh_max )
+
+ implicit none
+ real z, temperature, pressure, ztr, es, qvs, p0, rh_max
+
+ p0 = 100000.
+
+! ztr = 5000.
+!
+! if(z .gt. ztr) then
+! env_qv = 0.
+! else
+! if(z.lt.2000.) then
+! env_qv = .5
+! else
+! env_qv = .5*(1.-(z-2000.)/(ztr-2000.))
+! end if
+! end if
+
+ if (pressure .lt. 50000. ) then
+ env_qv = 0.0
+ else
+ env_qv = (1.-((p0-pressure)/50000.)**1.25)
+ end if
+
+ env_qv = min(rh_max,env_qv)
+
+! env_qv is the relative humidity, turn it into mixing ratio
+ if (temperature .gt. 273.15) then
+ es = 1000.*0.6112*exp(17.67*(temperature-273.15)/(temperature-29.65))
+ else
+ es = 1000.*0.6112*exp(21.8745584*(temperature-273.16)/(temperature-7.66))
+ end if
+ qvs = (287.04/461.6)*es/(pressure-es)
+
+ ! qvs = 380.*exp(17.27*(temperature-273.)/(temperature-36.))/pressure
+
+ env_qv = env_qv*qvs
+
+ end function env_qv
+
end module test_cases
</font>
</pre>