<p><b>duda</b> 2010-07-12 13:38:09 -0600 (Mon, 12 Jul 2010)</p><p>BRANCH COMMIT<br>
<br>
Add initial non-hydrostatic files from Bill's MPAS_dev_nh_20100709.tar file.<br>
<br>
<br>
A namelist.input.nhyd_atmos_squall<br>
A graphics/ncl/cells_hex.ncl<br>
A graphics/ncl/cells_nhyd_sphere.ncl<br>
A graphics/ncl/cells_nhyd_sph1.ncl<br>
A graphics/ncl/xz_plane.ncl<br>
A src/core_nhyd_atmos<br>
A src/core_nhyd_atmos/module_test_cases.F.100705<br>
A src/core_nhyd_atmos/module_time_integration.F.0531<br>
A src/core_nhyd_atmos/module_time_integration.F.sh0609<br>
A src/core_nhyd_atmos/mpas_interface.F<br>
A src/core_nhyd_atmos/module_advection.F<br>
A src/core_nhyd_atmos/module_test_cases.F<br>
A src/core_nhyd_atmos/Registry<br>
A src/core_nhyd_atmos/module_test_cases.F.sh0614<br>
A src/core_nhyd_atmos/module_time_integration.F<br>
A src/core_nhyd_atmos/module_test_cases.F.0521<br>
A src/core_nhyd_atmos/Makefile<br>
A src/core_nhyd_atmos/module_test_cases.F.ok<br>
M Makefile<br>
A namelist.input.nhyd_atmos<br>
</p><hr noshade><pre><font color="gray">Modified: branches/atmos_nonhydrostatic/Makefile
===================================================================
--- branches/atmos_nonhydrostatic/Makefile 2010-07-12 17:52:40 UTC (rev 371)
+++ branches/atmos_nonhydrostatic/Makefile 2010-07-12 19:38:09 UTC (rev 372)
@@ -5,6 +5,10 @@
EXPAND_LEVELS = -DEXPAND_LEVELS=26
endif
+ifeq ($(CORE),nhyd_atmos)
+EXPAND_LEVELS = -DEXPAND_LEVELS=26
+endif
+
FILE_OFFSET = -DOFFSET64BIT
#########################
Added: branches/atmos_nonhydrostatic/graphics/ncl/cells_hex.ncl
===================================================================
--- branches/atmos_nonhydrostatic/graphics/ncl/cells_hex.ncl (rev 0)
+++ branches/atmos_nonhydrostatic/graphics/ncl/cells_hex.ncl 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,171 @@
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl"
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl"
+
+begin
+
+ plotfield = "w"
+ level = 5
+ winds = True
+ nrows = 100
+ ncols = 100
+ maxedges = 6
+
+ wks = gsn_open_wks("pdf","cells")
+ gsn_define_colormap(wks,"wh-bl-gr-ye-re")
+
+ f = addfile("output.nc","r")
+
+ xCell = f->xCell(:)
+ yCell = f->yCell(:)
+ zCell = f->zCell(:)
+ xEdge = f->xEdge(:)
+ yEdge = f->yEdge(:)
+ zEdge = f->zEdge(:)
+ xVertex = f->xVertex(:)
+ yVertex = f->yVertex(:)
+ zVertex = f->zVertex(:)
+ verticesOnCell = f->verticesOnCell(:,:)
+ edgesOnCell = f->edgesOnCell(:,:)
+ edgesOnEdge = f->edgesOnEdge(:,:)
+ verticesOnEdge = f->verticesOnEdge(:,:)
+ cellsOnEdge = f->cellsOnEdge(:,:)
+ cellsOnVertex = f->cellsOnVertex(:,:)
+ edgesOnVertex = f->edgesOnVertex(:,:)
+
+ res = True
+
+ t = stringtointeger(getenv("T"))
+
+ xpoly = new((/maxedges/), "double")
+ ypoly = new((/maxedges/), "double")
+
+ xcb = new((/4/), "float")
+ ycb = new((/4/), "float")
+
+ pres = True
+ pres@gsnFrame = False
+ pres@xyLineColor = "Background"
+ plot = gsn_xy(wks,xCell,yCell,pres)
+
+ if (plotfield .eq. "tracer") then
+ fld = f->tracers(t,:,0,0)
+ minfld = min(fld)
+ maxfld = max(fld)
+ end if
+ if (plotfield .eq. "w") then
+ fld = f->w(t,:,level)
+ minfld = min(fld)
+ maxfld = max(fld)
+ end if
+ if (plotfield .eq. "t") then
+ fld = f->theta(t,:,level)
+ minfld = min(fld)
+ maxfld = max(fld)
+ end if
+ if (plotfield .eq. "qr") then
+ fld = f->qr(t,:,level)
+ minfld = min(fld)
+ maxfld = max(fld)
+ end if
+ if (plotfield .eq. "ke") then
+ fld = f->ke(t,:,0)
+ minfld = min(fld)
+ maxfld = max(fld)
+ end if
+ if (plotfield .eq. "vorticity") then
+ fld = f->vorticity(t,:,0)
+ minfld = min(fld)
+ maxfld = max(fld)
+ end if
+ scalefac = 198.0/(maxfld - minfld)
+
+ if (plotfield .eq. "vorticity") then
+ do iRow=1,nrows-2
+ do iCol=1,ncols-2
+ iCell = iRow*ncols+iCol
+ do iVertex=2*iCell,2*iCell+1
+ do i=0,2
+ xpoly(i) = xCell(cellsOnVertex(iVertex,i)-1)
+ ypoly(i) = yCell(cellsOnVertex(iVertex,i)-1)
+ res@gsFillColor = doubletointeger((fld(iVertex)-minfld)*scalefac)+2
+ end do
+ gsn_polygon(wks,plot,xpoly,ypoly,res);
+ end do
+ end do
+ end do
+ end if
+
+ if (plotfield .eq. "h" .or. plotfield .eq. "ke" .or. plotfield .eq. "t" .or. plotfield .eq. "w" .or. plotfield .eq. "qr") then
+ do iRow=1,nrows-2
+ do iCol=0,ncols-2
+ iCell = iRow*ncols+iCol
+ do i=0,5
+ xpoly(i) = xVertex(verticesOnCell(iCell,i)-1)
+ ypoly(i) = yVertex(verticesOnCell(iCell,i)-1)
+ res@gsFillColor = doubletointeger((fld(iCell)-minfld)*scalefac)+2
+ end do
+ gsn_polygon(wks,plot,xpoly,ypoly,res);
+ end do
+ end do
+ end if
+
+ if (winds) then
+ u = 2.*f->u(t,:,level)
+ v = 2.*f->v(t,:,level)
+ alpha = f->angleEdge(:)
+ esizes = dimsizes(u)
+ u_earth = new(dimsizes(u),float)
+ v_earth = new(dimsizes(u),float)
+ xwind = new(dimsizes(u),float)
+ ywind = new(dimsizes(u),float)
+ do i=0,esizes(0)-1
+ u_earth(i) = doubletofloat(u(i)*cos(alpha(i)) - v(i)*sin(alpha(i)))
+ v_earth(i) = doubletofloat(u(i)*sin(alpha(i)) + v(i)*cos(alpha(i)))
+ xwind(i) = doubletofloat(xEdge(i))
+ ywind(i) = doubletofloat(yEdge(i))
+ end do
+
+ wmsetp("VCH",0.0010)
+ wmsetp("VRN",0.010)
+ wmsetp("VRS",100.0)
+ wmsetp("VCW",0.10)
+
+ wmvect(wks, xwind, ywind, u_earth, v_earth)
+ end if
+
+ ;
+ ; Draw label bar
+ ;
+ tres = True
+ tres@txAngleF = 90.0
+ tres@txFontHeightF = 0.015
+ do i=2,200
+ xcb(0) = 0.1 + i*0.8/198
+ ycb(0) = 0.1
+
+ xcb(1) = 0.1 + (i+1)*0.8/198
+ ycb(1) = 0.1
+
+ xcb(2) = 0.1 + (i+1)*0.8/198
+ ycb(2) = 0.15
+
+ xcb(3) = 0.1 + i*0.8/198
+ ycb(3) = 0.15
+
+ res@gsFillColor = i
+
+ gsn_polygon_ndc(wks,xcb,ycb,res);
+
+ j = (i-2) % 20
+ if ((j .eq. 0) .or. (i .eq. 200)) then
+ ff = minfld + (i-2) / scalefac
+ label = sprintf("%7.3g", ff)
+ gsn_text_ndc(wks, label, xcb(0), 0.05, tres)
+ end if
+
+ end do
+
+ frame(wks)
+
+end
+
Added: branches/atmos_nonhydrostatic/graphics/ncl/cells_nhyd_sph1.ncl
===================================================================
--- branches/atmos_nonhydrostatic/graphics/ncl/cells_nhyd_sph1.ncl (rev 0)
+++ branches/atmos_nonhydrostatic/graphics/ncl/cells_nhyd_sph1.ncl 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,202 @@
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl"
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl"
+
+begin
+
+ ;
+ ; Which field to plot
+ ;
+ plotfield = "h"
+; plotfield = "ke"
+; plotfield = "vorticity"
+
+ ;
+ ; Whether to plot wind vectors
+ ;
+; winds = True
+ winds = False
+
+ ;
+ ; Whether to do color-filled plot (filled=True) or
+ ; to plot contours of height field (filled=False)
+ ;
+ filled = True
+; filled = False
+
+ ;
+ ; The (lat,lon) the plot is to be centered over
+ ;
+ cenLat = 90.0
+ cenLon = 180.0
+
+ ;
+ ; Projection to use for plot
+ ;
+ projection = "Orthographic"
+; projection = "CylindricalEquidistant"
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ r2d = 57.2957795 ; radians to degrees
+
+ maxedges = 7
+
+; wks_type = "pdf"
+; wks_type@wkOrientation = "landscape"
+; wks = gsn_open_wks(wks_type,"cells")
+
+ wks = gsn_open_wks("pdf","cells")
+; wks = gsn_open_wks("x11","cells")
+ gsn_define_colormap(wks,"gui_default")
+
+ f = addfile("output.nc","r")
+
+ lonCell = f->lonCell(:) * r2d
+ latCell = f->latCell(:) * r2d
+ lonVertex = f->lonVertex(:) * r2d
+ latVertex = f->latVertex(:) * r2d
+ lonEdge = f->lonEdge(:) * r2d
+ latEdge = f->latEdge(:) * r2d
+ verticesOnCell = f->verticesOnCell(:,:)
+ alpha = f->angleEdge(:)
+
+ res = True
+ res@gsnMaximize = True
+ res@gsnSpreadColors = True
+
+ if (plotfield .eq. "h" .or. plotfield .eq. "ke") then
+ res@sfXArray = lonCell
+ res@sfYArray = latCell
+ end if
+ if (plotfield .eq. "vorticity") then
+ res@sfXArray = lonVertex
+ res@sfYArray = latVertex
+ end if
+
+ res@cnFillMode = "AreaFill"
+
+ if (filled) then
+ res@cnFillOn = True
+; res@cnLinesOn = False
+; res@cnRasterModeOn = True
+; res@cnLinesOn = False
+ res@cnLinesOn = True
+ res@cnLineLabelsOn = False
+ else
+ res@cnFillOn = False
+ res@cnLinesOn = True
+ res@cnLineLabelsOn = True
+ end if
+
+; res@cnLevelSpacingF = 10.0
+ res@cnInfoLabelOn = True
+
+ res@lbLabelAutoStride = True
+ res@lbBoxLinesOn = False
+
+ res@mpProjection = projection
+ res@mpDataBaseVersion = "MediumRes"
+ res@mpCenterLatF = cenLat
+ res@mpCenterLonF = cenLon
+ res@mpGridAndLimbOn = True
+; res@mpGridAndLimbDrawOrder = "PreDraw"
+ res@mpGridLineColor = "Background"
+ res@mpOutlineOn = False
+ res@mpFillOn = False
+ res@mpPerimOn = False
+ res@gsnFrame = False
+
+ res@cnLevelSelectionMode = 2
+ res@cnLevels = (/950.,960.,970.,980.,990.,1000.,1010.,1020./)
+
+ t = stringtointeger(getenv("T"))
+ if (plotfield .eq. "h") then
+; h = f->h(t,:,0)
+; hs = f->h_s(:)
+; fld = h + hs
+; h = f->ww(t,:,5)
+; h = (f->surface_pressure(t,:) + 219.4)/100.
+; h = f->geopotential(t,:,18)
+; h = f->theta(t,:,25)-f->theta(0,:,25)
+; h = f->theta(t,:,0)-f->theta_base(:,0)
+; h = f->surface_pressure(t,:)/100.
+; h = (f->surface_pressure(t,:)-f->surface_pressure(0,:))/100.
+; h = f->pressure(t,:,0)/100.
+; fld = h
+
+ cf1 = 2.
+ cf2 = -1.5
+ cf3 = .5
+
+; cf1 = 1.
+; cf2 = 0.
+; cf3 = 0.
+
+ pfirst = f->pressure(t,:,0)+f->pressure_base(:,0)
+ psecond = f->pressure(t,:,1)+f->pressure_base(:,1)
+ pthird = f->pressure(t,:,2)+f->pressure_base(:,2)
+; fld = (cf1*pfirst + cf2*psecond + cf3*pthird)/100.
+
+ rhofirst = f->rho(t,:,0)
+ rhosecond = f->rho(t,:,1)
+ qvfirst = f->qv(t,:,0)
+ qvsecond = f->qv(t,:,1)
+ rdzw = f->rdzw
+
+ gravity = 9.80616
+ fld = (pfirst + (0.5*gravity/rdzw(0))*(1.25*rhofirst*(1.+qvfirst) - 0.25*rhosecond*(1.+qvsecond)))/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)))
+
+
+; fld = f->pressure(t,:,25)+f->pressure_base(:,25)
+
+; zg = f->zgrid
+; csizes = dimsizes(pfirst)
+; fld = pfirst
+; do i=0,csizes(0)-1
+; zoff = (zg(i,1)-zg(i,0))/(zg(i,2)-zg(i,0))
+; fld(i) = ((1.+zoff)*pfirst(i) + -zoff*psecond(i))/100.
+; end do
+;
+ end if
+ if (plotfield .eq. "ke") then
+ fld = f->ke(t,:,18)
+ end if
+ if (plotfield .eq. "vorticity") then
+ fld = f->vorticity(t,:,1)
+ end if
+ res@cnLineDashPattern = 0
+ map = gsn_csm_contour_map(wks,fld,res)
+
+ if (winds) then
+ u = f->u(t,:,25) - f->u(0,:,25)
+ v = f->v(t,:,25) - f->v(0,:,25)
+ esizes = dimsizes(u)
+ u_earth = new(dimsizes(u),float)
+ v_earth = new(dimsizes(u),float)
+ lat_edge = new(dimsizes(u),float)
+ lon_edge = new(dimsizes(u),float)
+ do i=0,esizes(0)-1
+ u_earth(i) = doubletofloat(u(i)*cos(alpha(i)) - v(i)*sin(alpha(i)))
+ v_earth(i) = doubletofloat(u(i)*sin(alpha(i)) + v(i)*cos(alpha(i)))
+ lat_edge(i) = doubletofloat(latEdge(i))
+ lon_edge(i) = doubletofloat(lonEdge(i))
+ end do
+
+ wmsetp("VCH",0.0010)
+ wmsetp("VRN",0.010)
+ wmsetp("VRS",100.0)
+ wmsetp("VCW",0.10)
+
+ wmvectmap(wks, lat_edge, lon_edge, u_earth, v_earth)
+ end if
+
+ frame(wks)
+
+end
+
Added: branches/atmos_nonhydrostatic/graphics/ncl/cells_nhyd_sphere.ncl
===================================================================
--- branches/atmos_nonhydrostatic/graphics/ncl/cells_nhyd_sphere.ncl (rev 0)
+++ branches/atmos_nonhydrostatic/graphics/ncl/cells_nhyd_sphere.ncl 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,215 @@
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl"
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl"
+
+begin
+
+ ;
+ ; Which field to plot
+ ;
+ plotfield = "h"
+; plotfield = "ke"
+; plotfield = "vorticity"
+
+ ;
+ ; Whether to plot wind vectors
+ ;
+; winds = True
+ winds = False
+
+ ;
+ ; Whether to do color-filled plot (filled=True) or
+ ; to plot contours of height field (filled=False)
+ ;
+ filled = True
+; filled = False
+
+ ;
+ ; The (lat,lon) the plot is to be centered over
+ ;
+ cenLat = 90.0
+ cenLon = 180.0
+
+ ;
+ ; Projection to use for plot
+ ;
+ projection = "Orthographic"
+; projection = "CylindricalEquidistant"
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ r2d = 57.2957795 ; radians to degrees
+
+ maxedges = 7
+
+; wks_type = "pdf"
+; wks_type@wkOrientation = "landscape"
+; wks = gsn_open_wks(wks_type,"cells")
+
+ wks = gsn_open_wks("pdf","cells")
+; wks = gsn_open_wks("x11","cells")
+ gsn_define_colormap(wks,"gui_default")
+
+ f = addfile("output.nc","r")
+
+ lonCell = f->lonCell(:) * r2d
+ latCell = f->latCell(:) * r2d
+ lonVertex = f->lonVertex(:) * r2d
+ latVertex = f->latVertex(:) * r2d
+ lonEdge = f->lonEdge(:) * r2d
+ latEdge = f->latEdge(:) * r2d
+ verticesOnCell = f->verticesOnCell(:,:)
+ alpha = f->angleEdge(:)
+
+ res = True
+ res@gsnMaximize = True
+ res@gsnSpreadColors = True
+
+ if (plotfield .eq. "h" .or. plotfield .eq. "ke") then
+ res@sfXArray = lonCell
+ res@sfYArray = latCell
+ end if
+ if (plotfield .eq. "vorticity") then
+ res@sfXArray = lonVertex
+ res@sfYArray = latVertex
+ end if
+
+ res@cnFillMode = "AreaFill"
+
+ if (filled) then
+ res@cnFillOn = True
+; res@cnLinesOn = False
+; res@cnRasterModeOn = True
+ res@cnLinesOn = True
+ res@cnLineLabelsOn = False
+ else
+ res@cnFillOn = False
+ res@cnLinesOn = True
+ res@cnLineLabelsOn = True
+ end if
+
+; res@cnLevelSpacingF = 10.0
+ res@cnInfoLabelOn = True
+
+ res@lbLabelAutoStride = True
+ res@lbBoxLinesOn = False
+
+ res@mpProjection = projection
+ res@mpDataBaseVersion = "MediumRes"
+ res@mpCenterLatF = cenLat
+ res@mpCenterLonF = cenLon
+
+ res@mpMinLatF = 0.
+ res@mpMaxLatF = 90.
+
+ res@mpGridAndLimbOn = True
+; res@mpGridAndLimbDrawOrder = "PreDraw"
+ res@mpGridLineColor = "Background"
+ res@mpOutlineOn = False
+ res@mpFillOn = False
+ res@mpPerimOn = False
+ res@gsnFrame = False
+
+ res@cnLevelSelectionMode = 2
+ res@cnLevels = (/950.,960.,970.,980.,990.,1000.,1010.,1020./)
+; res@cnLevels = (/962.,966.,970.,974.,978.,982.,986.,990.,994.,998.,1002.,1006.,1010.,1014./)
+; res@cnLevels = (/952.,956.,960.,964.,968.,972.,976.,980.,984.,988.,992.,996.,1000.,1004.,1008.,1012.,1016.,1020./)
+
+; res@cnMinLevelValF=
+; res@cnMaxLevelValF=
+; res@cnLevelSpacingF=
+
+
+ t = stringtointeger(getenv("T"))
+ if (plotfield .eq. "h") then
+; h = f->h(t,:,0)
+; hs = f->h_s(:)
+; fld = h + hs
+; h = f->ww(t,:,5)
+; h = (f->surface_pressure(t,:) + 219.4)/100.
+; h = f->geopotential(t,:,18)
+; h = f->theta(t,:,25)-f->theta(0,:,25)
+; h = f->theta(t,:,0)-f->theta_base(:,0)
+; h = f->surface_pressure(t,:)/100.
+; h = (f->surface_pressure(t,:)-f->surface_pressure(0,:))/100.
+; h = f->pressure(t,:,0)/100.
+; fld = h
+
+ cf1 = 2.
+ cf2 = -1.5
+ cf3 = .5
+
+; cf1 = 1.
+; cf2 = 0.
+; cf3 = 0.
+
+ pfirst = f->pressure(t,:,0)+f->pressure_base(:,0)
+ psecond = f->pressure(t,:,1)+f->pressure_base(:,1)
+ pthird = f->pressure(t,:,2)+f->pressure_base(:,2)
+ fld = (cf1*pfirst + cf2*psecond + cf3*pthird)/100.
+
+ rhofirst = f->rho(t,:,0)
+ rhosecond = f->rho(t,:,1)
+ qvfirst = f->qv(t,:,0)
+ qvsecond = f->qv(t,:,1)
+ rdzw = f->rdzw
+
+ gravity = 9.80616
+ fld = (pfirst + (0.5*gravity/rdzw(0))*(1.25*rhofirst*(1.+qvfirst) - 0.25*rhosecond*(1.+qvsecond)))/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)))
+
+
+; fld = f->pressure(t,:,25)+f->pressure_base(:,25)
+
+; zg = f->zgrid
+; csizes = dimsizes(pfirst)
+; fld = pfirst
+; do i=0,csizes(0)-1
+; zoff = (zg(i,1)-zg(i,0))/(zg(i,2)-zg(i,0))
+; fld(i) = ((1.+zoff)*pfirst(i) + -zoff*psecond(i))/100.
+; end do
+;
+
+; fld = f->theta(t,:,0)
+
+ end if
+ if (plotfield .eq. "ke") then
+ fld = f->ke(t,:,18)
+ end if
+ if (plotfield .eq. "vorticity") then
+ fld = f->vorticity(t,:,2)
+ end if
+ res@cnLineDashPattern = 0
+ map = gsn_csm_contour_map(wks,fld,res)
+
+ if (winds) then
+ u = f->u(t,:,25) - f->u(0,:,25)
+ v = f->v(t,:,25) - f->v(0,:,25)
+ esizes = dimsizes(u)
+ u_earth = new(dimsizes(u),float)
+ v_earth = new(dimsizes(u),float)
+ lat_edge = new(dimsizes(u),float)
+ lon_edge = new(dimsizes(u),float)
+ do i=0,esizes(0)-1
+ u_earth(i) = doubletofloat(u(i)*cos(alpha(i)) - v(i)*sin(alpha(i)))
+ v_earth(i) = doubletofloat(u(i)*sin(alpha(i)) + v(i)*cos(alpha(i)))
+ lat_edge(i) = doubletofloat(latEdge(i))
+ lon_edge(i) = doubletofloat(lonEdge(i))
+ end do
+
+ wmsetp("VCH",0.0010)
+ wmsetp("VRN",0.010)
+ wmsetp("VRS",100.0)
+ wmsetp("VCW",0.10)
+
+ wmvectmap(wks, lat_edge, lon_edge, u_earth, v_earth)
+ end if
+
+ frame(wks)
+
+end
+
Added: branches/atmos_nonhydrostatic/graphics/ncl/xz_plane.ncl
===================================================================
--- branches/atmos_nonhydrostatic/graphics/ncl/xz_plane.ncl (rev 0)
+++ branches/atmos_nonhydrostatic/graphics/ncl/xz_plane.ncl 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,161 @@
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl"
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl"
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/contributed.ncl"
+
+begin
+ r2d = 57.2957795 ; radians to degrees
+ pi = 3.14159265
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ; Set the field to be plotted in the section labeled SET FIELD HERE
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;
+ ; Whether to plot horizontal wind vectors
+ ;
+ horiz_winds = True
+; horiz_winds = False
+
+ ;
+ ; Whether to do color-filled plot (filled=True) or
+ ; to plot contours of height field (filled=False)
+ ;
+; filled = True
+ filled = False
+
+ ;
+ ; The number of rows and columns in the data set
+ ;
+ nrows = 4
+ ncols = 200
+
+ ;
+ ; The row number (between 1 and nrows) to plot
+ ;
+ irow = 1
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ wks = gsn_open_wks("pdf","xsec")
+ gsn_define_colormap(wks,"gui_default")
+
+ f = addfile("output.nc","r")
+
+ lonCell = f->lonCell(:) * r2d
+ latCell = f->latCell(:) * r2d
+ xCell = f->xCell(:)
+ yCell = f->yCell(:)
+ zCell = f->zCell(:)
+ lonVertex = f->lonVertex(:) * r2d
+ latVertex = f->latVertex(:) * r2d
+ xVertex = f->xVertex(:)
+ yVertex = f->yVertex(:)
+ zVertex = f->zVertex(:)
+ lonEdge = f->lonEdge(:) * r2d
+ latEdge = f->latEdge(:) * r2d
+ xEdge = f->xEdge(:)
+ yEdge = f->yEdge(:)
+ zEdge = f->zEdge(:)
+ verticesOnCell = f->verticesOnCell(:,:)
+ edgesOnCell = f->edgesOnCell(:,:)
+ nCellsOnCell = f->nEdgesOnCell(:)
+ cellsOnCell = f->cellsOnCell(:,:)
+ alpha = f->angleEdge(:)
+
+ dims = dimsizes(latCell)
+ nCells = dims(0)
+
+ nsec = ncols
+
+ xsec_id = new((/nsec/),integer)
+ xsec_edge_id = new((/nsec+1/),integer)
+
+ do i=0,nsec-1
+ xsec_id(i) = i + ncols * (irow-1)
+ xsec_edge_id(i) = 3 * (xsec_id(i))
+ end do
+ xsec_edge_id(nsec) = xsec_edge_id(nsec-1) + 3
+
+ res = True
+ res@gsnMaximize = True
+ res@gsnSpreadColors = True
+
+ res@cnFillMode = "AreaFill"
+
+ if (filled) then
+ res@cnFillOn = True
+ res@cnLinesOn = False
+ res@cnLineLabelsOn = False
+ else
+ res@cnFillOn = False
+ res@cnLinesOn = True
+ res@cnLineLabelsOn = True
+ end if
+
+; res@cnLevelSpacingF = 50.0
+ res@cnInfoLabelOn = True
+
+ res@lbLabelAutoStride = True
+ res@lbBoxLinesOn = False
+
+ res@gsnFrame = False
+
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; BEGIN SET FIELD HERE
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ t = stringtointeger(getenv("T"))
+
+ fld = f->tx(t,:,:)
+ ldims = dimsizes(fld)
+ nVertLevels = ldims(1)
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; END SET FIELD HERE
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ res@cnLineDashPattern = 0
+
+ ; Extract field from along cross section into plotting array
+ arr = new((/nVertLevels,nsec/),float)
+ do i=0,nsec-1
+ do j=0,nVertLevels-1
+ arr(j,i) = doubletofloat(fld(xsec_id(i),j))
+ end do
+ end do
+
+ map = gsn_csm_contour(wks,arr,res)
+
+ if (horiz_winds) then
+ u = f->u(t,:,:)
+ v = f->v(t,:,:)
+ esizes = dimsizes(u)
+ u_earth = new((/nVertLevels,nsec/),float)
+ v_earth = new((/nVertLevels,nsec/),float)
+ x_edge = new((/nVertLevels,nsec/),float)
+ y_edge = new((/nVertLevels,nsec/),float)
+ do i=0,nsec-1
+ do j=0,nVertLevels-1
+ u_earth(j,i) = doubletofloat(u(xsec_edge_id(i),j)*cos(alpha(xsec_edge_id(i))) - v(xsec_edge_id(i),j)*sin(alpha(xsec_edge_id(i))))
+ v_earth(j,i) = doubletofloat(u(xsec_edge_id(i),j)*sin(alpha(xsec_edge_id(i))) + v(xsec_edge_id(i),j)*cos(alpha(xsec_edge_id(i))))
+ x_edge(j,i) = i
+ y_edge(j,i) = j
+ end do
+ end do
+
+ wmsetp("VCH",0.0010)
+ wmsetp("VRN",0.010)
+ wmsetp("VRS",100.0)
+ wmsetp("VCW",0.10)
+
+ wmvect(wks, x_edge, y_edge, u_earth, v_earth)
+ end if
+
+ frame(wks)
+
+end
+
Added: branches/atmos_nonhydrostatic/namelist.input.nhyd_atmos
===================================================================
--- branches/atmos_nonhydrostatic/namelist.input.nhyd_atmos (rev 0)
+++ branches/atmos_nonhydrostatic/namelist.input.nhyd_atmos 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,32 @@
+&sw_model
+ config_test_case = 2
+ config_time_integration = 'SRK3'
+ config_dt = 1800
+ config_ntimesteps = 480
+ config_output_interval = 48
+ config_number_of_sub_steps = 6
+ config_h_mom_eddy_visc2 = 0000.
+ config_h_mom_eddy_visc4 = 0.
+ config_v_mom_eddy_visc2 = 00.0
+ config_h_theta_eddy_visc2 = 0000.
+ config_h_theta_eddy_visc4 = 00.
+ config_v_theta_eddy_visc2 = 00.0
+ config_theta_adv_order = 2
+ config_scalar_adv_order = 2
+ config_positive_definite = .false.
+ config_monotonic = .false.
+ config_epssm = 0.1
+ config_smdiv = 0.1
+/
+
+&io
+ config_input_name = 'grid.nc'
+ config_output_name = 'output.nc'
+ config_restart_name = 'restart.nc'
+/
+
+&restart
+ config_restart_interval = 3000
+ config_do_restart = .false.
+ config_restart_time = 1036800.0
+/
Added: branches/atmos_nonhydrostatic/namelist.input.nhyd_atmos_squall
===================================================================
--- branches/atmos_nonhydrostatic/namelist.input.nhyd_atmos_squall (rev 0)
+++ branches/atmos_nonhydrostatic/namelist.input.nhyd_atmos_squall 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,30 @@
+&sw_model
+ config_test_case = 1
+ config_time_integration = 'SRK3'
+ config_dt = 6.
+ config_ntimesteps = 600
+ config_output_interval = 100
+ config_number_of_sub_steps = 6
+ config_h_mom_eddy_visc2 = 500.
+ config_h_mom_eddy_visc4 = 0.
+ config_v_mom_eddy_visc2 = 500.0
+ config_h_theta_eddy_visc2 = 500.
+ config_h_theta_eddy_visc4 = 00.
+ config_v_theta_eddy_visc2 = 500.0
+ config_theta_adv_order = 2
+ config_scalar_adv_order = 2
+ config_positive_definite = .false.
+ config_monotonic = .false.
+/
+
+&io
+ config_input_name = 'grid.nc'
+ config_output_name = 'output.nc'
+ config_restart_name = 'restart.nc'
+/
+
+&restart
+ config_restart_interval = 3000
+ config_do_restart = .false.
+ config_restart_time = 1036800.0
+/
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/Makefile
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/Makefile (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/Makefile 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,27 @@
+.SUFFIXES: .F .o
+
+OBJS = module_test_cases.o \
+ module_time_integration.o \
+ module_advection.o \
+ mpas_interface.o
+
+all: core_hyd
+
+core_hyd: $(OBJS)
+ ar -ru libdycore.a $(OBJS)
+
+module_test_cases.o:
+
+module_time_integration.o:
+
+module_advection.o:
+
+mpas_interface.o: module_advection.o module_test_cases.o module_time_integration.o
+
+clean:
+ $(RM) *.o *.mod *.f90 libdycore.a
+
+.F.o:
+ $(RM) $@ $*.mod
+ $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90
+ $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/Registry
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/Registry (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/Registry 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,225 @@
+#
+# namelist type namelist_record name default_value
+#
+namelist integer sw_model config_test_case 5
+namelist character sw_model config_time_integration SRK3
+namelist real sw_model config_dt 172.8
+namelist integer sw_model config_ntimesteps 7500
+namelist integer sw_model config_output_interval 500
+namelist real sw_model config_h_mom_eddy_visc2 0.0
+namelist real sw_model config_h_mom_eddy_visc4 0.0
+namelist real sw_model config_v_mom_eddy_visc2 0.0
+namelist real sw_model config_h_theta_eddy_visc2 0.0
+namelist real sw_model config_h_theta_eddy_visc4 0.0
+namelist real sw_model config_v_theta_eddy_visc2 0.0
+namelist integer sw_model config_number_of_sub_steps 4
+namelist integer sw_model config_theta_adv_order 2
+namelist integer sw_model config_scalar_adv_order 2
+namelist logical sw_model config_positive_definite false
+namelist logical sw_model config_monotonic true
+namelist integer sw_model config_mp_physics 0
+namelist real sw_model config_epssm 0.1
+namelist real sw_model config_smdiv 0.1
+
+namelist character io config_input_name grid.nc
+namelist character io config_output_name output.nc
+namelist character io config_restart_name restart.nc
+namelist integer restart config_restart_interval 0
+namelist logical restart config_do_restart false
+namelist real restart config_restart_time 172800.0
+
+#
+# dim type name_in_file name_in_code
+#
+dim nCells nCells
+dim nEdges nEdges
+dim maxEdges maxEdges
+dim maxEdges2 maxEdges2
+dim nVertices nVertices
+dim TWO 2
+dim THREE 3
+dim vertexDegree vertexDegree
+dim FIFTEEN 15
+dim TWENTYONE 21
+dim R3 3
+dim nVertLevels nVertLevels
+dim nVertLevelsP1 nVertLevels+1
+
+#
+# var type name_in_file ( dims ) iro- name_in_code super-array array_class
+#
+var real xtime ( Time ) ro xtime - -
+
+# horizontal grid structure
+
+var real latCell ( nCells ) iro latCell - -
+var real lonCell ( nCells ) iro lonCell - -
+var real xCell ( nCells ) iro xCell - -
+var real yCell ( nCells ) iro yCell - -
+var real zCell ( nCells ) iro zCell - -
+var integer indexToCellID ( nCells ) iro indexToCellID - -
+
+var real latEdge ( nEdges ) iro latEdge - -
+var real lonEdge ( nEdges ) iro lonEdge - -
+var real xEdge ( nEdges ) iro xEdge - -
+var real yEdge ( nEdges ) iro yEdge - -
+var real zEdge ( nEdges ) iro zEdge - -
+var integer indexToEdgeID ( nEdges ) iro indexToEdgeID - -
+
+var real latVertex ( nVertices ) iro latVertex - -
+var real lonVertex ( nVertices ) iro lonVertex - -
+var real xVertex ( nVertices ) iro xVertex - -
+var real yVertex ( nVertices ) iro yVertex - -
+var real zVertex ( nVertices ) iro zVertex - -
+var integer indexToVertexID ( nVertices ) iro indexToVertexID - -
+
+var integer cellsOnEdge ( TWO nEdges ) iro cellsOnEdge - -
+var integer nEdgesOnCell ( nCells ) iro nEdgesOnCell - -
+var integer nEdgesOnEdge ( nEdges ) iro nEdgesOnEdge - -
+var integer edgesOnCell ( maxEdges nCells ) iro edgesOnCell - -
+var integer edgesOnEdge ( maxEdges2 nEdges ) iro edgesOnEdge - -
+
+var real weightsOnEdge ( maxEdges2 nEdges ) iro weightsOnEdge - -
+var real dvEdge ( nEdges ) iro dvEdge - -
+var real dcEdge ( nEdges ) iro dcEdge - -
+var real angleEdge ( nEdges ) iro angleEdge - -
+var real areaCell ( nCells ) iro areaCell - -
+var real areaTriangle ( nVertices ) iro areaTriangle - -
+
+var real edgeNormalVectors ( R3 nEdges ) o edgeNormalVectors - -
+var real localVerticalUnitVectors ( R3 nCells ) o localVerticalUnitVectors - -
+var real cellTangentPlane ( R3 TWO nEdges ) o cellTangentPlane - -
+
+var integer cellsOnCell ( maxEdges nCells ) iro cellsOnCell - -
+var integer verticesOnCell ( maxEdges nCells ) iro verticesOnCell - -
+var integer verticesOnEdge ( TWO nEdges ) iro verticesOnEdge - -
+var integer edgesOnVertex ( vertexDegree nVertices ) iro edgesOnVertex - -
+var integer cellsOnVertex ( vertexDegree nVertices ) iro cellsOnVertex - -
+var real kiteAreasOnVertex ( vertexDegree nVertices ) iro kiteAreasOnVertex - -
+var real fEdge ( nEdges ) iro fEdge - -
+var real fVertex ( nVertices ) iro fVertex - -
+var real h_s ( nCells ) iro h_s - -
+
+# some solver scalar coefficients
+
+# coefficients for vertical extrapolation to the surface
+var real cf1 ( ) iro cf1 - -
+var real cf2 ( ) iro cf2 - -
+var real cf3 ( ) iro cf3 - -
+
+# description of the vertical grid structure
+
+var real hx ( nVertLevelsP1 nCells ) iro hx - -
+var real zgrid ( nVertLevelsP1 nCells ) iro zgrid - -
+var real rdzw ( nVertLevels ) iro rdzw - -
+var real dzu ( nVertLevels ) iro dzu - -
+var real rdzu ( nVertLevels ) iro rdzu - -
+var real fzm ( nVertLevels ) iro fzm - -
+var real fzp ( nVertLevels ) iro fzp - -
+var real zx ( nVertLevelsP1 nEdges ) iro zx - -
+var real zz ( nVertLevelsP1 nCells ) iro zz - -
+
+# coefficients for the vertical tridiagonal solve
+# Note: these could be local but...
+
+var real cofrz ( nVertLevels ) - cofrz - -
+var real cofwr ( nVertLevels nCells ) - cofwr - -
+var real cofwz ( nVertLevels nCells ) - cofwz - -
+var real coftz ( nVertLevelsP1 nCells ) - coftz - -
+var real cofwt ( nVertLevels nCells ) - cofwt - -
+var real a_tri ( nVertLevels nCells ) - a_tri - -
+var real alpha_tri ( nVertLevels nCells ) - alpha_tri - -
+var real gamma_tri ( nVertLevels nCells ) - gamma_tri - -
+
+# W-Rayleigh-damping coefficient
+
+var real dss ( nVertLevels nCells ) ir dss - -
+
+# Prognostic variables: read from input, saved in restart, and written to output
+var real u ( nVertLevels nEdges Time ) iro u - -
+var real w ( nVertLevelsP1 nCells Time ) iro w - -
+var real rho ( nVertLevels nCells Time ) iro rho - -
+var real rho_p ( nVertLevels nCells Time ) iro rho_p - -
+var real theta ( nVertLevels nCells Time ) iro theta - -
+var real qv ( nVertLevels nCells Time ) iro qv scalars moist
+var real qc ( nVertLevels nCells Time ) iro qc scalars moist
+var real qr ( nVertLevels nCells Time ) iro qr scalars moist
+
+#var real tracers ( nTracers nVertLevels nCells Time ) iro tracers - -
+
+# state variables diagnosed from prognostic state
+# var real ww ( nVertLevelsP1 nCells Time ) ro ww - -
+var real pressure ( nVertLevels nCells Time ) ro pressure - -
+# var real pp ( nVertLevelsP1 nCells Time ) - pp - -
+
+var real u_init ( nVertLevels ) iro u_init - -
+var real t_init ( nVertLevels ) iro t_init - -
+var real qv_init ( nVertLevels ) iro qv_init - -
+
+# Diagnostic fields: only written to output
+var real v ( nVertLevels nEdges Time ) o v - -
+var real divergence ( nVertLevels nCells Time ) o divergence - -
+var real vorticity ( nVertLevels nVertices Time ) o vorticity - -
+var real pv_edge ( nVertLevels nEdges Time ) o pv_edge - -
+var real rho_edge ( nVertLevels nEdges Time ) o rho_edge - -
+var real ke ( nVertLevels nCells Time ) o ke - -
+var real pv_vertex ( nVertLevels nVertices Time ) o pv_vertex - -
+var real pv_cell ( nVertLevels nCells Time ) o pv_cell - -
+var real uReconstructX ( nVertLevels nCells Time ) o uReconstructX - -
+var real uReconstructY ( nVertLevels nCells Time ) o uReconstructY - -
+var real uReconstructZ ( nVertLevels nCells Time ) o uReconstructZ - -
+var real uReconstructZonal ( nVertLevels nCells Time ) o uReconstructZonal - -
+var real uReconstructMeridional ( nVertLevels nCells Time ) o uReconstructMeridional - -
+
+# Other diagnostic variables: neither read nor written to any files
+var real rv ( nVertLevels nEdges Time ) - rv - -
+var real circulation ( nVertLevels nVertices Time ) - circulation - -
+var real gradPVt ( nVertLevels nEdges Time ) - gradPVt - -
+var real gradPVn ( nVertLevels nEdges Time ) - gradPVn - -
+var real h_divergence ( nVertLevels nCells ) o h_divergence - -
+
+var real exner ( nVertLevels nCells ) - exner - -
+var real exner_base ( nVertLevels nCells ) or exner_base - -
+var real rtheta_base ( nVertLevels nCells ) or rtheta_base - -
+var real pressure_base ( nVertLevels nCells ) or pressure_base - -
+var real rho_base ( nVertLevels nCells ) or rho_base - -
+var real theta_base ( nVertLevels nCells ) or theta_base - -
+
+
+var real ruAvg ( nVertLevels nEdges ) - ruAvg - -
+var real wwAvg ( nVertLevelsP1 nCells ) - wwAvg - -
+var real qtot ( nVertLevels nCells ) - qtot - -
+var real cqu ( nVertLevels nEdges ) - cqu - -
+var real cqw ( nVertLevels nCells ) - cqw - -
+var real rt_diabatic_tend ( nVertLevels nCells ) - rt_diabatic_tend - -
+
+# coupled variables needed by the solver, but not output...
+
+var real ru ( nVertLevels nEdges ) - ru - -
+var real ru_p ( nVertLevels nEdges ) - ru_p - -
+var real ru_save ( nVertLevels nEdges ) - ru_save - -
+
+
+var real rw ( nVertLevelsP1 nCells ) - rw - -
+var real rw_p ( nVertLevelsP1 nCells ) - rw_p - -
+var real rw_save ( nVertLevelsP1 nCells ) - rw_save - -
+
+var real rtheta_p ( nVertLevels nCells ) - rtheta_p - -
+var real rtheta_pp ( nVertLevels nCells ) - rtheta_pp - -
+var real rtheta_p_save ( nVertLevels nCells ) - rtheta_p_save - -
+var real rtheta_pp_old ( nVertLevels nCells ) - rtheta_pp_old - -
+
+var real rho_pp ( nVertLevels nCells ) - rho_pp - -
+var real rho_p_save ( nVertLevels nCells ) - rho_p_save - -
+
+var real qv_old ( nVertLevels nCells ) - rqv scalars_old moist_old
+var real qc_old ( nVertLevels nCells ) - rqc scalars_old moist_old
+var real qr_old ( nVertLevels nCells ) - rqr scalars_old moist_old
+
+# Space needed for advection
+var real deriv_two ( FIFTEEN TWO nEdges ) o deriv_two - -
+var integer advCells ( TWENTYONE nCells ) - advCells - -
+
+# Arrays required for reconstruction of velocity field
+var real coeffs_reconstruct ( R3 maxEdges nCells ) - coeffs_reconstruct - -
+
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_advection.F
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_advection.F (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_advection.F 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,688 @@
+module advection
+
+ use grid_types
+ use configure
+ use constants
+
+
+ contains
+
+
+ subroutine initialize_advection_rk( grid )
+
+!
+! compute the cell coefficients for the polynomial fit.
+! this is performed during setup for model integration.
+! WCS, 31 August 2009
+!
+ implicit none
+
+ type (grid_meta), intent(in) :: grid
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ integer, dimension(:,:), pointer :: advCells
+
+! local variables
+
+ real (kind=RKIND), dimension(2, grid % nEdges) :: thetae
+ real (kind=RKIND), dimension(grid % nEdges) :: xe, ye
+ real (kind=RKIND), dimension(grid % nCells) :: theta_abs
+
+ real (kind=RKIND), dimension(25) :: xc, yc, zc ! cell center coordinates
+ real (kind=RKIND), dimension(25) :: thetav, thetat, dl_sphere
+ real (kind=RKIND) :: xm, ym, zm, dl, xec, yec, zec
+ real (kind=RKIND) :: thetae_tmp, xe_tmp, ye_tmp
+ real (kind=RKIND) :: xv1, xv2, yv1, yv2, zv1, zv2
+ integer :: i, j, k, ip1, ip2, m, n, ip1a, ii
+ integer :: iCell, iEdge
+ real (kind=RKIND) :: pii
+ real (kind=RKIND) :: x0, y0, x1, y1, x2, y2, x3, y3, x4, y4, x5, y5
+ real (kind=RKIND) :: pdx1, pdx2, pdx3, pdy1, pdy2, pdy3, dx1, dx2, dy1, dy2
+ real (kind=RKIND) :: angv1, angv2, dl1, dl2
+ real (kind=RKIND), dimension(25) :: dxe, dye, x2v, y2v, xp, yp
+
+ real (kind=RKIND) :: amatrix(25,25), bmatrix(25,25), wmatrix(25,25)
+ real (kind=RKIND) :: length_scale
+ integer :: ma,na, cell_add, mw, nn
+ integer, dimension(25) :: cell_list
+
+
+ integer :: cell1, cell2
+ integer, parameter :: polynomial_order = 2
+! logical, parameter :: debug = .true.
+ logical, parameter :: debug = .false.
+! logical, parameter :: least_squares = .false.
+ logical, parameter :: least_squares = .true.
+ logical :: add_the_cell, do_the_cell
+
+ logical, parameter :: reset_poly = .true.
+
+ real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
+
+!---
+
+ pii = 2.*asin(1.0)
+
+ advCells => grid % advCells % array
+ deriv_two => grid % deriv_two % array
+ deriv_two(:,:,:) = 0.
+
+ do iCell = 1, grid % nCells ! is this correct? - we need first halo cell also...
+
+ cell_list(1) = iCell
+ do i=2, grid % nEdgesOnCell % array(iCell)+1
+ cell_list(i) = grid % CellsOnCell % array(i-1,iCell)
+ end do
+ n = grid % nEdgesOnCell % array(iCell) + 1
+
+ if ( polynomial_order > 2 ) then
+ do i=2,grid % nEdgesOnCell % array(iCell) + 1
+ do j=1,grid % nEdgesOnCell % array ( cell_list(i) )
+ cell_add = grid % CellsOnCell % array (j,cell_list(i))
+ add_the_cell = .true.
+ do k=1,n
+ if ( cell_add == cell_list(k) ) add_the_cell = .false.
+ end do
+ if (add_the_cell) then
+ n = n+1
+ cell_list(n) = cell_add
+ end if
+ end do
+ end do
+ end if
+
+ advCells(1,iCell) = n
+
+! check to see if we are reaching outside the halo
+
+ do_the_cell = .true.
+ do i=1,n
+ if (cell_list(i) > grid % nCells) do_the_cell = .false.
+ end do
+
+
+ if ( .not. do_the_cell ) cycle
+
+
+! compute poynomial fit for this cell if all needed neighbors exist
+ if ( grid % on_a_sphere ) then
+
+ do i=1,n
+ advCells(i+1,iCell) = cell_list(i)
+ xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
+ yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
+ zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ end do
+
+ theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
+ xc(2), yc(2), zc(2), &
+ 0., 0., 1. )
+
+! angles from cell center to neighbor centers (thetav)
+
+ do i=1,n-1
+
+ ip2 = i+2
+ if (ip2 > n) ip2 = 2
+
+ thetav(i) = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xc(ip2), yc(ip2), zc(ip2) )
+
+ dl_sphere(i) = a*arc_length( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1) )
+ end do
+
+ length_scale = 1.
+ do i=1,n-1
+ dl_sphere(i) = dl_sphere(i)/length_scale
+ end do
+
+! thetat(1) = 0. ! this defines the x direction, cell center 1 ->
+ thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line
+ do i=2,n-1
+ thetat(i) = thetat(i-1) + thetav(i-1)
+ end do
+
+ do i=1,n-1
+ xp(i) = cos(thetat(i)) * dl_sphere(i)
+ yp(i) = sin(thetat(i)) * dl_sphere(i)
+ end do
+
+ else ! On an x-y plane
+
+ do i=1,n-1
+ xp(i) = grid % xCell % array(cell_list(i)) - grid % xCell % array(iCell)
+ yp(i) = grid % yCell % array(cell_list(i)) - grid % yCell % array(iCell)
+ end do
+
+ end if
+
+
+ ma = n-1
+ mw = grid % nEdgesOnCell % array (iCell)
+
+ bmatrix = 0.
+ amatrix = 0.
+ wmatrix = 0.
+
+ if (polynomial_order == 2) then
+ na = 6
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ wmatrix(i,i) = 1.
+ end do
+
+ else if (polynomial_order == 3) then
+ na = 10
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ else
+ na = 15
+ ma = ma+1
+
+ amatrix(1,1) = 1.
+ wmatrix(1,1) = 1.
+ do i=2,ma
+ amatrix(i,1) = 1.
+ amatrix(i,2) = xp(i-1)
+ amatrix(i,3) = yp(i-1)
+
+ amatrix(i,4) = xp(i-1)**2
+ amatrix(i,5) = xp(i-1) * yp(i-1)
+ amatrix(i,6) = yp(i-1)**2
+
+ amatrix(i,7) = xp(i-1)**3
+ amatrix(i,8) = yp(i-1) * (xp(i-1)**2)
+ amatrix(i,9) = xp(i-1) * (yp(i-1)**2)
+ amatrix(i,10) = yp(i-1)**3
+
+ amatrix(i,11) = xp(i-1)**4
+ amatrix(i,12) = yp(i-1) * (xp(i-1)**3)
+ amatrix(i,13) = (xp(i-1)**2)*(yp(i-1)**2)
+ amatrix(i,14) = xp(i-1) * (yp(i-1)**3)
+ amatrix(i,15) = yp(i-1)**4
+
+ wmatrix(i,i) = 1.
+
+ end do
+
+ do i=1,mw
+ wmatrix(i,i) = 1.
+ end do
+
+ end if
+
+ call poly_fit_2( amatrix, bmatrix, wmatrix, ma, na, 25 )
+
+ do i=1,grid % nEdgesOnCell % array (iCell)
+ ip1 = i+1
+ if (ip1 > n-1) ip1 = 1
+
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+ xv1 = grid % xVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ yv1 = grid % yVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ zv1 = grid % zVertex % array(grid % verticesOnEdge % array (1,iedge))/a
+ xv2 = grid % xVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ yv2 = grid % yVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+ zv2 = grid % zVertex % array(grid % verticesOnEdge % array (2,iedge))/a
+
+ if ( grid % on_a_sphere ) then
+ call arc_bisect( xv1, yv1, zv1, &
+ xv2, yv2, zv2, &
+ xec, yec, zec )
+
+ thetae_tmp = sphere_angle( xc(1), yc(1), zc(1), &
+ xc(i+1), yc(i+1), zc(i+1), &
+ xec, yec, zec )
+ thetae_tmp = thetae_tmp + thetat(i)
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+ thetae(1,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ else
+ thetae(2,grid % EdgesOnCell % array (i,iCell)) = thetae_tmp
+ end if
+ else
+ xe(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (xv1 + xv2)
+ ye(grid % EdgesOnCell % array (i,iCell)) = 0.5 * (yv1 + yv2)
+ end if
+
+ end do
+
+! fill second derivative stencil for rk advection
+
+ do i=1, grid % nEdgesOnCell % array (iCell)
+ iEdge = grid % EdgesOnCell % array (i,iCell)
+
+
+ if ( grid % on_a_sphere ) then
+ if (iCell == grid % cellsOnEdge % array(1,iEdge)) then
+
+ cos2t = cos(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(1,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ else
+
+ cos2t = cos(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ sin2t = sin(thetae(2,grid % EdgesOnCell % array (i,iCell)))
+ costsint = cos2t*sin2t
+ cos2t = cos2t**2
+ sin2t = sin2t**2
+
+ do j=1,n
+ deriv_two(j,2,iEdge) = 2.*cos2t*bmatrix(4,j) &
+ + 2.*costsint*bmatrix(5,j) &
+ + 2.*sin2t*bmatrix(6,j)
+ end do
+ end if
+ else
+ do j=1,n
+ deriv_two(j,1,iEdge) = 2.*xe(iEdge)*xe(iEdge)*bmatrix(4,j) &
+ + 2.*xe(iEdge)*ye(iEdge)*bmatrix(5,j) &
+ + 2.*ye(iEdge)*ye(iEdge)*bmatrix(6,j)
+ deriv_two(j,2,iEdge) = deriv_two(j,1,iEdge)
+ end do
+ end if
+ end do
+
+ end do ! end of loop over cells
+
+ if (debug) stop
+
+ end subroutine initialize_advection_rk
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION SPHERE_ANGLE
+ !
+ ! Computes the angle between arcs AB and AC, given points A, B, and C
+ ! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz
+
+ real (kind=RKIND) :: a, b, c ! Side lengths of spherical triangle ABC
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: s ! Semiperimeter of the triangle
+ real (kind=RKIND) :: sin_angle
+
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ s = 0.5*(a + b + c)
+! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+
+ if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ else
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ end if
+
+ end function sphere_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION PLANE_ANGLE
+ !
+ ! Computes the angle between vectors AB and AC, given points A, B, and C, and
+ ! a vector (u,v,w) normal to the plane.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w
+
+ real (kind=RKIND) :: ABx, ABy, ABz ! The components of the vector AB
+ real (kind=RKIND) :: mAB ! The magnitude of AB
+ real (kind=RKIND) :: ACx, ACy, ACz ! The components of the vector AC
+ real (kind=RKIND) :: mAC ! The magnitude of AC
+
+ real (kind=RKIND) :: Dx ! The i-components of the cross product AB x AC
+ real (kind=RKIND) :: Dy ! The j-components of the cross product AB x AC
+ real (kind=RKIND) :: Dz ! The k-components of the cross product AB x AC
+
+ real (kind=RKIND) :: cos_angle
+
+ ABx = bx - ax
+ ABy = by - ay
+ ABz = bz - az
+ mAB = sqrt(ABx**2.0 + ABy**2.0 + ABz**2.0)
+
+ ACx = cx - ax
+ ACy = cy - ay
+ ACz = cz - az
+ mAC = sqrt(ACx**2.0 + ACy**2.0 + ACz**2.0)
+
+
+ Dx = (ABy * ACz) - (ABz * ACy)
+ Dy = -((ABx * ACz) - (ABz * ACx))
+ Dz = (ABx * ACy) - (ABy * ACx)
+
+ cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
+
+ if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
+ plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ else
+ plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ end if
+
+ end function plane_angle
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! FUNCTION ARC_LENGTH
+ !
+ ! Returns the length of the great circle arc from A=(ax, ay, az) to
+ ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
+ ! same sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ real function arc_length(ax, ay, az, bx, by, bz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+
+ real (kind=RKIND) :: r, c
+ real (kind=RKIND) :: cx, cy, cz
+
+ cx = bx - ax
+ cy = by - ay
+ cz = bz - az
+
+! r = ax*ax + ay*ay + az*az
+! c = cx*cx + cy*cy + cz*cz
+!
+! arc_length = sqrt(r) * acos(1.0 - c/(2.0*r))
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+ c = sqrt(cx*cx + cy*cy + cz*cz)
+! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
+ arc_length = r * 2.0 * asin(c/(2.0*r))
+
+ end function arc_length
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! SUBROUTINE ARC_BISECT
+ !
+ ! Returns the point C=(cx, cy, cz) that bisects the great circle arc from
+ ! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
+ ! surface of a sphere centered at the origin.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: ax, ay, az, bx, by, bz
+ real (kind=RKIND), intent(out) :: cx, cy, cz
+
+ real (kind=RKIND) :: r ! Radius of the sphere
+ real (kind=RKIND) :: d
+
+ r = sqrt(ax*ax + ay*ay + az*az)
+
+ cx = 0.5*(ax + bx)
+ cy = 0.5*(ay + by)
+ cz = 0.5*(az + bz)
+
+ if (cx == 0. .and. cy == 0. .and. cz == 0.) then
+ write(0,*) 'Error: arc_bisect: A and B are diametrically opposite'
+ else
+ d = sqrt(cx*cx + cy*cy + cz*cz)
+ cx = r * cx / d
+ cy = r * cy / d
+ cz = r * cz / d
+ end if
+
+ end subroutine arc_bisect
+
+
+ subroutine poly_fit_2(a_in,b_out,weights_in,m,n,ne)
+
+ implicit none
+
+ integer, intent(in) :: m,n,ne
+ real (kind=RKIND), dimension(ne,ne), intent(in) :: a_in, weights_in
+ real (kind=RKIND), dimension(ne,ne), intent(out) :: b_out
+
+ ! local storage
+
+ real (kind=RKIND), dimension(m,n) :: a
+ real (kind=RKIND), dimension(n,m) :: b
+ real (kind=RKIND), dimension(m,m) :: w,wt,h
+ real (kind=RKIND), dimension(n,m) :: at, ath
+ real (kind=RKIND), dimension(n,n) :: ata, ata_inv, atha, atha_inv
+ integer, dimension(n) :: indx
+ integer :: i,j
+
+ if ( (ne<n) .or. (ne<m) ) then
+ write(6,*) ' error in poly_fit_2 inversion ',m,n,ne
+ stop
+ end if
+
+! a(1:m,1:n) = a_in(1:n,1:m)
+ a(1:m,1:n) = a_in(1:m,1:n)
+ w(1:m,1:m) = weights_in(1:m,1:m)
+ b_out(:,:) = 0.
+
+ wt = transpose(w)
+ h = matmul(wt,w)
+ at = transpose(a)
+ ath = matmul(at,h)
+ atha = matmul(ath,a)
+
+ ata = matmul(at,a)
+
+! if (m == n) then
+! call migs(a,n,b,indx)
+! else
+
+ call migs(atha,n,atha_inv,indx)
+
+ b = matmul(atha_inv,ath)
+
+! call migs(ata,n,ata_inv,indx)
+! b = matmul(ata_inv,at)
+! end if
+ b_out(1:n,1:m) = b(1:n,1:m)
+
+! do i=1,n
+! write(6,*) ' i, indx ',i,indx(i)
+! end do
+!
+! write(6,*) ' '
+
+ end subroutine poly_fit_2
+
+
+! Updated 10/24/2001.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!! Program 4.4 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !
+! Please Note: !
+! !
+! (1) This computer program is written by Tao Pang in conjunction with !
+! his book, "An Introduction to Computational Physics," published !
+! by Cambridge University Press in 1997. !
+! !
+! (2) No warranties, express or implied, are made for this program. !
+! !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+SUBROUTINE MIGS (A,N,X,INDX)
+!
+! Subroutine to invert matrix A(N,N) with the inverse stored
+! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
+ REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
+ REAL (kind=RKIND), DIMENSION (N,N) :: B
+!
+ DO I = 1, N
+ DO J = 1, N
+ B(I,J) = 0.0
+ END DO
+ END DO
+ DO I = 1, N
+ B(I,I) = 1.0
+ END DO
+!
+ CALL ELGS (A,N,INDX)
+!
+ DO I = 1, N-1
+ DO J = I+1, N
+ DO K = 1, N
+ B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
+ END DO
+ END DO
+ END DO
+!
+ DO I = 1, N
+ X(N,I) = B(INDX(N),I)/A(INDX(N),N)
+ DO J = N-1, 1, -1
+ X(J,I) = B(INDX(J),I)
+ DO K = J+1, N
+ X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
+ END DO
+ X(J,I) = X(J,I)/A(INDX(J),J)
+ END DO
+ END DO
+END SUBROUTINE MIGS
+
+
+SUBROUTINE ELGS (A,N,INDX)
+!
+! Subroutine to perform the partial-pivoting Gaussian elimination.
+! A(N,N) is the original matrix in the input and transformed matrix
+! plus the pivoting element ratios below the diagonal in the output.
+! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
+!
+ IMPLICIT NONE
+ INTEGER, INTENT (IN) :: N
+ INTEGER :: I,J,K,ITMP
+ INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
+ REAL (kind=RKIND) :: C1,PI,PI1,PJ
+ REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
+ REAL (kind=RKIND), DIMENSION (N) :: C
+!
+! Initialize the index
+!
+ DO I = 1, N
+ INDX(I) = I
+ END DO
+!
+! Find the rescaling factors, one from each row
+!
+ DO I = 1, N
+ C1= 0.0
+ DO J = 1, N
+ C1 = AMAX1(C1,ABS(A(I,J)))
+ END DO
+ C(I) = C1
+ END DO
+!
+! Search the pivoting (largest) element from each column
+!
+ DO J = 1, N-1
+ PI1 = 0.0
+ DO I = J, N
+ PI = ABS(A(INDX(I),J))/C(INDX(I))
+ IF (PI.GT.PI1) THEN
+ PI1 = PI
+ K = I
+ ENDIF
+ END DO
+!
+! Interchange the rows via INDX(N) to record pivoting order
+!
+ ITMP = INDX(J)
+ INDX(J) = INDX(K)
+ INDX(K) = ITMP
+ DO I = J+1, N
+ PJ = A(INDX(I),J)/A(INDX(J),J)
+!
+! Record pivoting ratios below the diagonal
+!
+ A(INDX(I),J) = PJ
+!
+! Modify other elements accordingly
+!
+ DO K = J+1, N
+ A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
+ END DO
+ END DO
+ END DO
+!
+END SUBROUTINE ELGS
+
+end module advection
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,1200 @@
+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
+
+ ! 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
+ real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal
+ real (kind=RKIND), dimension(nlat, grid % nVertLevels) :: u_2d, etavs_2d
+ real (kind=RKIND), dimension(nlat) :: lat_2d
+ real (kind=RKIND) :: dlat
+
+ !
+ ! 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
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = 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 '
+
+!************** section for 2d (lat,z) 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
+
+ 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)) &
+ + 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))
+ end do
+
+ do k=1,nz1
+ ztemp = .5*(zgrid_1d(k+1)+zgrid_1d(k))
+ 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))
+ 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
+
+
+ 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)
+ phi = lat_2d (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)
+
+
+ ztemp = .5*(zgrid_1d(k)+zgrid_1d(k+1))
+ ptemp = ppb(k,i) + pp(k,i)
+ qv(k,i) = 0.
+
+ 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)
+ 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
+ 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))
+ 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
+
+!******************************************************************
+
+!
+!---- 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
+
+ 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
+!! 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_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
+
+! 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
+
+ !
+ ! 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 calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat)
+
+ implicit none
+ integer, intent(in) :: nz1,nlat
+ real (kind=RKIND), dimension(nlat,nz1), 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
+
+ integer :: k,i
+ real (kind=RKIND) :: lat1, lat2, w1, w2
+ real (kind=RKIND) :: dlat,da,db
+
+ lat1 = abs(lat1_in)
+ lat2 = abs(lat2_in)
+ if(lat2 <= lat1) then
+ lat1 = abs(lat2_in)
+ lat2 = abs(lat1_in)
+ end if
+
+ do k=1,nz1
+ flux_zonal(k) = 0.
+ end do
+
+ do i=1,nlat-1
+ if( (lat1 <= lat_2d(i+1)) .and. (lat2 >= lat_2d(i)) ) then
+
+ dlat = lat_2d(i+1)-lat_2d(i)
+ da = (max(lat1,lat_2d(i))-lat_2d(i))/dlat
+ db = (min(lat2,lat_2d(i+1))-lat_2d(i))/dlat
+ w1 = (db-da) -0.5*(db-da)**2
+ 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)
+ end do
+
+ end if
+
+ end do
+
+! renormalize for setting cell-face fluxes
+
+ do k=1,nz1
+ flux_zonal(k) = sign(1.,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
+ end do
+
+ end subroutine calc_flux_zonal
+
+
+!----------------------------------------------------------------------------------------------------------
+
+ 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, cof1, cof2
+ 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?
+
+ 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))
+
+ grid % cf1 % scalar = cf1
+ grid % cf2 % scalar = cf2
+ grid % cf3 % scalar = cf3
+
+ 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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.0521
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.0521 (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.0521 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,964 @@
+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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.100705
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.100705 (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.100705 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,1007 @@
+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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.ok
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.ok (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.ok 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,966 @@
+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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.sh0614
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.sh0614 (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_test_cases.F.sh0614 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,998 @@
+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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,2908 @@
+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 = .false.
+ logical, parameter :: scalar_advection = .false.
+
+ 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...
+
+
+ if(scalar_advection) then
+
+ 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
+
+ else
+
+ write(0,*) ' no scalar advection '
+
+ end if
+
+ 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(0,*) ' 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(0,*) ' 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(0,*) ' 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
+ epssm = config_epssm
+
+ 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, h_divergence
+ 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
+ h_divergence => grid % h_divergence % 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 = grid % cf1 % scalar
+ cf2 = grid % cf2 % scalar
+ cf3 = grid % cf3 % scalar
+
+ epssm = config_epssm
+ smdiv = config_smdiv
+
+ 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)
+! + (0.005/6.)*dcEdge(iEdge)*(h_divergence(k,cell2)-h_divergence(k,cell1))
+
+ 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 = grid % cf1 % scalar
+ cf2 = grid % cf2 % scalar
+ cf3 = grid % cf3 % scalar
+
+ ! 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, &
+ h_divergence
+ 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.
+ integer :: w_adv_order
+
+ real (kind=RKIND) :: coef_3rd_order
+
+ 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
+ h_divergence => grid % h_divergence % 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 = grid % cf1 % scalar
+ cf2 = grid % cf2 % scalar
+ cf3 = grid % cf3 % scalar
+
+ ! 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
+ h_divergence(:,:) = 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
+ h_divergence(k,iCell) = divergence_ru(k,iCell)
+ 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="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc2 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = 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="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
+ end do
+ end 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(k) = 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
+ !
+
+ w_adv_order = 2
+
+ if (w_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 (w_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 (w_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
+
+ coef_3rd_order = 0.25
+
+ 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 + d2fdx2_cell2) / 12. &
+ -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+ else
+ flux = dvEdge(iEdge) * ru(k,iEdge) * ( &
+ 0.5*(theta(k,cell1) + theta(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
+! 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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.0531
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.0531 (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.0531 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,2861 @@
+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="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc2 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = 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="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
+ end do
+ end 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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.sh0609
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.sh0609 (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/module_time_integration.F.sh0609 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,2876 @@
+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="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc2 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ u_diffusion = 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="blue">abla vorticity
+ ! only valid for h_mom_eddy_visc4 == constant
+ !
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+
+ delsq_u(k,iEdge) = delsq_u(k,iEdge) + u_diffusion
+ end do
+ end 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* &
+!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
Added: branches/atmos_nonhydrostatic/src/core_nhyd_atmos/mpas_interface.F
===================================================================
--- branches/atmos_nonhydrostatic/src/core_nhyd_atmos/mpas_interface.F (rev 0)
+++ branches/atmos_nonhydrostatic/src/core_nhyd_atmos/mpas_interface.F 2010-07-12 19:38:09 UTC (rev 372)
@@ -0,0 +1,70 @@
+subroutine mpas_setup_test_case(domain)
+
+ use grid_types
+ use test_cases
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+
+ call setup_nhyd_test_case(domain)
+
+end subroutine mpas_setup_test_case
+
+
+subroutine mpas_init(block, mesh, dt)
+
+ use grid_types
+ use advection
+ use time_integration
+
+ implicit none
+
+ type (block_type), intent(inout) :: block
+ type (grid_meta), intent(inout) :: mesh
+ real (kind=RKIND), intent(in) :: dt
+
+! call compute_solver_constants(block % time_levs(1) % state, mesh)
+! call compute_state_diagnostics(block % time_levs(1) % state, mesh)
+ call init_coupled_diagnostics( block % time_levs(1) % state, mesh)
+ call compute_solve_diagnostics(dt, block % time_levs(1) % state, mesh) ! ok for nonhydrostatic model
+ call initialize_advection_rk(mesh)
+
+end subroutine mpas_init
+
+
+subroutine mpas_query(key, ivalue)
+
+ implicit none
+
+ character (len=256), intent(in) :: key
+ integer, intent(out) :: ivalue
+
+ if (index(key,'STORAGE_FACTOR') /= 0) then
+ ivalue = 1
+ end if
+
+end subroutine mpas_query
+
+
+subroutine mpas_timestep(domain, itimestep, dt)
+
+ use grid_types
+ use time_integration
+
+ implicit none
+
+ type (domain_type), intent(inout) :: domain
+ integer, intent(in) :: itimestep
+ real (kind=RKIND), intent(in) :: dt
+
+ call timestep(domain, dt)
+
+end subroutine mpas_timestep
+
+
+subroutine mpas_finalize()
+
+ implicit none
+
+end subroutine mpas_finalize
</font>
</pre>