<p><b>duda</b> 2012-02-10 14:00:58 -0700 (Fri, 10 Feb 2012)</p><p>Update trunk with changes from atmos_physics branch.<br>
<br>
<br>
A + graphics/ncl/atm_contours.ncl<br>
A + graphics/ncl/atm_mesh.ncl<br>
A + graphics/ncl/atm_cells.ncl<br>
A + graphics/ncl/atm_xsec.ncl<br>
M namelist.input.init_nhyd_atmos<br>
M src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F<br>
M src/core_init_nhyd_atmos/Registry<br>
M src/core_atmos_physics/mpas_atmphys_control.F<br>
M src/core_atmos_physics/physics_wrf/module_cam_support.F<br>
A + src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F<br>
M src/core_atmos_physics/physics_wrf/Makefile<br>
M src/core_atmos_physics/Makefile<br>
M src/core_atmos_physics/mpas_atmphys_vars.F<br>
M src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F<br>
M src/core_atmos_physics/mpas_atmphys_driver.F<br>
M src/core_atmos_physics/mpas_atmphys_initialize_real.F<br>
M src/core_nhyd_atmos/mpas_atm_test_cases.F<br>
M src/core_nhyd_atmos/mpas_atm_time_integration.F<br>
M src/core_nhyd_atmos/Registry<br>
M src/core_nhyd_atmos/mpas_atm_mpas_core.F<br>
</p><hr noshade><pre><font color="gray">Copied: trunk/mpas/graphics/ncl/atm_cells.ncl (from rev 1496, branches/atmos_physics/graphics/ncl/atm_cells.ncl)
===================================================================
--- trunk/mpas/graphics/ncl/atm_cells.ncl (rev 0)
+++ trunk/mpas/graphics/ncl/atm_cells.ncl 2012-02-10 21:00:58 UTC (rev 1498)
@@ -0,0 +1,145 @@
+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
+
+ maxedges = 8
+
+ wks = gsn_open_wks("pdf","atm_cells")
+ gsn_define_colormap(wks,"BlAqGrYeOrReVi200")
+
+ fname = getenv("FNAME")
+ f = addfile(fname,"r")
+
+ nEdgesOnCell = f->nEdgesOnCell(:)
+ verticesOnCell = f->verticesOnCell(:,:)
+ verticesOnEdge = f->verticesOnEdge(:,:)
+ x = f->lonCell(:) * r2d
+ y = f->latCell(:) * r2d
+ lonCell = f->lonCell(:) * r2d
+ latCell = f->latCell(:) * r2d
+ lonVertex = f->lonVertex(:) * r2d
+ latVertex = f->latVertex(:) * r2d
+
+ res = True
+ res@gsnPaperOrientation = "portrait"
+
+ res@sfXArray = x
+ res@sfYArray = y
+
+ res@cnFillOn = True
+ res@cnFillMode = "RasterFill"
+ res@cnLinesOn = False
+ res@cnLineLabelsOn = False
+ res@cnInfoLabelOn = False
+
+ res@lbLabelAutoStride = True
+ res@lbBoxLinesOn = False
+
+ res@mpProjection = "CylindricalEquidistant"
+; res@mpProjection = "Orthographic"
+ res@mpDataBaseVersion = "MediumRes"
+ res@mpCenterLatF = 0.
+ res@mpCenterLonF = 0.
+ res@mpGridAndLimbOn = False
+ res@mpOutlineOn = False
+ res@mpFillOn = False
+ res@mpPerimOn = False
+ res@gsnFrame = False
+
+ ;
+ ; The purpose of this section is simply to set up a graphic ('map')
+ ; that uses the projection specified above, and over which we
+ ; can draw polygons
+ ;
+ h = f->areaCell(:)
+ sizes = dimsizes(h)
+ nCells = sizes(0)
+ xpoly = new((/maxedges/), "double")
+ ypoly = new((/maxedges/), "double")
+ res@cnConstFLabelOn = False
+ res@lbLabelBarOn = False
+ map = gsn_csm_contour_map(wks,h,res)
+
+ t = stringtointeger(getenv("T"))
+
+ ;
+ ; Set the field to be plotted here
+ ;
+ pres = True
+ h = f->qv(t,:,0)
+ minfld = min(h)
+ maxfld = max(h)
+ fldrange = maxfld - minfld
+ do iCell=0,nCells-1
+ do i=0,nEdgesOnCell(iCell)-1
+ xpoly(i) = lonVertex(verticesOnCell(iCell,i)-1)
+ ypoly(i) = latVertex(verticesOnCell(iCell,i)-1)
+ if (i .gt. 0) then
+ if (abs(xpoly(i) - xpoly(0)) .gt. 180.0) then
+ if (xpoly(i) .gt. xpoly(0)) then
+ xpoly(i) = xpoly(i) - 360.0
+ else
+ xpoly(i) = xpoly(i) + 360.0
+ end if
+ end if
+ end if
+ end do
+ pres@gsFillColor = doubletointeger(198*(h(iCell) - minfld)/fldrange+2)
+ gsn_polygon(wks,map,xpoly(0:nEdgesOnCell(iCell)-1),ypoly(0:nEdgesOnCell(iCell)-1),pres);
+ end do
+
+
+ ;
+ ; Draw label bar
+ ;
+
+ xcb = new((/4/), "float")
+ ycb = new((/4/), "float")
+
+ tres = True
+ tres@txAngleF = 90.0
+ tres@txFontHeightF = 0.015
+ do i=2,200
+ xcb(0) = 0.125 + i*0.75/198
+ ycb(0) = 0.11
+
+ xcb(1) = 0.125 + (i+1)*0.75/198
+ ycb(1) = 0.11
+
+ xcb(2) = 0.125 + (i+1)*0.75/198
+ ycb(2) = 0.16
+
+ xcb(3) = 0.125 + i*0.75/198
+ ycb(3) = 0.16
+
+ tres@gsFillColor = i
+
+ gsn_polygon_ndc(wks,xcb,ycb,tres);
+
+ j = (i-2) % 20
+ if ((j .eq. 0) .or. (i .eq. 200)) then
+ ff = minfld + int2flt(i-2) * fldrange / 198.0
+ label = sprintf("%5.3g", ff)
+ gsn_text_ndc(wks, label, xcb(0), 0.060, tres)
+ end if
+
+ end do
+
+ mres = True
+ mres@mpCenterLatF = 0.
+ mres@mpCenterLonF = 0.
+ mres@mpGridAndLimbOn = False
+ mres@mpOutlineOn = True
+ mres@mpFillOn = False
+ mres@mpPerimOn = False
+ mres@gsnFrame = False
+ mapo = gsn_csm_map(wks,mres)
+
+ frame(wks)
+
+end
+
Copied: trunk/mpas/graphics/ncl/atm_contours.ncl (from rev 1496, branches/atmos_physics/graphics/ncl/atm_contours.ncl)
===================================================================
--- trunk/mpas/graphics/ncl/atm_contours.ncl (rev 0)
+++ trunk/mpas/graphics/ncl/atm_contours.ncl 2012-02-10 21:00:58 UTC (rev 1498)
@@ -0,0 +1,152 @@
+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 = 0.0
+ cenLon = 0.0
+
+ ;
+ ; Projection to use for plot
+ ;
+; projection = "Orthographic"
+ projection = "CylindricalEquidistant"
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ r2d = 57.2957795 ; radians to degrees
+
+ maxedges = 7
+
+ wks = gsn_open_wks("pdf","atm_contours")
+ gsn_define_colormap(wks,"gui_default")
+
+ fname = getenv("FNAME")
+ f = addfile(fname,"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@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@mpProjection = projection
+ res@mpDataBaseVersion = "MediumRes"
+ res@mpCenterLatF = cenLat
+ res@mpCenterLonF = cenLon
+ res@mpGridAndLimbOn = True
+ res@mpGridAndLimbDrawOrder = "PreDraw"
+ res@mpGridLineColor = "Background"
+ res@mpOutlineOn = True
+ res@mpDataBaseVersion = "Ncarg4_1"
+ res@mpDataSetName = "Earth..3"
+ res@mpOutlineBoundarySets = "Geophysical"
+ res@mpFillOn = False
+ res@mpPerimOn = True
+ res@gsnFrame = False
+ res@cnLineThicknessF = 2.0
+ res@cnLineColor = "NavyBlue"
+
+ t = stringtointeger(getenv("T"))
+ if (plotfield .eq. "h") then
+; fld = f->xice(t,:)
+; fld = f->sst(t,:)
+; fld = f->surface_pressure(t,:)
+; fld = f->pressure_base(t,:,25) + f->pressure_p(t,:,25)
+ fld = f->theta(t,:,25)
+ end if
+ if (plotfield .eq. "ke") then
+ fld = f->ke(t,:,0)
+ end if
+ if (plotfield .eq. "vorticity") then
+ fld = f->vorticity(t,:,0)
+ end if
+ res@cnLineDashPattern = 0
+ map = gsn_csm_contour_map(wks,fld,res)
+
+ if (winds) then
+ u = f->u(t,:,0)
+ v = f->v(t,:,0)
+ 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
+
Copied: trunk/mpas/graphics/ncl/atm_mesh.ncl (from rev 1496, branches/atmos_physics/graphics/ncl/atm_mesh.ncl)
===================================================================
--- trunk/mpas/graphics/ncl/atm_mesh.ncl (rev 0)
+++ trunk/mpas/graphics/ncl/atm_mesh.ncl 2012-02-10 21:00:58 UTC (rev 1498)
@@ -0,0 +1,80 @@
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl"
+load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl"
+
+begin
+
+ r2d = 57.2957795 ; radians to degrees
+
+ wks = gsn_open_wks("pdf","atm_mesh")
+
+ colors = (/"white","black","lightskyblue1","lightskyblue1","bisque"/)
+; colors = (/"white","black","white","white","grey90"/)
+ gsn_define_colormap(wks,colors)
+
+ fname = getenv("FNAME")
+ f = addfile(fname,"r")
+
+ xVertex = f->xVertex(:)
+ yVertex = f->yVertex(:)
+ zVertex = f->zVertex(:)
+ verticesOnCell = f->verticesOnCell(:,:)
+ verticesOnEdge = f->verticesOnEdge(:,:)
+ x = f->lonCell(:) * r2d
+ y = f->latCell(:) * r2d
+ lonCell = f->lonCell(:) * r2d
+ latCell = f->latCell(:) * r2d
+ lonVertex = f->lonVertex(:) * r2d
+ latVertex = f->latVertex(:) * r2d
+ lonEdge = f->lonEdge(:) * r2d
+ latEdge = f->latEdge(:) * r2d
+
+ res = True
+ res@gsnMaximize = True
+
+ res@mpProjection = "Orthographic"
+ res@mpDataBaseVersion = "MediumRes"
+ res@mpCenterLatF = 50.
+ res@mpCenterLonF = -100.
+ res@mpCenterRotF = -100.
+ res@mpGridAndLimbOn = False
+ res@mpOutlineOn = True
+ res@mpFillOn = True
+ res@mpPerimOn = False
+ res@gsnFrame = False
+ res@mpOceanFillColor = 3
+ res@mpInlandWaterFillColor = 3
+ res@mpLandFillColor = 4
+
+ map = gsn_csm_map(wks,res)
+
+ lres = True
+ lres@gsLineThicknessF = 0.10
+
+ esizes = dimsizes(latEdge)
+ ecx = new((/esizes(0),2/),double)
+ ecy = new((/esizes(0),2/),double)
+ do j=0,esizes(0)-1
+ ecy(j,0) = latVertex(verticesOnEdge(j,0)-1)
+ ecx(j,0) = lonVertex(verticesOnEdge(j,0)-1)
+ ecy(j,1) = latVertex(verticesOnEdge(j,1)-1)
+ ecx(j,1) = lonVertex(verticesOnEdge(j,1)-1)
+ end do
+
+ do j=0,esizes(0)-1
+ if (abs(ecx(j,0) - ecx(j,1)) .gt. 180.0) then
+ if (ecx(j,0) .gt. ecx(j,1)) then
+ ecx(j,0) = ecx(j,0) - 360.0
+ else
+ ecx(j,1) = ecx(j,1) - 360.0
+ end if
+ end if
+ end do
+
+ do j=0,esizes(0)-1
+ gsn_polyline(wks,map,ecx(j,:),ecy(j,:),lres)
+ end do
+
+ frame(wks)
+
+end
+
Copied: trunk/mpas/graphics/ncl/atm_xsec.ncl (from rev 1496, branches/atmos_physics/graphics/ncl/atm_xsec.ncl)
===================================================================
--- trunk/mpas/graphics/ncl/atm_xsec.ncl (rev 0)
+++ trunk/mpas/graphics/ncl/atm_xsec.ncl 2012-02-10 21:00:58 UTC (rev 1498)
@@ -0,0 +1,373 @@
+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
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;
+ ; Which field to plot
+ ;
+; plotfield = "w"
+ plotfield = "theta"
+; plotfield = "ke"
+; plotfield = "vorticity"
+
+
+ ;
+ ; 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
+
+ ;
+ ; Starting and ending locations (in degrees)
+ ; Exercise caution when setting these: setting start_lon=90.0 and end_lon=-90.0
+ ; would create a cross-section including the prime meridian, whereas setting
+ ; start_lon=90.0 and end_lon=270.0 would create a cross-section containing
+ ; the date line, for example.
+ ;
+ ;
+ start_lat = 40.0
+ start_lon = -140.0
+ end_lat = 40.0
+ end_lon = -80.0
+
+ ;
+ ; The number of points along the cross section
+ ;
+ nsec = 250
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+ wks = gsn_open_wks("pdf","atm_xsec")
+ gsn_define_colormap(wks,"BlAqGrYeOrReVi200")
+
+ fname = getenv("FNAME")
+ f = addfile(fname,"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(:)
+ zgrid = f->zgrid(:,:) / 1000.0
+ verticesOnCell = f->verticesOnCell(:,:)
+ edgesOnCell = f->edgesOnCell(:,:)
+ nCellsOnCell = f->nEdgesOnCell(:)
+ cellsOnCell = f->cellsOnCell(:,:)
+ alpha = f->angleEdge(:)
+
+ dims = dimsizes(latCell)
+ nCells = dims(0)
+
+ start_lat = start_lat / r2d
+ start_lon = start_lon / r2d
+ end_lat = end_lat / r2d
+ end_lon = end_lon / r2d
+
+ radius = 6371220.0
+ xsec_latitude = start_lat
+ xsec_longitude = start_lon
+ xsec_lat_inc = (end_lat - start_lat) / (int2flt(nsec) - 1.0)
+ xsec_lon_inc = (end_lon - start_lon) / (int2flt(nsec) - 1.0)
+
+ xsecx = new((/nsec/),float)
+ xsecy = new((/nsec/),float)
+ xsecz = new((/nsec/),float)
+ xsec_cell_id = new((/nsec/),integer)
+ xsec_edge_id = new((/nsec/),integer)
+ xsec_vtx_id = new((/nsec/),integer)
+ xsec_id = new((/nsec/),integer)
+
+ ; Compute (x,y,z) coordinates for points on cross section
+ do i=0,nsec-1
+ xsecx(i) = radius * cos(xsec_longitude) * cos(xsec_latitude)
+ xsecy(i) = radius * sin(xsec_longitude) * cos(xsec_latitude)
+ xsecz(i) = radius * sin(xsec_latitude)
+ xsec_latitude = xsec_latitude + xsec_lat_inc
+ xsec_longitude = xsec_longitude + xsec_lon_inc
+ end do
+
+ ; Find cell containing first cross section point
+ dmin = 2.0 * radius
+ cellmin = -1
+ do i=0,nCells-1
+ d = sqrt((xCell(i) - xsecx(0))^2.0 + (yCell(i) - xsecy(0))^2.0 + (zCell(i) - xsecz(0))^2.0)
+ if (d .lt. dmin) then
+ cellmin = i
+ dmin = doubletofloat(d)
+ end if
+ end do
+ xsec_cell_id(0) = cellmin
+
+ ; For the remaining cross section points, find the grid cell containing them
+ do j=1,nsec-1
+ moved = 1
+ do while (moved .ne. 0)
+ moved = 0
+ d = sqrt((xCell(cellmin) - xsecx(j))^2.0 + (yCell(cellmin) - xsecy(j))^2.0 + (zCell(cellmin) - xsecz(j))^2.0)
+ do k=0,nCellsOnCell(cellmin)-1
+ dn = sqrt((xCell(cellsOnCell(cellmin,k)-1) - xsecx(j))^2.0 + (yCell(cellsOnCell(cellmin,k)-1) - xsecy(j))^2.0 + (zCell(cellsOnCell(cellmin,k)-1) - xsecz(j))^2.0)
+ if (dn .lt. d) then
+ d = dn
+ nearest = (/cellsOnCell(cellmin,k)/)-1
+ moved = 1
+ end if
+ end do
+ if (moved .eq. 1) then
+ cellmin = nearest
+ end if
+ end do
+ xsec_cell_id(j) = cellmin
+ end do
+
+ ; For all cross section points, find the nearest vertex and edge
+ do i=0,nsec-1
+ iVtx = verticesOnCell(xsec_cell_id(i),0) - 1
+ iEdge = edgesOnCell(xsec_cell_id(i),0) - 1
+ xsec_edge_id(i) = iEdge
+ xsec_vtx_id(i) = iVtx
+ de = sqrt((xEdge(iEdge) - xsecx(i))^2.0 + (yEdge(iEdge) - xsecy(i))^2.0 + (zEdge(iEdge) - xsecz(i))^2.0)
+ dv = sqrt((xVertex(iVtx) - xsecx(i))^2.0 + (yVertex(iVtx) - xsecy(i))^2.0 + (zVertex(iVtx) - xsecz(i))^2.0)
+ do j=1,nCellsOnCell(xsec_cell_id(i))-1
+ iVtx = verticesOnCell(xsec_cell_id(i),j) - 1
+ iEdge = edgesOnCell(xsec_cell_id(i),j) - 1
+ de_test = sqrt((xEdge(iEdge) - xsecx(i))^2.0 + (yEdge(iEdge) - xsecy(i))^2.0 + (zEdge(iEdge) - xsecz(i))^2.0)
+ dv_test = sqrt((xVertex(iVtx) - xsecx(i))^2.0 + (yVertex(iVtx) - xsecy(i))^2.0 + (zVertex(iVtx) - xsecz(i))^2.0)
+ if (de_test .lt. de) then
+ de = de_test
+ xsec_edge_id(i) = iEdge
+ end if
+ if (dv_test .lt. dv) then
+ dv = dv_test
+ xsec_vtx_id(i) = iVtx
+ end if
+ end do
+ end do
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ; At this point, xsec_cell_id(:), xsec_edge_id(:), and xsec_vtx_id(:) contains the cell, edge,
+ ; and vertex IDs of the nearest points to those along the cross section
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ res = True
+ res@gsnMaximize = False
+ 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 = 0.01
+ res@cnInfoLabelOn = True
+
+ res@lbLabelAutoStride = True
+ res@lbBoxLinesOn = False
+
+ res@gsnFrame = False
+
+
+ ;
+ ; Select field to be plotted, and set generic array xsec_id(:) to contain IDs of
+ ; locations (cell, edge, or vertex) in that field containg cross section points
+ ;
+
+ t = stringtointeger(getenv("T"))
+ if (plotfield .eq. "w") then
+ fld1 = f->w(t,:,:)
+ ldims = dimsizes(fld1)
+ fld = new((/ldims(0),ldims(1)-1/),"double")
+ ; Average w to center of layers
+ do i=0,ldims(0)-1
+ do j=0,ldims(1)-2
+ fld(i,j) = 0.5*(fld1(i,j)+fld1(i,j+1))
+ end do
+ end do
+ nVertLevels = ldims(1)
+ nVertLevels = nVertLevels-1
+ xsec_id(:) = xsec_cell_id(:)
+ end if
+ if (plotfield .eq. "theta") then
+ fld = f->theta(t,:,:)
+ ldims = dimsizes(fld)
+ nVertLevels = ldims(1)
+ xsec_id(:) = xsec_cell_id(:)
+ end if
+ if (plotfield .eq. "ke") then
+ fld = f->ke(t,:,:)
+ ldims = dimsizes(fld)
+ nVertLevels = ldims(1)
+ xsec_id(:) = xsec_cell_id(:)
+ end if
+ if (plotfield .eq. "vorticity") then
+ fld = f->vorticity(t,:,:)
+ ldims = dimsizes(fld)
+ nVertLevels = ldims(1)
+ xsec_id(:) = xsec_vtx_id(:)
+ end if
+ res@cnLineDashPattern = 0
+
+ height1 = new((/nVertLevels+1,nsec/),float)
+ height = new((/nVertLevels+1,nsec+1/),float)
+ x = new((/nVertLevels+1,nsec+1/),float)
+
+ ; 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) = 0.5*doubletofloat(fld(xsec_id(i),j)+fld(xsec_id(i),j+1))
+ arr(j,i) = doubletofloat(fld(xsec_id(i),j))
+ height1(j,i) = doubletofloat(zgrid(xsec_id(i),j))
+ end do
+ j = nVertLevels
+ height1(j,i) = doubletofloat(zgrid(xsec_id(i),j))
+ end do
+
+ do j=0,nVertLevels
+ x(j,nsec) = int2flt(nsec) + 0.5
+ x(j,0) = 0.5
+ height(j,0) = height1(j,0)
+ height(j,nsec) = height1(j,nsec-1)
+ end do
+
+ do i=1,nsec-1
+ do j=0,nVertLevels
+ height(j,i) = 0.5*(height1(j,i) + height1(j,i-1))
+ x(j,i) = int2flt(i) + 0.5
+ end do
+ end do
+
+ xpoly = new((/5/), "float")
+ ypoly = new((/5/), "float")
+
+ minfld = min(arr)
+ maxfld = max(arr)
+ fldrange = maxfld - minfld
+
+ res@trYMinF = min(zgrid)
+ res@trYMaxF = max(zgrid)
+ res@trXMinF = int2flt(0)
+ res@trXMaxF = int2flt(nsec+1)
+
+ res@tiYAxisString = "z(km)"
+ res@tiYAxisFontHeightF = 0.017
+ res@tiXAxisString = "cell"
+ res@tiXAxisFontHeightF = 0.017
+
+ map = gsn_csm_xy(wks,x,height,res)
+
+ do i=0,nsec-1
+ do j=0,nVertLevels-1
+ xpoly(0) = x(j,i)
+ xpoly(1) = x(j,i+1)
+ xpoly(2) = x(j+1,i+1)
+ xpoly(3) = x(j+1,i)
+ xpoly(4) = x(j,i)
+
+ ypoly(0) = height(j,i)
+ ypoly(1) = height(j,i+1)
+ ypoly(2) = height(j+1,i+1)
+ ypoly(3) = height(j+1,i)
+ ypoly(4) = height(j,i)
+
+ res@gsFillColor = doubletointeger(195*(arr(j,i) - minfld)/fldrange+2)
+ gsn_polygon(wks,map,xpoly,ypoly,res);
+ end do
+ end do
+
+ if (horiz_winds) then
+ u = f->u(t,:,:)
+ v = f->v(t,:,:)
+ esizes = dimsizes(u)
+ nVertLevels = esizes(1)
+ 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",50.0)
+ wmsetp("VCW",0.10)
+
+ wmvect(wks, x_edge, y_edge, u_earth, v_earth)
+ end if
+
+ ;
+ ; Draw label bar
+ ;
+
+ xcb = new((/4/), "float")
+ ycb = new((/4/), "float")
+
+ tres = True
+ tres@txAngleF = 90.0
+ tres@txFontHeightF = 0.013
+ do i=2,200
+ xcb(0) = 0.125 + i*0.75/198
+ ycb(0) = 0.08
+
+ xcb(1) = 0.125 + (i+1)*0.75/198
+ ycb(1) = 0.08
+
+ xcb(2) = 0.125 + (i+1)*0.75/198
+ ycb(2) = 0.10
+
+ xcb(3) = 0.125 + i*0.75/198
+ ycb(3) = 0.10
+
+ tres@gsFillColor = i
+
+ gsn_polygon_ndc(wks,xcb,ycb,tres);
+
+ j = (i-2) % 20
+ if ((j .eq. 0) .or. (i .eq. 200)) then
+ ff = minfld + int2flt(i-2) * fldrange / 198.0
+ label = sprintf("%8.3g", ff)
+ gsn_text_ndc(wks, label, xcb(0), 0.050, tres)
+ end if
+
+ end do
+
+ frame(wks)
+
+end
+
Modified: trunk/mpas/namelist.input.init_nhyd_atmos
===================================================================
--- trunk/mpas/namelist.input.init_nhyd_atmos 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/namelist.input.init_nhyd_atmos 2012-02-10 21:00:58 UTC (rev 1498)
@@ -15,7 +15,7 @@
&data_sources
config_geog_data_path = '/mmm/users/wrfhelp/WPS_GEOG/'
config_met_prefix = 'CFSR'
- config_sst_prefix = 'SST'
+ config_sfc_prefix = 'SST'
config_fg_interval = 21600
/
@@ -29,7 +29,6 @@
config_static_interp = .false.
config_vertical_grid = .true.
config_met_interp = .true.
- config_physics_init = .true.
config_input_sst = .false.
/
Modified: trunk/mpas/src/core_atmos_physics/Makefile
===================================================================
--- trunk/mpas/src/core_atmos_physics/Makefile 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/Makefile 2012-02-10 21:00:58 UTC (rev 1498)
@@ -63,13 +63,15 @@
# DEPENDENCIES:
mpas_atmphys_driver_cloudines.o: \
- mpas_atmphys_driver_cloudiness.o \
+ mpas_atmphys_driver_cloudiness.o \
mpas_atmphys_vars.o
mpas_atmphys_driver_convection_deep.o: \
mpas_atmphys_constants.o \
+ mpas_atmphys_utilities.o \
mpas_atmphys_vars.o \
- ./physics_wrf/module_cu_kfeta.o
+ ./physics_wrf/module_cu_kfeta.o \
+ ./physics_wrf/module_cu_tiedtke.o
mpas_atmphys_driver_lsm.o: \
mpas_atmphys_constants.o \
@@ -84,22 +86,22 @@
./physics_wrf/module_bl_ysu.o
mpas_atmphys_driver_radiation_lw.o: \
- mpas_atmphys_driver_radiation_sw.o \
+ mpas_atmphys_driver_radiation_sw.o \
mpas_atmphys_camrad_init.o \
mpas_atmphys_constants.o \
mpas_atmphys_manager.o \
mpas_atmphys_rrtmg_lwinit.o \
mpas_atmphys_vars.o \
- ./physics_wrf/module_ra_cam.o \
+ ./physics_wrf/module_ra_cam.o \
./physics_wrf/module_ra_rrtmg_lw.o
mpas_atmphys_driver_radiation_sw.o: \
- mpas_atmphys_camrad_init.o \
+ mpas_atmphys_camrad_init.o \
mpas_atmphys_constants.o \
mpas_atmphys_manager.o \
mpas_atmphys_rrtmg_swinit.o \
mpas_atmphys_vars.o \
- ./physics_wrf/module_ra_cam.o \
+ ./physics_wrf/module_ra_cam.o \
./physics_wrf/module_ra_rrtmg_sw.o
mpas_atmphys_driver_sfclayer.o: \
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_control.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_control.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_control.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -68,8 +68,9 @@
endif
!deep convection scheme:
- if(.not. (config_conv_deep_scheme .eq. 'off' .or. &
- config_conv_deep_scheme .eq. 'kain_fritsch')) then
+ if(.not. (config_conv_deep_scheme .eq. 'off' .or. &
+ config_conv_deep_scheme .eq. 'kain_fritsch' .or. &
+ config_conv_deep_scheme .eq. 'tiedtke' )) then
write(mpas_err_message,'(A,A10)') 'illegal value for config_deep_conv_scheme: ', &
trim(config_conv_deep_scheme)
@@ -77,6 +78,13 @@
endif
+!ldf (2012-01-19): Tiedtke is still under testing. do not use right now.
+ if(config_conv_deep_scheme .eq. 'tiedtke') then
+ write(mpas_err_message,'(A,A10)') 'Tiedtke is being tested. Do not use right now. Thanks '
+ call physics_error_fatal(mpas_err_message)
+ endif
+!ldf end.
+
!pbl scheme:
if(.not. (config_pbl_scheme .eq. 'off' .or. &
config_pbl_scheme .eq. 'ysu')) then
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -115,7 +115,8 @@
!call to convection scheme:
if(config_conv_deep_scheme .ne. 'off') then
call allocate_convection_deep
- call driver_convection_deep(itimestep,block%mesh,block%diag_physics,block%tend_physics)
+ call driver_convection_deep(itimestep,block%mesh,block%sfc_input,block%diag_physics, &
+ block%tend_physics)
call deallocate_convection_deep
endif
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -3,10 +3,12 @@
use mpas_grid_types
use mpas_atmphys_constants
+ use mpas_atmphys_utilities
use mpas_atmphys_vars
!wrf physics:
use module_cu_kfeta
+ use module_cu_tiedtke
implicit none
private
@@ -28,21 +30,31 @@
if(.not.allocated(rthcuten_p) ) allocate(rthcuten_p(ims:ime,kms:kme,jms:jme))
if(.not.allocated(rqvcuten_p) ) allocate(rqvcuten_p(ims:ime,kms:kme,jms:jme))
if(.not.allocated(rqccuten_p) ) allocate(rqccuten_p(ims:ime,kms:kme,jms:jme))
- if(.not.allocated(rqrcuten_p) ) allocate(rqrcuten_p(ims:ime,kms:kme,jms:jme))
if(.not.allocated(rqicuten_p) ) allocate(rqicuten_p(ims:ime,kms:kme,jms:jme))
- if(.not.allocated(rqscuten_p) ) allocate(rqscuten_p(ims:ime,kms:kme,jms:jme))
- if(.not.allocated(cubot_p) ) allocate(cubot_p(ims:ime,jms:jme) )
- if(.not.allocated(cutop_p) ) allocate(cutop_p(ims:ime,jms:jme) )
if(.not.allocated(pratec_p) ) allocate(pratec_p(ims:ime,jms:jme) )
if(.not.allocated(raincv_p) ) allocate(raincv_p(ims:ime,jms:jme) )
convection_select: select case(conv_deep_scheme)
case ("kain_fritsch")
- if(.not.allocated(area_p) ) allocate(area_p(ims:ime,jms:jme) )
- if(.not.allocated(nca_p) ) allocate(nca_p(ims:ime,jms:jme) )
- if(.not.allocated(w0avg_p)) allocate(w0avg_p(ims:ime,kms:kme,jms:jme))
+ if(.not.allocated(area_p) ) allocate(area_p(ims:ime,jms:jme) )
+ if(.not.allocated(nca_p) ) allocate(nca_p(ims:ime,jms:jme) )
+ if(.not.allocated(w0avg_p) ) allocate(w0avg_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(cubot_p) ) allocate(cubot_p(ims:ime,jms:jme) )
+ if(.not.allocated(cutop_p) ) allocate(cutop_p(ims:ime,jms:jme) )
+ if(.not.allocated(rqrcuten_p) ) allocate(rqrcuten_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(rqscuten_p) ) allocate(rqscuten_p(ims:ime,kms:kme,jms:jme) )
+
+ case ("tiedtke")
+ if(.not.allocated(znu_p) ) allocate(znu_p(kms:kme) )
+ if(.not.allocated(qfx_p) ) allocate(qfx_p(ims:ime,jms:jme) )
+ if(.not.allocated(xland_p) ) allocate(xland_p(ims:ime,jms:jme) )
+ if(.not.allocated(rqvdynten_p) ) allocate(rqvdynten_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(rqvdynblten_p)) allocate(rqvdynblten_p(ims:ime,kms:kme,jms:jme))
+ if(.not.allocated(rucuten_p) ) allocate(rucuten_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(rvcuten_p) ) allocate(rvcuten_p(ims:ime,kms:kme,jms:jme) )
+
case default
end select convection_select
@@ -57,21 +69,31 @@
if(allocated(rthcuten_p) ) deallocate(rthcuten_p )
if(allocated(rqvcuten_p) ) deallocate(rqvcuten_p )
if(allocated(rqccuten_p) ) deallocate(rqccuten_p )
- if(allocated(rqrcuten_p) ) deallocate(rqrcuten_p )
if(allocated(rqicuten_p) ) deallocate(rqicuten_p )
- if(allocated(rqscuten_p) ) deallocate(rqscuten_p )
- if(allocated(cubot_p) ) deallocate(cubot_p )
- if(allocated(cutop_p) ) deallocate(cutop_p )
if(allocated(pratec_p) ) deallocate(pratec_p )
if(allocated(raincv_p) ) deallocate(raincv_p )
convection_select: select case(conv_deep_scheme)
case ("kain_fritsch")
- if(allocated(area_p) ) deallocate(area_p )
- if(allocated(nca_p) ) deallocate(nca_p )
- if(allocated(w0avg_p)) deallocate(w0avg_p)
+ if(allocated(area_p) ) deallocate(area_p )
+ if(allocated(nca_p) ) deallocate(nca_p )
+ if(allocated(w0avg_p) ) deallocate(w0avg_p )
+ if(allocated(cubot_p) ) deallocate(cubot_p )
+ if(allocated(cutop_p) ) deallocate(cutop_p )
+ if(allocated(rqrcuten_p) ) deallocate(rqrcuten_p )
+ if(allocated(rqscuten_p) ) deallocate(rqscuten_p )
+
+ case ("tiedtke")
+ if(allocated(znu_p) ) deallocate(znu_p )
+ if(allocated(qfx_p) ) deallocate(qfx_p )
+ if(allocated(xland_p) ) deallocate(xland_p )
+ if(allocated(rqvdynten_p) ) deallocate(rqvdynten_p )
+ if(allocated(rqvdynblten_p)) deallocate(rqvdynblten_p)
+ if(allocated(rucuten_p) ) deallocate(rucuten_p )
+ if(allocated(rvcuten_p) ) deallocate(rvcuten_p )
+
case default
end select convection_select
@@ -108,6 +130,12 @@
call kf_lutab(svp1,svp2,svp3,svpt0)
write(0,*) ' end kain-kritsch initialization'
+ case ("tiedtke")
+ write(0,*) ' enter tiedtke initialization:'
+ write(mpas_err_message,'(A,A10)') &
+ 'Tiedtke is being tested. Do not use right now. Thanks '
+ call physics_error_fatal(mpas_err_message)
+
case default
end select convection_select
@@ -117,13 +145,14 @@
end subroutine init_convection_deep
!=============================================================================================
- subroutine driver_convection_deep(itimestep,mesh,diag_physics,tend_physics)
+ subroutine driver_convection_deep(itimestep,mesh,sfc_input,diag_physics,tend_physics)
!=============================================================================================
!input and output arguments:
!---------------------------
integer,intent(in):: itimestep
type(mesh_type),intent(in):: mesh
+ type(sfc_input_type),intent(in):: sfc_input
type(diag_physics_type),intent(inout):: diag_physics
type(tend_physics_type),intent(inout):: tend_physics
@@ -137,7 +166,8 @@
logical:: warm_rain,adapt_step_flag
real(kind=RKIND):: curr_secs
real(kind=RKIND):: cudt
-
+ real(kind=RKIND):: cudtacttime
+
!=============================================================================================
write(0,*)
write(0,*) '--- enter convection_driver: dt_cu=',dt_cu
@@ -145,14 +175,15 @@
!initialize instantaneous precipitation, and copy convective tendencies from the dynamics to
!the physics grid:
- call convection_from_MPAS(dt_dyn,mesh,diag_physics,tend_physics)
+ call convection_from_MPAS(dt_dyn,mesh,sfc_input,diag_physics,tend_physics)
!... convert the convection time-step to minutes:
cudt = dt_cu/60.
!... call to convection schemes:
-!dx = sqrt(maxval(mesh % areaCell % array))
-
+ curr_secs = -1
+ cudtacttime = -1
+ adapt_step_flag = .false.
do j = jts, jte
do i = its, ite
cu_act_flag(i,j) = .false.
@@ -162,14 +193,9 @@
convection_select: select case(conv_deep_scheme)
case ("kain_fritsch")
-
- !initialization:
- curr_secs = -1
- adapt_step_flag = .false.
write(0,*) '--- enter subroutine kf_eta_cps:'
call kf_eta_cps ( &
dt = dt_dyn , ktau = itimestep , &
-! dx = dx , cudt = dt_cu , &
areaCell = area_p , cudt = dt_cu , &
curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
rho = rho_p , raincv = raincv_p , &
@@ -198,28 +224,14 @@
ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
- 201 format(i3,i6,1x,l1,5(1x,e15.8))
- write(0,*) '--- end subroutine kf_eta_cps:'
-! write(0,*)
-! write(0,*) '--- deep convection:'
-! do j = jts,jte
-! do i = its,ite
-! if(nca_p(i,j).gt.0. .and. raincv_p(i,j).gt.0.) then
-! write(0,201) j,i,cu_act_flag(i,j),nca_p(i,j),raincv_p(i,j), &
-! raincv_p(i,j)/dt_dyn,pratec_p(i,j)
-! endif
-! enddo
-! enddo
-! write(0,*) '--- shallow convection:'
-! do j = jts,jte
-! do i = its,ite
-! if(nca_p(i,j).gt.0. .and. raincv_p(i,j).eq.0.) then
-! write(0,201) j,i,cu_act_flag(i,j),nca_p(i,j),raincv_p(i,j), &
-! raincv_p(i,j)/dt_dyn,pratec_p(i,j)
-! endif
-! enddo
-! enddo
+ write(0,*) '--- end subroutine kf_eta_cps'
+ case("tiedtke")
+ write(0,*) '--- enter subroutine cu_tiedtke:'
+ write(mpas_err_message,'(A,A10)') &
+ 'Tiedtke is being tested. Do not use right now. Thanks '
+ call physics_error_fatal(mpas_err_message)
+
case default
end select convection_select
@@ -234,42 +246,51 @@
end subroutine driver_convection_deep
!=============================================================================================
- subroutine convection_from_MPAS(dt_dyn,mesh,diag_physics,tend_physics)
+ subroutine convection_from_MPAS(dt_dyn,mesh,sfc_input,diag_physics,tend_physics)
!=============================================================================================
!input arguments:
type(mesh_type),intent(in):: mesh
+ type(sfc_input_type),intent(in) :: sfc_input
type(diag_physics_type),intent(in):: diag_physics
type(tend_physics_type),intent(in):: tend_physics
real(kind=RKIND),intent(in):: dt_dyn
+!local variables:
+ real(kind=RKIND):: tem
+ real(kind=RKIND),dimension(:),allocatable:: zw
+
!---------------------------------------------------------------------------------------------
+ write(0,*)
+ write(0,*) '--- enter subroutine convection_from_MPAS:'
do j = jts,jte
do i = its,ite
- cubot_p(i,j) = diag_physics % cubot % array(i)
- cutop_p(i,j) = diag_physics % cutop % array(i)
raincv_p(i,j) = diag_physics % raincv % array(i)
pratec_p(i,j) = diag_physics % cuprec % array(i)
- do k = kts, kte
+ do k = kts,kte
rthcuten_p(i,k,j) = tend_physics % rthcuten % array(k,i)
rqvcuten_p(i,k,j) = tend_physics % rqvcuten % array(k,i)
rqccuten_p(i,k,j) = tend_physics % rqccuten % array(k,i)
- rqrcuten_p(i,k,j) = tend_physics % rqrcuten % array(k,i)
rqicuten_p(i,k,j) = tend_physics % rqicuten % array(k,i)
- rqscuten_p(i,k,j) = tend_physics % rqscuten % array(k,i)
enddo
enddo
enddo
-
+
convection_select: select case(conv_deep_scheme)
case ("kain_fritsch")
-
+
do j = jts,jte
do i = its,ite
- !area of grid-cell:
- area_p(i,j) = mesh % areaCell % array(i)
+ area_p(i,j) = mesh % areaCell % array(i)
+ cubot_p(i,j) = diag_physics % cubot % array(i)
+ cutop_p(i,j) = diag_physics % cutop % array(i)
+ do k = kts,kte
+ rqrcuten_p(i,k,j) = tend_physics % rqrcuten % array(k,i)
+ rqscuten_p(i,k,j) = tend_physics % rqscuten % array(k,i)
+ enddo
+
!decreases the characteristic time period that convection remains active. When nca_p
!becomes less than the convective timestep, convective tendencies and precipitation
!are reset to zero (note that this is also done in subroutine kf_eta_cps).
@@ -294,18 +315,49 @@
endif
endif
- do k = kts, kte
+ do k = kts,kte
w0avg_p(i,k,j) = diag_physics % w0avg % array(k,i)
enddo
enddo
enddo
+ case ("tiedtke")
+ if(.not.allocated(zw)) allocate(zw(kms:kme))
+ zw(kts) = 0.
+ do k = kts,kte
+ tem = 1./mesh % rdzw % array(k)
+ zw(k+1) = zw(k) + tem
+ znu_p(k) = 0.5*(zw(k+1)+zw(k))
+ write(0,*) k,zw(k+1),znu_p(k)
+ enddo
+ if(allocated(zw)) deallocate(zw)
+
+ do j = jts,jte
+ do i = its,ite
+ xland_p(i,j) = sfc_input % xland % array(i)
+ qfx_p(i,j) = diag_physics % qfx % array(i)
+ enddo
+
+ do k = kts,kte
+ do i = its,ite
+ rqvdynblten_p(i,k,j) = tend_physics % rqvblten % array(k,i)
+ rqvdynten_p(i,k,j) = tend_physics % rqvdynten % array(k,i)
+ rucuten_p(i,k,j) = tend_physics % rucuten % array(k,i)
+ rvcuten_p(i,k,j) = tend_physics % rvcuten % array(k,i)
+ enddo
+ enddo
+ enddo
+ write(0,*) '--- max rqvdynblten = ',maxval(rqvdynblten_p(:,:,:))
+ write(0,*) '--- min rqvdynblten = ',minval(rqvdynblten_p(:,:,:))
+ write(0,*) '--- max rqvdynten = ',maxval(rqvdynten_p(:,:,:))
+ write(0,*) '--- min rqvdynten = ',minval(rqvdynten_p(:,:,:))
+
case default
end select convection_select
end subroutine convection_from_MPAS
-
+
!=============================================================================================
subroutine convection_to_MPAS(diag_physics,tend_physics)
!=============================================================================================
@@ -319,15 +371,11 @@
do i = its,ite
diag_physics % raincv % array(i) = raincv_p(i,j)
diag_physics % cuprec % array(i) = pratec_p(i,j)
- diag_physics % cubot % array(i) = cubot_p(i,j)
- diag_physics % cutop % array(i) = cutop_p(i,j)
do k = kts, kte
tend_physics % rthcuten % array(k,i) = rthcuten_p(i,k,j)
tend_physics % rqvcuten % array(k,i) = rqvcuten_p(i,k,j)
tend_physics % rqccuten % array(k,i) = rqccuten_p(i,k,j)
- tend_physics % rqrcuten % array(k,i) = rqrcuten_p(i,k,j)
tend_physics % rqicuten % array(k,i) = rqicuten_p(i,k,j)
- tend_physics % rqscuten % array(k,i) = rqscuten_p(i,k,j)
enddo
enddo
enddo
@@ -337,13 +385,27 @@
case ("kain_fritsch")
do j = jts,jte
do i = its,ite
+ diag_physics % cubot % array(i) = cubot_p(i,j)
+ diag_physics % cutop % array(i) = cutop_p(i,j)
diag_physics % nca % array(i) = nca_p(i,j)
do k = kts, kte
diag_physics % w0avg % array(k,i) = w0avg_p(i,k,j)
+ tend_physics % rqrcuten % array(k,i) = rqrcuten_p(i,k,j)
+ tend_physics % rqscuten % array(k,i) = rqscuten_p(i,k,j)
enddo
enddo
enddo
+ case ("tiedtke")
+ do j = jts,jte
+ do k = kts,kte
+ do i = its,ite
+ tend_physics % rucuten % array(k,i) = rucuten_p(i,k,j)
+ tend_physics % rvcuten % array(k,i) = rvcuten_p(i,k,j)
+ enddo
+ enddo
+ enddo
+
case default
end select convection_select
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_initialize_real.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -6,7 +6,7 @@
config_input_sst, &
config_nsoillevels, &
config_start_time, &
- config_sst_prefix
+ config_sfc_prefix
use mpas_grid_types
use init_atm_hinterp
use init_atm_llxy
@@ -52,10 +52,10 @@
interp_list(3) = 0
!open intermediate file:
- call read_met_init(trim(config_sst_prefix),.false.,config_start_time(1:13),istatus)
+ call read_met_init(trim(config_sfc_prefix),.false.,config_start_time(1:13),istatus)
if(istatus /= 0) &
- write(0,*) 'Error reading ',trim(config_sst_prefix)//':'//config_start_time(1:13)
- write(0,*) 'Processing ',trim(config_sst_prefix)//':'//config_start_time(1:13)
+ write(0,*) 'Error reading ',trim(config_sfc_prefix)//':'//config_start_time(1:13)
+ write(0,*) 'Processing ',trim(config_sfc_prefix)//':'//config_start_time(1:13)
!scan through all the fields in the file:
call read_next_met_field(field,istatus)
@@ -89,6 +89,22 @@
knownj = 1.0_RKIND, &
lat1 = real(field % startlat,RKIND), &
lon1 = real(field % startlon,RKIND))
+ else if (field % iproj == PROJ_GAUSS) then
+ call map_set(PROJ_GAUSS, proj, &
+ nlat = nint(field % deltalat), &
+ loninc = real(field % deltalon,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
+! nxmax = nint(360.0 / field % deltalon), &
+ else if (field % iproj == PROJ_PS) then
+ call map_set(PROJ_PS, proj, &
+ dx = real(field % dx,RKIND), &
+ truelat1 = real(field % truelat1,RKIND), &
+ stdlon = real(field % xlonc,RKIND), &
+ knowni = real(field % nx / 2.0,RKIND), &
+ knownj = real(field % ny / 2.0,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
end if
!Interpolate field to each MPAS grid cell:
Modified: trunk/mpas/src/core_atmos_physics/mpas_atmphys_vars.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/mpas_atmphys_vars.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/mpas_atmphys_vars.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -43,6 +43,9 @@
real(kind=RKIND),public:: xice_threshold
+ real(kind=RKIND),dimension(:),allocatable:: &
+ znu_p
+
real(kind=RKIND),dimension(:,:),allocatable:: &
area_p !grid cell area [m2]
@@ -138,23 +141,37 @@
logical,dimension(:,:),allocatable:: &
cu_act_flag
real(kind=RKIND),dimension(:,:),allocatable:: &
- cubot_p, &!lowest convective level [-]
- cutop_p, &!highest convective level [-]
- nca_p, &!counter for cloud relaxation time [-]
rainc_p, &!
raincv_p, &!
pratec_p !
- real(kind=RKIND),dimension(:,:,:),allocatable:: &
- w0avg_p !
real(kind=RKIND),dimension(:,:,:),allocatable:: &
rthcuten_p, &!
rqvcuten_p, &!
rqccuten_p, &!
+ rqicuten_p !
+
+!... kain fritsch specific arrays:
+ real(kind=RKIND),dimension(:,:),allocatable:: &
+ cubot_p, &!lowest convective level [-]
+ cutop_p, &!highest convective level [-]
+ nca_p !counter for cloud relaxation time [-]
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ w0avg_p !
+
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
rqrcuten_p, &!
- rqicuten_p, &!
- rqscuten_p
+ rqscuten_p !
+!... tiedtke specific arrays:
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ rqvdynten_p, &!
+ rqvdynblten_p !
+
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ rucuten_p, &!
+ rvcuten_p !
+
!=============================================================================================
!... variables and arrays related to parameterization of pbl:
!=============================================================================================
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/Makefile
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/Makefile 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/Makefile 2012-02-10 21:00:58 UTC (rev 1498)
@@ -6,28 +6,35 @@
echo "****** compile physics_wrf ******"
OBJS = \
- libmassv.o \
- module_bl_ysu.o \
- module_cu_kfeta.o \
- module_mp_kessler.o \
- module_mp_thompson.o \
- module_mp_wsm6.o \
- module_ra_cam.o \
- module_ra_cam_support.o \
- module_ra_rrtmg_lw.o \
- module_ra_rrtmg_sw.o \
- module_sf_bem.o \
- module_sf_bep.o \
- module_sf_bep_bem.o \
- module_sf_noahdrv.o \
- module_sf_noahlsm.o \
- module_sf_sfclay.o \
+ libmassv.o \
+ module_bl_ysu.o \
+ module_cam_shr_kind_mod.o \
+ module_cam_support.o \
+ module_cu_kfeta.o \
+ module_cu_tiedtke.o \
+ module_mp_kessler.o \
+ module_mp_thompson.o \
+ module_mp_wsm6.o \
+ module_ra_cam.o \
+ module_ra_cam_support.o \
+ module_ra_rrtmg_lw.o \
+ module_ra_rrtmg_sw.o \
+ module_sf_bem.o \
+ module_sf_bep.o \
+ module_sf_bep_bem.o \
+ module_sf_noahdrv.o \
+ module_sf_noahlsm.o \
+ module_sf_sfclay.o \
module_sf_urban.o
physics_wrf: $(OBJS)
ar -ru ./../libphys.a $(OBJS)
# DEPENDENCIES:
+module_cam_support.o: \
+ module_cam_shr_kind_mod.o \
+ ../mpas_atmphys_utilities.o
+
module_mp_thompson.o: \
../mpas_atmphys_utilities.o
@@ -35,6 +42,7 @@
libmassv.o
module_ra_cam.o: \
+ module_cam_support.o \
module_ra_cam_support.o \
../mpas_atmphys_utilities.o
@@ -48,11 +56,11 @@
module_sf_urban.o
module_sf_bep_bem.o: \
- module_sf_bem.o \
+ module_sf_bem.o \
module_sf_urban.o
module_sf_noahdrv.o: \
- module_sf_bem.o \
+ module_sf_bem.o \
module_sf_bep.o \
module_sf_bep_bem.o \
module_sf_noahlsm.o \
Modified: trunk/mpas/src/core_atmos_physics/physics_wrf/module_cam_support.F
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_cam_support.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_cam_support.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -7,7 +7,7 @@
! Author: William.Gustafson@pnl.gov, Nov 2009
!------------------------------------------------------------------------
#if (defined(non_hydrostatic_core) || defined(hydrostatic_core))
- use module_physics_utilities
+ use mpas_atmphys_utilities
#else
use module_state_description, only: param_num_moist
#endif
Copied: trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F (from rev 1496, branches/atmos_physics/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F)
===================================================================
--- trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F (rev 0)
+++ trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -0,0 +1,3114 @@
+!-----------------------------------------------------------------------
+!
+!WRF:MODEL_LAYER:PHYSICS
+!
+!####################TIEDTKE SCHEME#########################
+! Taken from the IPRC iRAM - Yuqing Wang, University of Hawaii
+! Added by Chunxi Zhang and Yuqing Wang to WRF3.2, May, 2010
+! refenrence: Tiedtke (1989, MWR, 117, 1779-1800)
+! Nordeng, T.E., (1995), CAPE closure and organized entrainment/detrainment
+! Yuqing Wang et al. (2003,J. Climate, 16, 1721-1738) for improvements
+! for cloud top detrainment
+! (2004, Mon. Wea. Rev., 132, 274-296), improvements for PBL clouds
+! (2007,Mon. Wea. Rev., 135, 567-585), diurnal cycle of precipitation
+! This scheme is on testing
+!###########################################################
+MODULE module_cu_tiedtke
+!
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+! epsl--- allowed minimum value for floating calculation
+!---------------------------------------------------------------
+ real,parameter :: epsl = 1.0e-20
+ real,parameter :: t000 = 273.15
+ real,parameter :: hgfr = 233.15 ! defined in param.f in explct
+!-------------------------------------------------------------
+! Ends the parameters set
+!++++++++++++++++++++++++++++
+ REAL,PRIVATE :: G,CPV
+ REAL :: API,A,EOMEGA,RD,RV,CPD,RCPD,VTMPC1,VTMPC2, &
+ RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, &
+ C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG
+
+ REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC, &
+ CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0, &
+ fdbk,ZTAU
+
+ INTEGER :: nentr
+
+ REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC
+
+
+ PARAMETER(A=6371.22E03, &
+ ALV=2.5008E6, &
+ ALS=2.8345E6, &
+ ALF=ALS-ALV, &
+ CPD=1005.46, &
+ CPV=1869.46, & ! CPV in module is 1846.4
+ RCPD=1.0/CPD, &
+ RHOH2O=1.0E03, &
+ TMELT=273.16, &
+ G=9.806, & ! G=9.806
+ ZRG=1.0/G, &
+ RD=287.05, &
+ RV=461.51, &
+ C1ES=610.78, &
+ C2ES=C1ES*RD/RV, &
+ C3LES=17.269, &
+ C4LES=35.86, &
+ C5LES=C3LES*(TMELT-C4LES), &
+ C3IES=21.875, &
+ C4IES=7.66, &
+ C5IES=C3IES*(TMELT-C4IES), &
+ API=3.141593, & ! API=2.0*ASIN(1.)
+ VTMPC1=RV/RD-1.0, &
+ VTMPC2=CPV/CPD-1.0, &
+ CVDIFTS=1.0, &
+ CEVAPCU1=1.93E-6*261., &
+ CEVAPCU2=1.E3/(38.3*0.293) )
+
+
+! SPECIFY PARAMETERS FOR MASSFLUX-SCHEME
+! --------------------------------------
+! These are tunable parameters
+!
+! ENTRPEN: AVERAGE ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+! -------
+!
+ PARAMETER(ENTRPEN=1.0E-4)
+!
+! ENTRSCV: AVERAGE ENTRAINMENT RATE FOR SHALLOW CONVECTION
+! -------
+!
+ PARAMETER(ENTRSCV=1.2E-3)
+!
+! ENTRMID: AVERAGE ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+! -------
+!
+ PARAMETER(ENTRMID=1.0E-4)
+!
+! ENTRDD: AVERAGE ENTRAINMENT RATE FOR DOWNDRAFTS
+! ------
+!
+ PARAMETER(ENTRDD =2.0E-4)
+!
+! CMFCTOP: RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL
+! -------
+!
+ PARAMETER(CMFCTOP=0.26)
+!
+! CMFCMAX: MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC
+! -------
+!
+ PARAMETER(CMFCMAX=1.0)
+!
+! CMFCMIN: MINIMUM MASSFLUX VALUE (FOR SAFETY)
+! -------
+!
+ PARAMETER(CMFCMIN=1.E-10)
+!
+! CMFDEPS: FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+! -------
+!
+ PARAMETER(CMFDEPS=0.30)
+!
+! CPRCON: COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER
+!
+ PARAMETER(CPRCON = 2.0E-3/G)
+!
+! ZDNOPRC: The pressure depth below which no precipitation
+!
+ PARAMETER(ZDNOPRC = 1.5E4)
+!--------------------
+ PARAMETER(nentr=1) ! Old entrainment rate parameterization ! chn1,2,4
+! PARAMETER(nentr=2) ! New entrainment rate parameterization ! chn3
+!
+!--------------------
+ PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50)
+!--------------------
+ PARAMETER(CRIRH=0.80,fdbk = 1.0,ZTAU = 3600.0)
+!--------------------
+ LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV
+ PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.)
+!--------------------
+!#################### END of Variables definition##########################
+!-----------------------------------------------------------------------
+!
+CONTAINS
+!-----------------------------------------------------------------------
+ SUBROUTINE CU_TIEDTKE( &
+ DT,ITIMESTEP,STEPCU &
+ ,RAINCV,PRATEC,QFX,ZNU &
+ ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D &
+ ,QVFTEN,QVPBLTEN &
+ ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG &
+ ,CUDT, CURR_SECS, ADAPT_STEP_FLAG &
+ ,CUDTACTTIME &
+ ,ids,ide, jds,jde, kds,kde &
+ ,ims,ime, jms,jme, kms,kme &
+ ,its,ite, jts,jte, kts,kte &
+ ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN &
+ ,RUCUTEN, RVCUTEN &
+ ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS &
+ )
+
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+!-- U3D 3D u-velocity interpolated to theta points (m/s)
+!-- V3D 3D v-velocity interpolated to theta points (m/s)
+!-- TH3D 3D potential temperature (K)
+!-- T3D temperature (K)
+!-- QV3D 3D water vapor mixing ratio (Kg/Kg)
+!-- QC3D 3D cloud mixing ratio (Kg/Kg)
+!-- QI3D 3D ice mixing ratio (Kg/Kg)
+!-- RHO3D 3D air density (kg/m^3)
+!-- P8w 3D hydrostatic pressure at full levels (Pa)
+!-- Pcps 3D hydrostatic pressure at half levels (Pa)
+!-- PI3D 3D exner function (dimensionless)
+!-- RTHCUTEN Theta tendency due to
+! cumulus scheme precipitation (K/s)
+!-- RUCUTEN U wind tendency due to
+! cumulus scheme precipitation (K/s)
+!-- RVCUTEN V wind tendency due to
+! cumulus scheme precipitation (K/s)
+!-- RQVCUTEN Qv tendency due to
+! cumulus scheme precipitation (kg/kg/s)
+!-- RQRCUTEN Qr tendency due to
+! cumulus scheme precipitation (kg/kg/s)
+!-- RQCCUTEN Qc tendency due to
+! cumulus scheme precipitation (kg/kg/s)
+!-- RQSCUTEN Qs tendency due to
+! cumulus scheme precipitation (kg/kg/s)
+!-- RQICUTEN Qi tendency due to
+! cumulus scheme precipitation (kg/kg/s)
+!-- RAINC accumulated total cumulus scheme precipitation (mm)
+!-- RAINCV cumulus scheme precipitation (mm)
+!-- PRATEC precipitiation rate from cumulus scheme (mm/s)
+!-- dz8w dz between full levels (m)
+!-- QFX upward moisture flux at the surface (kg/m^2/s)
+!-- DT time step (s)
+!-- ids start index for i in domain
+!-- ide end index for i in domain
+!-- jds start index for j in domain
+!-- jde end index for j in domain
+!-- kds start index for k in domain
+!-- kde end index for k in domain
+!-- ims start index for i in memory
+!-- ime end index for i in memory
+!-- jms start index for j in memory
+!-- jme end index for j in memory
+!-- kms start index for k in memory
+!-- kme end index for k in memory
+!-- its start index for i in tile
+!-- ite end index for i in tile
+!-- jts start index for j in tile
+!-- jte end index for j in tile
+!-- kts start index for k in tile
+!-- kte end index for k in tile
+!-------------------------------------------------------------------
+ INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
+ ims,ime, jms,jme, kms,kme, &
+ its,ite, jts,jte, kts,kte, &
+ ITIMESTEP, &
+ STEPCU
+
+ REAL, INTENT(IN) :: &
+ DT
+
+
+ REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: &
+ XLAND
+
+ REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: &
+ RAINCV, PRATEC
+
+ LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: &
+ CU_ACT_FLAG
+
+
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: &
+ DZ8W, &
+ P8w, &
+ Pcps, &
+ PI3D, &
+ QC3D, &
+ QVFTEN, &
+ QVPBLTEN, &
+ QI3D, &
+ QV3D, &
+ RHO3D, &
+ T3D, &
+ U3D, &
+ V3D, &
+ W
+
+!--------------------------- OPTIONAL VARS ----------------------------
+
+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), &
+ OPTIONAL, INTENT(INOUT) :: &
+ RQCCUTEN, &
+ RQICUTEN, &
+ RQVCUTEN, &
+ RTHCUTEN, &
+ RUCUTEN, &
+ RVCUTEN
+
+!
+! Flags relating to the optional tendency arrays declared above
+! Models that carry the optional tendencies will provdide the
+! optional arguments at compile time; these flags all the model
+! to determine at run-time whether a particular tracer is in
+! use or not.
+!
+ LOGICAL, OPTIONAL :: &
+ F_QV &
+ ,F_QC &
+ ,F_QR &
+ ,F_QI &
+ ,F_QS
+
+! Adaptive time-step variables
+ REAL, INTENT(IN ) :: CUDT
+ REAL, INTENT(IN ) :: CURR_SECS
+ LOGICAL,INTENT(IN ) , OPTIONAL :: ADAPT_STEP_FLAG
+ REAL, INTENT (INOUT) :: CUDTACTTIME
+
+!--------------------------- LOCAL VARS ------------------------------
+
+ REAL, DIMENSION(ims:ime, jms:jme) :: &
+ QFX
+
+ REAL :: &
+ DELT, &
+ RDELT
+
+ REAL , DIMENSION(its:ite) :: &
+ RCS, &
+ RN, &
+ EVAP
+ INTEGER , DIMENSION(its:ite) :: SLIMSK
+
+
+ REAL , DIMENSION(its:ite, kts:kte+1) :: &
+ PRSI
+
+ REAL , DIMENSION(its:ite, kts:kte) :: &
+ DEL, &
+ DOT, &
+ PHIL, &
+ PRSL, &
+ Q1, &
+ Q2, &
+ Q3, &
+ Q1B, &
+ Q1BL, &
+ Q11, &
+ Q12, &
+ T1, &
+ U1, &
+ V1, &
+ ZI, &
+ ZL, &
+ OMG, &
+ GHT
+
+ INTEGER, DIMENSION(its:ite) :: &
+ KBOT, &
+ KTOP
+
+ INTEGER :: &
+ I, &
+ IM, &
+ J, &
+ K, &
+ KM, &
+ KP, &
+ KX
+
+
+ LOGICAL :: run_param , doing_adapt_dt , decided
+
+!-------other local variables----
+ INTEGER,DIMENSION( its:ite ) :: KTYPE
+ REAL, DIMENSION( kts:kte ) :: sig1 ! half sigma levels
+ REAL, DIMENSION( kms:kme ) :: ZNU
+ INTEGER :: zz
+!-----------------------------------------------------------------------
+!
+!*** CHECK TO SEE IF THIS IS A CONVECTION TIMESTEP
+!
+
+! Initialization for adaptive time step.
+
+ doing_adapt_dt = .FALSE.
+ IF ( PRESENT(adapt_step_flag) ) THEN
+ IF ( adapt_step_flag ) THEN
+ doing_adapt_dt = .TRUE.
+ IF ( cudtacttime .EQ. 0. ) THEN
+ cudtacttime = curr_secs + cudt*60.
+ END IF
+ END IF
+ END IF
+
+! Do we run through this scheme or not?
+
+! Test 1: If this is the initial model time, then yes.
+! ITIMESTEP=1
+! Test 2: If the user asked for the cumulus to be run every time step, then yes.
+! CUDT=0 or STEPCU=1
+! Test 3: If not adaptive dt, and this is on the requested cumulus frequency, then yes.
+! MOD(ITIMESTEP,STEPCU)=0
+! Test 4: If using adaptive dt and the current time is past the last requested activate cumulus time, then yes.
+! CURR_SECS >= CUDTACTTIME
+
+! If we do run through the scheme, we set the flag run_param to TRUE and we set the decided flag
+! to TRUE. The decided flag says that one of these tests was able to say "yes", run the scheme.
+! We only proceed to other tests if the previous tests all have left decided as FALSE.
+
+! If we set run_param to TRUE and this is adaptive time stepping, we set the time to the next
+! cumulus run.
+
+ decided = .FALSE.
+ run_param = .FALSE.
+ IF ( ( .NOT. decided ) .AND. &
+ ( itimestep .EQ. 1 ) ) THEN
+ run_param = .TRUE.
+ decided = .TRUE.
+ END IF
+
+ IF ( ( .NOT. decided ) .AND. &
+ ( ( cudt .EQ. 0. ) .OR. ( stepcu .EQ. 1 ) ) ) THEN
+ run_param = .TRUE.
+ decided = .TRUE.
+ END IF
+
+ IF ( ( .NOT. decided ) .AND. &
+ ( .NOT. doing_adapt_dt ) .AND. &
+ ( MOD(itimestep,stepcu) .EQ. 0 ) ) THEN
+ run_param = .TRUE.
+ decided = .TRUE.
+ END IF
+
+ IF ( ( .NOT. decided ) .AND. &
+ ( doing_adapt_dt ) .AND. &
+ ( curr_secs .GE. cudtacttime ) ) THEN
+ run_param = .TRUE.
+ decided = .TRUE.
+ cudtacttime = curr_secs + cudt*60
+ END IF
+
+!-----------------------------------------------------------------------
+ IF(run_param) THEN
+
+ DO J=JTS,JTE
+ DO I=ITS,ITE
+ CU_ACT_FLAG(I,J)=.TRUE.
+ ENDDO
+ ENDDO
+
+ IM=ITE-ITS+1
+ KX=KTE-KTS+1
+ DELT=DT*STEPCU
+ RDELT=1./DELT
+
+!------------- J LOOP (OUTER) --------------------------------------------------
+
+ DO J=jts,jte
+
+! --------------- compute zi and zl -----------------------------------------
+ DO i=its,ite
+ ZI(I,KTS)=0.0
+ ENDDO
+
+ DO k=kts+1,kte
+ KM=k-1
+ DO i=its,ite
+ ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
+ ENDDO
+ ENDDO
+
+ DO k=kts+1,kte
+ KM=k-1
+ DO i=its,ite
+ ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
+ ENDDO
+ ENDDO
+
+ DO i=its,ite
+ ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
+ ENDDO
+
+! --------------- end compute zi and zl -------------------------------------
+ DO i=its,ite
+ SLIMSK(i)=int(ABS(XLAND(i,j)-2.))
+ ENDDO
+
+ DO k=kts,kte
+ kp=k+1
+ DO i=its,ite
+ DOT(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
+ ENDDO
+ ENDDO
+
+ DO k=kts,kte
+ zz = kte+1-k
+ DO i=its,ite
+ U1(i,zz)=U3D(i,k,j)
+ V1(i,zz)=V3D(i,k,j)
+ T1(i,zz)=T3D(i,k,j)
+ Q1(i,zz)= QV3D(i,k,j)
+ if(itimestep == 1) then
+ Q1B(i,zz)=0.
+ Q1BL(i,zz)=0.
+ else
+ Q1B(i,zz)=QVFTEN(i,k,j)
+ Q1BL(i,zz)=QVPBLTEN(i,k,j)
+ endif
+ Q2(i,zz)=QC3D(i,k,j)
+ Q3(i,zz)=QI3D(i,k,j)
+ OMG(i,zz)=DOT(i,k)
+ GHT(i,zz)=ZL(i,k)
+ PRSL(i,zz) = Pcps(i,k,j)
+ ENDDO
+ ENDDO
+
+ DO k=kts,kte+1
+ zz = kte+2-k
+ DO i=its,ite
+ PRSI(i,zz) = P8w(i,k,j)
+ ENDDO
+ ENDDO
+
+ DO k=kts,kte
+ zz = kte+1-k
+ sig1(zz) = ZNU(k)
+ ENDDO
+
+!###############before call TIECNV, we need EVAP########################
+! EVAP is the vapor flux at the surface
+!########################################################################
+!
+ DO i=its,ite
+ EVAP(i) = QFX(i,j)
+ ENDDO
+!########################################################################
+ CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP, &
+ RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT)
+
+ DO I=ITS,ITE
+ RAINCV(I,J)=RN(I)/STEPCU
+ PRATEC(I,J)=RN(I)/(STEPCU * DT)
+ ENDDO
+
+ DO K=KTS,KTE
+ zz = kte+1-k
+ DO I=ITS,ITE
+ RTHCUTEN(I,K,J)=(T1(I,zz)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
+ RQVCUTEN(I,K,J)=(Q1(I,zz)-QV3D(I,K,J))*RDELT
+ RUCUTEN(I,K,J) =(U1(I,zz)-U3D(I,K,J))*RDELT
+ RVCUTEN(I,K,J) =(V1(I,zz)-V3D(I,K,J))*RDELT
+ ENDDO
+ ENDDO
+
+ IF(PRESENT(RQCCUTEN))THEN
+ IF ( F_QC ) THEN
+ DO K=KTS,KTE
+ zz = kte+1-k
+ DO I=ITS,ITE
+ RQCCUTEN(I,K,J)=(Q2(I,zz)-QC3D(I,K,J))*RDELT
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ IF(PRESENT(RQICUTEN))THEN
+ IF ( F_QI ) THEN
+ DO K=KTS,KTE
+ zz = kte+1-k
+ DO I=ITS,ITE
+ RQICUTEN(I,K,J)=(Q3(I,zz)-QI3D(I,K,J))*RDELT
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+
+ ENDDO
+
+ ENDIF
+
+ END SUBROUTINE CU_TIEDTKE
+
+!====================================================================
+ SUBROUTINE tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, &
+ RUCUTEN,RVCUTEN, &
+ RESTART,P_QC,P_QI,P_FIRST_SCALAR, &
+ allowed_to_read, &
+ ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte)
+!--------------------------------------------------------------------
+ IMPLICIT NONE
+!--------------------------------------------------------------------
+ LOGICAL , INTENT(IN) :: allowed_to_read,restart
+ INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
+ ims, ime, jms, jme, kms, kme, &
+ its, ite, jts, jte, kts, kte
+ INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC
+
+ REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: &
+ RTHCUTEN, &
+ RQVCUTEN, &
+ RQCCUTEN, &
+ RQICUTEN, &
+ RUCUTEN,RVCUTEN
+
+ INTEGER :: i, j, k, itf, jtf, ktf
+
+ jtf=min0(jte,jde-1)
+ ktf=min0(kte,kde-1)
+ itf=min0(ite,ide-1)
+
+ IF(.not.restart)THEN
+ DO j=jts,jtf
+ DO k=kts,ktf
+ DO i=its,itf
+ RTHCUTEN(i,k,j)=0.
+ RQVCUTEN(i,k,j)=0.
+ RUCUTEN(i,k,j)=0.
+ RVCUTEN(i,k,j)=0.
+ ENDDO
+ ENDDO
+ ENDDO
+
+ IF (P_QC .ge. P_FIRST_SCALAR) THEN
+ DO j=jts,jtf
+ DO k=kts,ktf
+ DO i=its,itf
+ RQCCUTEN(i,k,j)=0.
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+
+ IF (P_QI .ge. P_FIRST_SCALAR) THEN
+ DO j=jts,jtf
+ DO k=kts,ktf
+ DO i=its,itf
+ RQICUTEN(i,k,j)=0.
+ ENDDO
+ ENDDO
+ ENDDO
+ ENDIF
+ ENDIF
+
+ END SUBROUTINE tiedtkeinit
+
+! ------------------------------------------------------------------------
+
+!------------This is the combined version for tiedtke---------------
+!----------------------------------------------------------------
+! In this module only the mass flux convection scheme of the ECMWF is included
+!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!#############################################################
+!
+! LEVEL 1 SUBROUTINEs
+!
+!#############################################################
+!********************************************************
+! subroutine TIECNV
+!********************************************************
+ SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, &
+ pap,paph,evap,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt)
+!-----------------------------------------------------------------
+! This is the interface between the meso-scale model and the mass
+! flux convection module
+!-----------------------------------------------------------------
+ implicit none
+
+ real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km)
+ real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km)
+
+ REAL PUM1(lq,km), PVM1(lq,km), &
+ PTTE(lq,km), PQTE(lq,km), PVOM(lq,km), PVOL(lq,km), &
+ PVERV(lq,km), PGEO(lq,km), PAP(lq,km), PAPH(lq,km1)
+ REAL PQHFL(lq), ZQQ(lq,km), PAPRC(lq), PAPRS(lq), &
+ PRSFC(lq), PSSFC(lq), PAPRSM(lq), PCTE(lq,km)
+ REAL ZTP1(lq,km), ZQP1(lq,km), ZTU(lq,km), ZQU(lq,km), &
+ ZLU(lq,km), ZLUDE(lq,km), ZMFU(lq,km), ZMFD(lq,km), &
+ ZQSAT(lq,km), pqc(lq,km), pqi(lq,km), ZRAIN(lq)
+
+ REAL sig(km1),sig1(km)
+ INTEGER ICBOT(lq), ICTOP(lq), KTYPE(lq), lndj(lq)
+ REAL dt
+ LOGICAL LOCUM(lq)
+
+ real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT
+ real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF
+ integer i,j,k,lq,lp,km,km1
+! real TLUCUA
+! external TLUCUA
+
+ ZTMST=dt
+! Masv flux diagnostics.
+
+ PSHEAT=0.0
+ PSRAIN=0.0
+ PSEVAP=0.0
+ PSMELT=0.0
+ PSDISS=0.0
+ DO 8 j=1,lq
+ ZRAIN(j)=0.0
+ LOCUM(j)=.FALSE.
+ PRSFC(j)=0.0
+ PSSFC(j)=0.0
+ PAPRC(j)=0.0
+ PAPRS(j)=0.0
+ PAPRSM(j)=0.0
+ PQHFL(j)=evap(j)
+ 8 CONTINUE
+
+! CONVERT MODEL VARIABLES FOR MFLUX SCHEME
+
+ DO 10 k=1,km
+ DO 10 j=1,lq
+ PTTE(j,k)=0.0
+ PCTE(j,k)=0.0
+ PVOM(j,k)=0.0
+ PVOL(j,k)=0.0
+ ZTP1(j,k)=pt(j,k)
+ ZQP1(j,k)=pqv(j,k)/(1.0+pqv(j,k))
+ PUM1(j,k)=pu(j,k)
+ PVM1(j,k)=pv(j,k)
+ PVERV(j,k)=pomg(j,k)
+ PGEO(j,k)=G*poz(j,k)
+ TT=ZTP1(j,k)
+ ZQSAT(j,k)=TLUCUA(TT)/PAP(j,k)
+ ZQSAT(j,k)=MIN(0.5,ZQSAT(j,k))
+ ZQSAT(j,k)=ZQSAT(j,k)/(1.-VTMPC1*ZQSAT(j,k))
+ PQTE(j,k)=pqvf(j,k)+pqvbl(j,k)
+ ZQQ(j,k)=PQTE(j,k)
+ 10 CONTINUE
+!
+!-----------------------------------------------------------------------
+!* 2. CALL 'CUMASTR'(MASTER-ROUTINE FOR CUMULUS PARAMETERIZATION)
+!
+ CALL CUMASTR_NEW &
+ (lq, km, km1, km-1, ZTP1, &
+ ZQP1, PUM1, PVM1, PVERV, ZQSAT, &
+ PQHFL, ZTMST, PAP, PAPH, PGEO, &
+ PTTE, PQTE, PVOM, PVOL, PRSFC, &
+ PSSFC, PAPRC, PAPRSM, PAPRS, LOCUM, &
+ KTYPE, ICBOT, ICTOP, ZTU, ZQU, &
+ ZLU, ZLUDE, ZMFU, ZMFD, ZRAIN, &
+ PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, &
+ PCTE, sig1, lndj)
+!
+! TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION
+!
+ IF(fdbk.ge.1.0e-9) THEN
+ DO 20 K=1,km
+ DO 20 j=1,lq
+ If(PCTE(j,k).GT.0.0) then
+ ZTPP1=pt(j,k)+PTTE(j,k)*ZTMST
+ if(ZTPP1.ge.t000) then
+ fliq=1.0
+ ZALF=0.0
+ else if(ZTPP1.le.hgfr) then
+ fliq=0.0
+ ZALF=ALF
+ else
+ ZTC=ZTPP1-t000
+ fliq=0.0059+0.9941*exp(-0.003102*ZTC*ZTC)
+ ZALF=ALF
+ endif
+ fice=1.0-fliq
+ pqc(j,k)=pqc(j,k)+fliq*PCTE(j,k)*ZTMST
+ pqi(j,k)=pqi(j,k)+fice*PCTE(j,k)*ZTMST
+ PTTE(j,k)=PTTE(j,k)-ZALF*RCPD*fliq*PCTE(j,k)
+ Endif
+ 20 CONTINUE
+ ENDIF
+!
+ DO 75 k=1,km
+ DO 75 j=1,lq
+ pt(j,k)=ZTP1(j,k)+PTTE(j,k)*ZTMST
+ ZQP1(j,k)=ZQP1(j,k)+(PQTE(j,k)-ZQQ(j,k))*ZTMST
+ pqv(j,k)=ZQP1(j,k)/(1.0-ZQP1(j,k))
+ 75 CONTINUE
+ DO 85 j=1,lq
+ zprecc(j)=amax1(0.0,(PRSFC(j)+PSSFC(j))*ZTMST)
+ 85 CONTINUE
+ IF (LMFDUDV) THEN
+ DO 100 k=1,km
+ DO 100 j=1,lq
+ pu(j,k)=pu(j,k)+PVOM(j,k)*ZTMST
+ pv(j,k)=pv(j,k)+PVOL(j,k)*ZTMST
+ 100 CONTINUE
+ ENDIF
+!
+ RETURN
+ END SUBROUTINE TIECNV
+
+!#############################################################
+!
+! LEVEL 2 SUBROUTINEs
+!
+!#############################################################
+!***********************************************************
+! SUBROUTINE CUMASTR_NEW
+!***********************************************************
+ SUBROUTINE CUMASTR_NEW &
+ (KLON, KLEV, KLEVP1, KLEVM1, PTEN, &
+ PQEN, PUEN, PVEN, PVERV, PQSEN, &
+ PQHFL, ZTMST, PAP, PAPH, PGEO, &
+ PTTE, PQTE, PVOM, PVOL, PRSFC, &
+ PSSFC, PAPRC, PAPRSM, PAPRS, LDCUM, &
+ KTYPE, KCBOT, KCTOP, PTU, PQU, &
+ PLU, PLUDE, PMFU, PMFD, PRAIN, &
+ PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT,&
+ PCTE, sig1, lndj)
+!
+!***CUMASTR* MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME
+! M.TIEDTKE E.C.M.W.F. 1986/1987/1989
+!***PURPOSE
+! -------
+! THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE
+! PROGNOSTIC VARIABLES T,Q,U AND V DUE TO CONVECTIVE PROCESSES.
+! PROCESSES CONSIDERED ARE: CONVECTIVE FLUXES, FORMATION OF
+! PRECIPITATION, EVAPORATION OF FALLING RAIN BELOW CLOUD BASE,
+! SATURATED CUMULUS DOWNDRAFTS.
+!***INTERFACE.
+! ----------
+! *CUMASTR* IS CALLED FROM *MSSFLX*
+! THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE
+! T,Q,U,V,PHI AND P AND MOISTURE TENDENCIES.
+! IT RETURNS ITS OUTPUT TO THE SAME SPACE
+! 1.MODIFIED TENDENCIES OF MODEL VARIABLES
+! 2.RATES OF CONVECTIVE PRECIPITATION
+! (USED IN SUBROUTINE SURF)
+! 3.CLOUD BASE, CLOUD TOP AND PRECIP FOR RADIATION
+! (USED IN SUBROUTINE CLOUD)
+!***METHOD
+! ------
+! PARAMETERIZATION IS DONE USING A MASSFLUX-SCHEME.
+! (1) DEFINE CONSTANTS AND PARAMETERS
+! (2) SPECIFY VALUES (T,Q,QS...) AT HALF LEVELS AND
+! INITIALIZE UPDRAFT- AND DOWNDRAFT-VALUES IN 'CUINI'
+! (3) CALCULATE CLOUD BASE IN 'CUBASE'
+! AND SPECIFY CLOUD BASE MASSFLUX FROM PBL MOISTURE BUDGET
+! (4) DO CLOUD ASCENT IN 'CUASC' IN ABSENCE OF DOWNDRAFTS
+! (5) DO DOWNDRAFT CALCULATIONS:
+! (A) DETERMINE VALUES AT LFS IN 'CUDLFS'
+! (B) DETERMINE MOIST DESCENT IN 'CUDDRAF'
+! (C) RECALCULATE CLOUD BASE MASSFLUX CONSIDERING THE
+! EFFECT OF CU-DOWNDRAFTS
+! (6) DO FINAL CLOUD ASCENT IN 'CUASC'
+! (7) DO FINAL ADJUSMENTS TO CONVECTIVE FLUXES IN 'CUFLX',
+! DO EVAPORATION IN SUBCLOUD LAYER
+! (8) CALCULATE INCREMENTS OF T AND Q IN 'CUDTDQ'
+! (9) CALCULATE INCREMENTS OF U AND V IN 'CUDUDV'
+!***EXTERNALS.
+! ----------
+! CUINI: INITIALIZES VALUES AT VERTICAL GRID USED IN CU-PARAMETR.
+! CUBASE: CLOUD BASE CALCULATION FOR PENETR.AND SHALLOW CONVECTION
+! CUASC: CLOUD ASCENT FOR ENTRAINING PLUME
+! CUDLFS: DETERMINES VALUES AT LFS FOR DOWNDRAFTS
+! CUDDRAF:DOES MOIST DESCENT FOR CUMULUS DOWNDRAFTS
+! CUFLX: FINAL ADJUSTMENTS TO CONVECTIVE FLUXES (ALSO IN PBL)
+! CUDQDT: UPDATES TENDENCIES FOR T AND Q
+! CUDUDV: UPDATES TENDENCIES FOR U AND V
+!***SWITCHES.
+! --------
+! LMFPEN=.T. PENETRATIVE CONVECTION IS SWITCHED ON
+! LMFSCV=.T. SHALLOW CONVECTION IS SWITCHED ON
+! LMFMID=.T. MIDLEVEL CONVECTION IS SWITCHED ON
+! LMFDD=.T. CUMULUS DOWNDRAFTS SWITCHED ON
+! LMFDUDV=.T. CUMULUS FRICTION SWITCHED ON
+!***
+! MODEL PARAMETERS (DEFINED IN SUBROUTINE CUPARAM)
+! ------------------------------------------------
+! ENTRPEN ENTRAINMENT RATE FOR PENETRATIVE CONVECTION
+! ENTRSCV ENTRAINMENT RATE FOR SHALLOW CONVECTION
+! ENTRMID ENTRAINMENT RATE FOR MIDLEVEL CONVECTION
+! ENTRDD ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS
+! CMFCTOP RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY
+! LEVEL
+! CMFCMAX MAXIMUM MASSFLUX VALUE ALLOWED FOR
+! CMFCMIN MINIMUM MASSFLUX VALUE (FOR SAFETY)
+! CMFDEPS FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS
+! CPRCON COEFFICIENT FOR CONVERSION FROM CLOUD WATER TO RAIN
+!***REFERENCE.
+! ----------
+! PAPER ON MASSFLUX SCHEME (TIEDTKE,1989)
+!-----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER KLEVM1
+ REAL ZTMST
+ REAL PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, ZCONS2
+ INTEGER JK,JL,IKB
+ REAL ZQUMQE, ZDQMIN, ZMFMAX, ZALVDCP, ZQALV
+ REAL ZHSAT, ZGAM, ZZZ, ZHHAT, ZBI, ZRO, ZDZ, ZDHDZ, ZDEPTH
+ REAL ZFAC, ZRH, ZPBMPT, DEPT, ZHT, ZEPS
+ INTEGER ICUM, ITOPM2
+ REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
+ PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PTTE(KLON,KLEV), PQTE(KLON,KLEV), &
+ PVOM(KLON,KLEV), PVOL(KLON,KLEV), &
+ PQSEN(KLON,KLEV), PGEO(KLON,KLEV), &
+ PAP(KLON,KLEV), PAPH(KLON,KLEVP1),&
+ PVERV(KLON,KLEV), PQHFL(KLON)
+ REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
+ PLU(KLON,KLEV), PLUDE(KLON,KLEV), &
+ PMFU(KLON,KLEV), PMFD(KLON,KLEV), &
+ PAPRC(KLON), PAPRS(KLON), &
+ PAPRSM(KLON), PRAIN(KLON), &
+ PRSFC(KLON), PSSFC(KLON)
+ REAL ZTENH(KLON,KLEV), ZQENH(KLON,KLEV),&
+ ZGEOH(KLON,KLEV), ZQSENH(KLON,KLEV),&
+ ZTD(KLON,KLEV), ZQD(KLON,KLEV), &
+ ZMFUS(KLON,KLEV), ZMFDS(KLON,KLEV), &
+ ZMFUQ(KLON,KLEV), ZMFDQ(KLON,KLEV), &
+ ZDMFUP(KLON,KLEV), ZDMFDP(KLON,KLEV),&
+ ZMFUL(KLON,KLEV), ZRFL(KLON), &
+ ZUU(KLON,KLEV), ZVU(KLON,KLEV), &
+ ZUD(KLON,KLEV), ZVD(KLON,KLEV)
+ REAL ZENTR(KLON), ZHCBASE(KLON), &
+ ZMFUB(KLON), ZMFUB1(KLON), &
+ ZDQPBL(KLON), ZDQCV(KLON)
+ REAL ZSFL(KLON), ZDPMEL(KLON,KLEV), &
+ PCTE(KLON,KLEV), ZCAPE(KLON), &
+ ZHEAT(KLON), ZHHATT(KLON,KLEV), &
+ ZHMIN(KLON), ZRELH(KLON)
+ REAL sig1(KLEV)
+ INTEGER ILAB(KLON,KLEV), IDTOP(KLON), &
+ ICTOP0(KLON), ILWMIN(KLON)
+ INTEGER KCBOT(KLON), KCTOP(KLON), &
+ KTYPE(KLON), IHMIN(KLON), &
+ KTOP0, lndj(KLON)
+ LOGICAL LDCUM(KLON)
+ LOGICAL LODDRAF(KLON), LLO1
+!-------------------------------------------
+! 1. SPECIFY CONSTANTS AND PARAMETERS
+!-------------------------------------------
+ 100 CONTINUE
+ ZCONS2=1./(G*ZTMST)
+!--------------------------------------------------------------
+!* 2. INITIALIZE VALUES AT VERTICAL GRID POINTS IN 'CUINI'
+!--------------------------------------------------------------
+ 200 CONTINUE
+ CALL CUINI &
+ (KLON, KLEV, KLEVP1, KLEVM1, PTEN, &
+ PQEN, PQSEN, PUEN, PVEN, PVERV, &
+ PGEO, PAPH, ZGEOH, ZTENH, ZQENH, &
+ ZQSENH, ILWMIN, PTU, PQU, ZTD, &
+ ZQD, ZUU, ZVU, ZUD, ZVD, &
+ PMFU, PMFD, ZMFUS, ZMFDS, ZMFUQ, &
+ ZMFDQ, ZDMFUP, ZDMFDP, ZDPMEL, PLU, &
+ PLUDE, ILAB)
+!----------------------------------
+!* 3.0 CLOUD BASE CALCULATIONS
+!----------------------------------
+ 300 CONTINUE
+!* (A) DETERMINE CLOUD BASE VALUES IN 'CUBASE'
+! -------------------------------------------
+ CALL CUBASE &
+ (KLON, KLEV, KLEVP1, KLEVM1, ZTENH, &
+ ZQENH, ZGEOH, PAPH, PTU, PQU, &
+ PLU, PUEN, PVEN, ZUU, ZVU, &
+ LDCUM, KCBOT, ILAB)
+!* (B) DETERMINE TOTAL MOISTURE CONVERGENCE AND
+!* THEN DECIDE ON TYPE OF CUMULUS CONVECTION
+! -----------------------------------------
+ JK=1
+ DO 310 JL=1,KLON
+ ZDQCV(JL) =PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+ ZDQPBL(JL)=0.0
+ IDTOP(JL)=0
+ 310 CONTINUE
+ DO 320 JK=2,KLEV
+ DO 315 JL=1,KLON
+ ZDQCV(JL)=ZDQCV(JL)+PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+ IF(JK.GE.KCBOT(JL)) ZDQPBL(JL)=ZDQPBL(JL)+PQTE(JL,JK) &
+ *(PAPH(JL,JK+1)-PAPH(JL,JK))
+ 315 CONTINUE
+ 320 CONTINUE
+ DO 340 JL=1,KLON
+ KTYPE(JL)=0
+ IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN
+ KTYPE(JL)=1
+ ELSE
+ KTYPE(JL)=2
+ ENDIF
+!* (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER
+!* AND DETERMINE CLOUD BASE MASSFLUX IGNORING
+!* THE EFFECTS OF DOWNDRAFTS AT THIS STAGE
+! ------------------------------------------
+ IKB=KCBOT(JL)
+ ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB)
+ ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
+ IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL)) THEN
+ ZMFUB(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
+ ELSE
+ ZMFUB(JL)=0.01
+ LDCUM(JL)=.FALSE.
+ ENDIF
+ ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
+ ZMFUB(JL)=MIN(ZMFUB(JL),ZMFMAX)
+!------------------------------------------------------
+!* 4.0 DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME
+!------------------------------------------------------
+ 400 CONTINUE
+!* (A) ESTIMATE CLOUD HEIGHT FOR ENTRAINMENT/DETRAINMENT
+!* CALCULATIONS IN CUASC (MAX.POSSIBLE CLOUD HEIGHT
+!* FOR NON-ENTRAINING PLUME, FOLLOWING A.-S.,1974)
+! -------------------------------------------------------------
+ IKB=KCBOT(JL)
+ ZHCBASE(JL)=CPD*PTU(JL,IKB)+ZGEOH(JL,IKB)+ALV*PQU(JL,IKB)
+ ICTOP0(JL)=KCBOT(JL)-1
+ 340 CONTINUE
+ ZALVDCP=ALV/CPD
+ ZQALV=1./ALV
+ DO 420 JK=KLEVM1,3,-1
+ DO 420 JL=1,KLON
+ ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
+ ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/ &
+ ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
+ ZZZ=CPD*ZTENH(JL,JK)*0.608
+ ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
+ MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
+ ZHHATT(JL,JK)=ZHHAT
+ IF(JK.LT.ICTOP0(JL).AND.ZHCBASE(JL).GT.ZHHAT) ICTOP0(JL)=JK
+ 420 CONTINUE
+ DO 430 JL=1,KLON
+ JK=KCBOT(JL)
+ ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK)
+ ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/ &
+ ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2)
+ ZZZ=CPD*ZTENH(JL,JK)*0.608
+ ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* &
+ MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.)
+ ZHHATT(JL,JK)=ZHHAT
+ 430 CONTINUE
+!
+! Find lowest possible org. detrainment level
+!
+ DO 440 JL = 1, KLON
+ ZHMIN(JL) = 0.
+ IF( LDCUM(JL).AND.KTYPE(JL).EQ.1 ) THEN
+ IHMIN(JL) = KCBOT(JL)
+ ELSE
+ IHMIN(JL) = -1
+ END IF
+ 440 CONTINUE
+!
+ ZBI = 1./(25.*G)
+ DO 450 JK = KLEV, 1, -1
+ DO 450 JL = 1, KLON
+ LLO1 = LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.IHMIN(JL).EQ.KCBOT(JL)
+ IF (LLO1.AND.JK.LT.KCBOT(JL).AND.JK.GE.ICTOP0(JL)) THEN
+ IKB = KCBOT(JL)
+ ZRO = RD*ZTENH(JL,JK)/(G*PAPH(JL,JK))
+ ZDZ = (PAPH(JL,JK)-PAPH(JL,JK-1))*ZRO
+ ZDHDZ=(CPD*(PTEN(JL,JK-1)-PTEN(JL,JK))+ALV*(PQEN(JL,JK-1)- &
+ PQEN(JL,JK))+(PGEO(JL,JK-1)-PGEO(JL,JK)))*G/(PGEO(JL, &
+ JK-1)-PGEO(JL,JK))
+ ZDEPTH = ZGEOH(JL,JK) - ZGEOH(JL,IKB)
+ ZFAC = SQRT(1.+ZDEPTH*ZBI)
+ ZHMIN(JL) = ZHMIN(JL) + ZDHDZ*ZFAC*ZDZ
+ ZRH = -ALV*(ZQSENH(JL,JK)-ZQENH(JL,JK))*ZFAC
+ IF (ZHMIN(JL).GT.ZRH) IHMIN(JL) = JK
+ END IF
+ 450 CONTINUE
+ DO 460 JL = 1, KLON
+ IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
+ IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL)
+ END IF
+ if(nentr.eq.1) then
+ IF(KTYPE(JL).EQ.1) THEN
+ ZENTR(JL)=ENTRPEN
+ ELSE
+ ZENTR(JL)=ENTRSCV
+ ENDIF
+ if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+ else
+ ZDEPTH=ZRG*(ZGEOH(JL,ICTOP0(JL))-ZGEOH(JL,KCBOT(JL)))
+ ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
+ if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+ endif
+ 460 CONTINUE
+!* (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS
+!----------------------------------------------------------
+ CALL CUASC_NEW &
+ (KLON, KLEV, KLEVP1, KLEVM1, ZTENH, &
+ ZQENH, PUEN, PVEN, PTEN, PQEN, &
+ PQSEN, PGEO, ZGEOH, PAP, PAPH, &
+ PQTE, PVERV, ILWMIN, LDCUM, ZHCBASE, &
+ KTYPE, ILAB, PTU, PQU, PLU, &
+ ZUU, ZVU, PMFU, ZMFUB, ZENTR, &
+ ZMFUS, ZMFUQ, ZMFUL, PLUDE, ZDMFUP, &
+ KCBOT, KCTOP, ICTOP0, ICUM, ZTMST, &
+ IHMIN, ZHHATT, ZQSENH)
+ IF(ICUM.EQ.0) GO TO 1000
+!* (C) CHECK CLOUD DEPTH AND CHANGE ENTRAINMENT RATE ACCORDINGLY
+! CALCULATE PRECIPITATION RATE (FOR DOWNDRAFT CALCULATION)
+!------------------------------------------------------------------
+ DO 480 JL=1,KLON
+ ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL))
+ IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL)
+ IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2
+ IF(KTYPE(JL).EQ.2.and.nentr.eq.1) then
+ ZENTR(JL)=ENTRSCV
+ if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+ endif
+ if(nentr.eq.2) then
+ ZDEPTH=ZRG*(ZGEOH(JL,KCTOP(JL))-ZGEOH(JL,KCBOT(JL)))
+ ZENTR(JL)=MAX(ENTRPEN,1.5/MAX(500.0,ZDEPTH))
+ if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.1
+ endif
+ ZRFL(JL)=ZDMFUP(JL,1)
+ 480 CONTINUE
+ DO 490 JK=2,KLEV
+ DO 490 JL=1,KLON
+ ZRFL(JL)=ZRFL(JL)+ZDMFUP(JL,JK)
+ 490 CONTINUE
+!-----------------------------------------
+!* 5.0 CUMULUS DOWNDRAFT CALCULATIONS
+!-----------------------------------------
+ 500 CONTINUE
+ IF(LMFDD) THEN
+!* (A) DETERMINE LFS IN 'CUDLFS'
+!--------------------------------------
+ CALL CUDLFS &
+ (KLON, KLEV, KLEVP1, ZTENH, ZQENH, &
+ PUEN, PVEN, ZGEOH, PAPH, PTU, &
+ PQU, ZUU, ZVU, LDCUM, KCBOT, &
+ KCTOP, ZMFUB, ZRFL, ZTD, ZQD, &
+ ZUD, ZVD, PMFD, ZMFDS, ZMFDQ, &
+ ZDMFDP, IDTOP, LODDRAF)
+!* (B) DETERMINE DOWNDRAFT T,Q AND FLUXES IN 'CUDDRAF'
+!------------------------------------------------------------
+ CALL CUDDRAF &
+ (KLON, KLEV, KLEVP1, ZTENH, ZQENH, &
+ PUEN, PVEN, ZGEOH, PAPH, ZRFL, &
+ LODDRAF, ZTD, ZQD, ZUD, ZVD, &
+ PMFD, ZMFDS, ZMFDQ, ZDMFDP)
+!* (C) RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
+! DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
+!-----------------------------------------------------------
+ END IF
+!
+!-- 5.1 Recalculate cloud base massflux from a cape closure
+! for deep convection (ktype=1) and by PBL equilibrium
+! taking downdrafts into account for shallow convection
+! (ktype=2)
+! implemented by Y. WANG based on ECHAM4 in Nov. 2001.
+!
+ DO 510 JL=1,KLON
+ ZHEAT(JL)=0.0
+ ZCAPE(JL)=0.0
+ ZRELH(JL)=0.0
+ ZMFUB1(JL)=ZMFUB(JL)
+ 510 CONTINUE
+!
+ DO 511 JL=1,KLON
+ IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN
+ KTOP0=MAX(12,KCTOP(JL))
+ DO JK=2,KLEV
+ IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN
+ ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK))
+ ZDZ=(PAPH(JL,JK)-PAPH(JL,JK-1))/(G*ZRO)
+ ZHEAT(JL)=ZHEAT(JL)+((PTEN(JL,JK-1)-PTEN(JL,JK) &
+ +G*ZDZ/CPD)/ZTENH(JL,JK)+0.608*(PQEN(JL,JK-1)- &
+ PQEN(JL,JK)))*(PMFU(JL,JK)+PMFD(JL,JK))*G/ZRO
+ ZCAPE(JL)=ZCAPE(JL)+G*((PTU(JL,JK)*(1.+.608*PQU(JL,JK) &
+ -PLU(JL,JK)))/(ZTENH(JL,JK)*(1.+.608*ZQENH(JL,JK))) &
+ -1.0)*ZDZ
+ ENDIF
+ IF(JK.LE.KCBOT(JL).AND.JK.GT.KTOP0) THEN
+ dept=(PAPH(JL,JK)-PAPH(JL,JK-1))/(PAPH(JL,KCBOT(JL))- &
+ PAPH(JL,KTOP0))
+ ZRELH(JL)=ZRELH(JL)+dept*PQEN(JL,JK)/PQSEN(JL,JK)
+ ENDIF
+ ENDDO
+!
+ IF(ZRELH(JL).GE.CRIRH) THEN
+ IKB=KCBOT(JL)
+! ZHT=MAX(0.0,(ZCAPE(JL)-300.0))/(ZTAU*ZHEAT(JL))
+ ZHT=MAX(0.0,(ZCAPE(JL)-0.0))/(ZTAU*ZHEAT(JL))
+ ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01)
+ ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
+ ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
+ ELSE
+ ZMFUB1(JL)=0.01
+ ZMFUB(JL)=0.01
+ LDCUM(JL)=.FALSE.
+ ENDIF
+ ENDIF
+ 511 CONTINUE
+!
+!* 5.2 RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF
+! DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET
+!--------------------------------------------------------
+ DO 512 JL=1,KLON
+ IF(KTYPE(JL).NE.1) THEN
+ IKB=KCBOT(JL)
+ IF(PMFD(JL,IKB).LT.0.0.AND.LODDRAF(JL)) THEN
+ ZEPS=CMFDEPS
+ ELSE
+ ZEPS=0.
+ ENDIF
+ ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)- &
+ ZEPS*ZQD(JL,IKB)-(1.-ZEPS)*ZQENH(JL,IKB)
+ ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10)
+ ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2
+ IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL) &
+ .AND.ZMFUB(JL).LT.ZMFMAX) THEN
+ ZMFUB1(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN))
+ ELSE
+ ZMFUB1(JL)=ZMFUB(JL)
+ ENDIF
+ LLO1=(KTYPE(JL).EQ.2).AND.ABS(ZMFUB1(JL) &
+ -ZMFUB(JL)).LT.0.2*ZMFUB(JL)
+ IF(.NOT.LLO1) ZMFUB1(JL)=ZMFUB(JL)
+ ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX)
+ END IF
+ 512 CONTINUE
+ DO 530 JK=1,KLEV
+ DO 530 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ ZFAC=ZMFUB1(JL)/MAX(ZMFUB(JL),1.E-10)
+ PMFD(JL,JK)=PMFD(JL,JK)*ZFAC
+ ZMFDS(JL,JK)=ZMFDS(JL,JK)*ZFAC
+ ZMFDQ(JL,JK)=ZMFDQ(JL,JK)*ZFAC
+ ZDMFDP(JL,JK)=ZDMFDP(JL,JK)*ZFAC
+ ELSE
+ PMFD(JL,JK)=0.0
+ ZMFDS(JL,JK)=0.0
+ ZMFDQ(JL,JK)=0.0
+ ZDMFDP(JL,JK)=0.0
+ ENDIF
+ 530 CONTINUE
+ DO 538 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ ZMFUB(JL)=ZMFUB1(JL)
+ ELSE
+ ZMFUB(JL)=0.0
+ ENDIF
+ 538 CONTINUE
+!
+!---------------------------------------------------------------
+!* 6.0 DETERMINE FINAL CLOUD ASCENT FOR ENTRAINING PLUME
+!* FOR PENETRATIVE CONVECTION (TYPE=1),
+!* FOR SHALLOW TO MEDIUM CONVECTION (TYPE=2)
+!* AND FOR MID-LEVEL CONVECTION (TYPE=3).
+!---------------------------------------------------------------
+ 600 CONTINUE
+ CALL CUASC_NEW &
+ (KLON, KLEV, KLEVP1, KLEVM1, ZTENH, &
+ ZQENH, PUEN, PVEN, PTEN, PQEN, &
+ PQSEN, PGEO, ZGEOH, PAP, PAPH, &
+ PQTE, PVERV, ILWMIN, LDCUM, ZHCBASE,&
+ KTYPE, ILAB, PTU, PQU, PLU, &
+ ZUU, ZVU, PMFU, ZMFUB, ZENTR, &
+ ZMFUS, ZMFUQ, ZMFUL, PLUDE, ZDMFUP, &
+ KCBOT, KCTOP, ICTOP0, ICUM, ZTMST, &
+ IHMIN, ZHHATT, ZQSENH)
+!----------------------------------------------------------
+!* 7.0 DETERMINE FINAL CONVECTIVE FLUXES IN 'CUFLX'
+!----------------------------------------------------------
+ 700 CONTINUE
+ CALL CUFLX &
+ (KLON, KLEV, KLEVP1, PQEN, PQSEN, &
+ ZTENH, ZQENH, PAPH, ZGEOH, KCBOT, &
+ KCTOP, IDTOP, KTYPE, LODDRAF, LDCUM, &
+ PMFU, PMFD, ZMFUS, ZMFDS, ZMFUQ, &
+ ZMFDQ, ZMFUL, PLUDE, ZDMFUP, ZDMFDP, &
+ ZRFL, PRAIN, PTEN, ZSFL, ZDPMEL, &
+ ITOPM2, ZTMST, sig1)
+!----------------------------------------------------------------
+!* 8.0 UPDATE TENDENCIES FOR T AND Q IN SUBROUTINE CUDTDQ
+!----------------------------------------------------------------
+ 800 CONTINUE
+ CALL CUDTDQ &
+ (KLON, KLEV, KLEVP1, ITOPM2, PAPH, &
+ LDCUM, PTEN, PTTE, PQTE, ZMFUS, &
+ ZMFDS, ZMFUQ, ZMFDQ, ZMFUL, ZDMFUP, &
+ ZDMFDP, ZTMST, ZDPMEL, PRAIN, ZRFL, &
+ ZSFL, PSRAIN, PSEVAP, PSHEAT, PSMELT, &
+ PRSFC, PSSFC, PAPRC, PAPRSM, PAPRS, &
+ PQEN, PQSEN, PLUDE, PCTE)
+!----------------------------------------------------------------
+!* 9.0 UPDATE TENDENCIES FOR U AND U IN SUBROUTINE CUDUDV
+!----------------------------------------------------------------
+ 900 CONTINUE
+ IF(LMFDUDV) THEN
+ CALL CUDUDV &
+ (KLON, KLEV, KLEVP1, ITOPM2, KTYPE, &
+ KCBOT, PAPH, LDCUM, PUEN, PVEN, &
+ PVOM, PVOL, ZUU, ZUD, ZVU, &
+ ZVD, PMFU, PMFD, PSDISS)
+ END IF
+ 1000 CONTINUE
+ RETURN
+ END SUBROUTINE CUMASTR_NEW
+!
+
+!#############################################################
+!
+! LEVEL 3 SUBROUTINEs
+!
+!#############################################################
+!**********************************************
+! SUBROUTINE CUINI
+!**********************************************
+!
+ SUBROUTINE CUINI &
+ (KLON, KLEV, KLEVP1, KLEVM1, PTEN, &
+ PQEN, PQSEN, PUEN, PVEN, PVERV, &
+ PGEO, PAPH, PGEOH, PTENH, PQENH, &
+ PQSENH, KLWMIN, PTU, PQU, PTD, &
+ PQD, PUU, PVU, PUD, PVD, &
+ PMFU, PMFD, PMFUS, PMFDS, PMFUQ, &
+ PMFDQ, PDMFUP, PDMFDP, PDPMEL, PLU, &
+ PLUDE, KLAB)
+! M.TIEDTKE E.C.M.W.F. 12/89
+!***PURPOSE
+! -------
+! THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC.
+! TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME),
+! AND INITIALIZES VALUES FOR UPDRAFTS AND DOWNDRAFTS
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!***METHOD.
+! --------
+! FOR EXTRAPOLATION TO HALF LEVELS SEE TIEDTKE(1989)
+!***EXTERNALS
+! ---------
+! *CUADJTQ* TO SPECIFY QS AT HALF LEVELS
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER klevm1
+ INTEGER JK,JL,IK, ICALL
+ REAL ZDP, ZZS
+ REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
+ PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PQSEN(KLON,KLEV), PVERV(KLON,KLEV), &
+ PGEO(KLON,KLEV), PGEOH(KLON,KLEV), &
+ PAPH(KLON,KLEVP1), PTENH(KLON,KLEV), &
+ PQENH(KLON,KLEV), PQSENH(KLON,KLEV)
+ REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
+ PTD(KLON,KLEV), PQD(KLON,KLEV), &
+ PUU(KLON,KLEV), PUD(KLON,KLEV), &
+ PVU(KLON,KLEV), PVD(KLON,KLEV), &
+ PMFU(KLON,KLEV), PMFD(KLON,KLEV), &
+ PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), &
+ PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), &
+ PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV), &
+ PLU(KLON,KLEV), PLUDE(KLON,KLEV)
+ REAL ZWMAX(KLON), ZPH(KLON), &
+ PDPMEL(KLON,KLEV)
+ INTEGER KLAB(KLON,KLEV), KLWMIN(KLON)
+ LOGICAL LOFLAG(KLON)
+!------------------------------------------------------------
+!* 1. SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS
+!* ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE
+!* FIND LEVEL OF MAXIMUM VERTICAL VELOCITY
+! -----------------------------------------------------------
+ 100 CONTINUE
+ ZDP=0.5
+ DO 130 JK=2,KLEV
+ DO 110 JL=1,KLON
+ PGEOH(JL,JK)=PGEO(JL,JK)+(PGEO(JL,JK-1)-PGEO(JL,JK))*ZDP
+ PTENH(JL,JK)=(MAX(CPD*PTEN(JL,JK-1)+PGEO(JL,JK-1), &
+ CPD*PTEN(JL,JK)+PGEO(JL,JK))-PGEOH(JL,JK))*RCPD
+ PQSENH(JL,JK)=PQSEN(JL,JK-1)
+ ZPH(JL)=PAPH(JL,JK)
+ LOFLAG(JL)=.TRUE.
+ 110 CONTINUE
+ IK=JK
+ ICALL=0
+ CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTENH,PQSENH,LOFLAG,ICALL)
+ DO 120 JL=1,KLON
+ PQENH(JL,JK)=MIN(PQEN(JL,JK-1),PQSEN(JL,JK-1)) &
+ +(PQSENH(JL,JK)-PQSEN(JL,JK-1))
+ PQENH(JL,JK)=MAX(PQENH(JL,JK),0.)
+ 120 CONTINUE
+ 130 CONTINUE
+ DO 140 JL=1,KLON
+ PTENH(JL,KLEV)=(CPD*PTEN(JL,KLEV)+PGEO(JL,KLEV)- &
+ PGEOH(JL,KLEV))*RCPD
+ PQENH(JL,KLEV)=PQEN(JL,KLEV)
+ PTENH(JL,1)=PTEN(JL,1)
+ PQENH(JL,1)=PQEN(JL,1)
+ PGEOH(JL,1)=PGEO(JL,1)
+ KLWMIN(JL)=KLEV
+ ZWMAX(JL)=0.
+ 140 CONTINUE
+ DO 160 JK=KLEVM1,2,-1
+ DO 150 JL=1,KLON
+ ZZS=MAX(CPD*PTENH(JL,JK)+PGEOH(JL,JK), &
+ CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))
+ PTENH(JL,JK)=(ZZS-PGEOH(JL,JK))*RCPD
+ 150 CONTINUE
+ 160 CONTINUE
+ DO 190 JK=KLEV,3,-1
+ DO 180 JL=1,KLON
+ IF(PVERV(JL,JK).LT.ZWMAX(JL)) THEN
+ ZWMAX(JL)=PVERV(JL,JK)
+ KLWMIN(JL)=JK
+ END IF
+ 180 CONTINUE
+ 190 CONTINUE
+!-----------------------------------------------------------
+!* 2.0 INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS
+!-----------------------------------------------------------
+ 200 CONTINUE
+ DO 230 JK=1,KLEV
+ IK=JK-1
+ IF(JK.EQ.1) IK=1
+ DO 220 JL=1,KLON
+ PTU(JL,JK)=PTENH(JL,JK)
+ PTD(JL,JK)=PTENH(JL,JK)
+ PQU(JL,JK)=PQENH(JL,JK)
+ PQD(JL,JK)=PQENH(JL,JK)
+ PLU(JL,JK)=0.
+ PUU(JL,JK)=PUEN(JL,IK)
+ PUD(JL,JK)=PUEN(JL,IK)
+ PVU(JL,JK)=PVEN(JL,IK)
+ PVD(JL,JK)=PVEN(JL,IK)
+ PMFU(JL,JK)=0.
+ PMFD(JL,JK)=0.
+ PMFUS(JL,JK)=0.
+ PMFDS(JL,JK)=0.
+ PMFUQ(JL,JK)=0.
+ PMFDQ(JL,JK)=0.
+ PDMFUP(JL,JK)=0.
+ PDMFDP(JL,JK)=0.
+ PDPMEL(JL,JK)=0.
+ PLUDE(JL,JK)=0.
+ KLAB(JL,JK)=0
+ 220 CONTINUE
+ 230 CONTINUE
+ RETURN
+ END SUBROUTINE CUINI
+
+!**********************************************
+! SUBROUTINE CUBASE
+!**********************************************
+ SUBROUTINE CUBASE &
+ (KLON, KLEV, KLEVP1, KLEVM1, PTENH, &
+ PQENH, PGEOH, PAPH, PTU, PQU, &
+ PLU, PUEN, PVEN, PUU, PVU, &
+ LDCUM, KCBOT, KLAB)
+! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
+! FOR CUMULUS PARAMETERIZATION
+! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
+!***PURPOSE.
+! --------
+! TO PRODUCE CLOUD BASE VALUES FOR CU-PARAMETRIZATION
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUMASTR*.
+! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
+! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
+! KLAB=1 FOR SUBCLOUD LEVELS
+! KLAB=2 FOR CONDENSATION LEVEL
+!***METHOD.
+! --------
+! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
+!***EXTERNALS
+! ---------
+! *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER klevm1
+ INTEGER JL,JK,IS,IK,ICALL,IKB
+ REAL ZBUO,ZZ
+ REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
+ PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1)
+ REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
+ PLU(KLON,KLEV)
+ REAL PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PUU(KLON,KLEV), PVU(KLON,KLEV)
+ REAL ZQOLD(KLON,KLEV), ZPH(KLON)
+ INTEGER KLAB(KLON,KLEV), KCBOT(KLON)
+ LOGICAL LDCUM(KLON), LOFLAG(KLON)
+!***INPUT VARIABLES:
+! PTENH [ZTENH] - Environment Temperature on half levels. (CUINI)
+! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
+! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
+! PAPH - Pressure of half levels. (MSSFLX)
+!***VARIABLES MODIFIED BY CUBASE:
+! LDCUM - Logical denoting profiles. (CUBASE)
+! KTYPE - Convection type - 1: Penetrative (CUMASTR)
+! 2: Stratocumulus (CUMASTR)
+! 3: Mid-level (CUASC)
+! PTU - Cloud Temperature.
+! PQU - Cloud specific Humidity.
+! PLU - Cloud Liquid Water (Moisture condensed out)
+! KCBOT - Cloud Base Level. (CUBASE)
+! KLAB [ILAB] - Level Label - 1: Sub-cloud layer (CUBASE)
+!------------------------------------------------
+! 1. INITIALIZE VALUES AT LIFTING LEVEL
+!------------------------------------------------
+ 100 CONTINUE
+ DO 110 JL=1,KLON
+ KLAB(JL,KLEV)=1
+ KCBOT(JL)=KLEVM1
+ LDCUM(JL)=.FALSE.
+ PUU(JL,KLEV)=PUEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
+ PVU(JL,KLEV)=PVEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV))
+ 110 CONTINUE
+!-------------------------------------------------------
+! 2.0 DO ASCENT IN SUBCLOUD LAYER,
+! CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
+! ADJUST T,Q AND L ACCORDINGLY IN *CUADJTQ*,
+! CHECK FOR BUOYANCY AND SET FLAGS
+!-------------------------------------------------------
+ DO 200 JK=1,KLEV
+ DO 200 JL=1,KLON
+ ZQOLD(JL,JK)=0.0
+ 200 CONTINUE
+ DO 290 JK=KLEVM1,2,-1
+ IS=0
+ DO 210 JL=1,KLON
+ IF(KLAB(JL,JK+1).EQ.1) THEN
+ IS=IS+1
+ LOFLAG(JL)=.TRUE.
+ ELSE
+ LOFLAG(JL)=.FALSE.
+ ENDIF
+ ZPH(JL)=PAPH(JL,JK)
+ 210 CONTINUE
+ IF(IS.EQ.0) GO TO 290
+ DO 220 JL=1,KLON
+ IF(LOFLAG(JL)) THEN
+ PQU(JL,JK)=PQU(JL,JK+1)
+ PTU(JL,JK)=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1) &
+ -PGEOH(JL,JK))*RCPD
+ ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))- &
+ PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
+ IF(ZBUO.GT.0.) KLAB(JL,JK)=1
+ ZQOLD(JL,JK)=PQU(JL,JK)
+ END IF
+ 220 CONTINUE
+ IK=JK
+ ICALL=1
+ CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
+ DO 240 JL=1,KLON
+ IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL,JK)) THEN
+ KLAB(JL,JK)=2
+ PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL,JK)-PQU(JL,JK)
+ ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))- &
+ PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0
+ IF(ZBUO.GT.0.) THEN
+ KCBOT(JL)=JK
+ LDCUM(JL)=.TRUE.
+ END IF
+ END IF
+ 240 CONTINUE
+! CALCULATE AVERAGES OF U AND V FOR SUBCLOUD ARA,.
+! THE VALUES WILL BE USED TO DEFINE CLOUD BASE VALUES.
+ IF(LMFDUDV) THEN
+ DO 250 JL=1,KLON
+ IF(JK.GE.KCBOT(JL)) THEN
+ PUU(JL,KLEV)=PUU(JL,KLEV)+ &
+ PUEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+ PVU(JL,KLEV)=PVU(JL,KLEV)+ &
+ PVEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK))
+ END IF
+ 250 CONTINUE
+ END IF
+ 290 CONTINUE
+ IF(LMFDUDV) THEN
+ DO 310 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ IKB=KCBOT(JL)
+ ZZ=1./(PAPH(JL,KLEVP1)-PAPH(JL,IKB))
+ PUU(JL,KLEV)=PUU(JL,KLEV)*ZZ
+ PVU(JL,KLEV)=PVU(JL,KLEV)*ZZ
+ ELSE
+ PUU(JL,KLEV)=PUEN(JL,KLEVM1)
+ PVU(JL,KLEV)=PVEN(JL,KLEVM1)
+ END IF
+ 310 CONTINUE
+ END IF
+ RETURN
+ END SUBROUTINE CUBASE
+
+!
+!**********************************************
+! SUBROUTINE CUASC_NEW
+!**********************************************
+ SUBROUTINE CUASC_NEW &
+ (KLON, KLEV, KLEVP1, KLEVM1, PTENH, &
+ PQENH, PUEN, PVEN, PTEN, PQEN, &
+ PQSEN, PGEO, PGEOH, PAP, PAPH, &
+ PQTE, PVERV, KLWMIN, LDCUM, PHCBASE,&
+ KTYPE, KLAB, PTU, PQU, PLU, &
+ PUU, PVU, PMFU, PMFUB, PENTR, &
+ PMFUS, PMFUQ, PMFUL, PLUDE, PDMFUP, &
+ KCBOT, KCTOP, KCTOP0, KCUM, ZTMST, &
+ KHMIN, PHHATT, PQSENH)
+! THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS
+! FOR CUMULUS PARAMETERIZATION
+! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
+! Y.WANG IPRC 11/01 MODIF.
+!***PURPOSE.
+! --------
+! TO PRODUCE CLOUD ASCENTS FOR CU-PARAMETRIZATION
+! (VERTICAL PROFILES OF T,Q,L,U AND V AND CORRESPONDING
+! FLUXES AS WELL AS PRECIPITATION RATES)
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!***METHOD.
+! --------
+! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
+! AND THEN CALCULATE MOIST ASCENT FOR
+! ENTRAINING/DETRAINING PLUME.
+! ENTRAINMENT AND DETRAINMENT RATES DIFFER FOR
+! SHALLOW AND DEEP CUMULUS CONVECTION.
+! IN CASE THERE IS NO PENETRATIVE OR SHALLOW CONVECTION
+! CHECK FOR POSSIBILITY OF MID LEVEL CONVECTION
+! (CLOUD BASE VALUES CALCULATED IN *CUBASMC*)
+!***EXTERNALS
+! ---------
+! *CUADJTQ* ADJUST T AND Q DUE TO CONDENSATION IN ASCENT
+! *CUENTR_NEW* CALCULATE ENTRAINMENT/DETRAINMENT RATES
+! *CUBASMC* CALCULATE CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
+!***REFERENCE
+! ---------
+! (TIEDTKE,1989)
+!***INPUT VARIABLES:
+! PTENH [ZTENH] - Environ Temperature on half levels. (CUINI)
+! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI)
+! PUEN - Environment wind u-component. (MSSFLX)
+! PVEN - Environment wind v-component. (MSSFLX)
+! PTEN - Environment Temperature. (MSSFLX)
+! PQEN - Environment Specific Humidity. (MSSFLX)
+! PQSEN - Environment Saturation Specific Humidity. (MSSFLX)
+! PGEO - Geopotential. (MSSFLX)
+! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX)
+! PAP - Pressure in Pa. (MSSFLX)
+! PAPH - Pressure of half levels. (MSSFLX)
+! PQTE - Moisture convergence (Delta q/Delta t). (MSSFLX)
+! PVERV - Large Scale Vertical Velocity (Omega). (MSSFLX)
+! KLWMIN [ILWMIN] - Level of Minimum Omega. (CUINI)
+! KLAB [ILAB] - Level Label - 1: Sub-cloud layer.
+! 2: Condensation Level (Cloud Base)
+! PMFUB [ZMFUB] - Updraft Mass Flux at Cloud Base. (CUMASTR)
+!***VARIABLES MODIFIED BY CUASC:
+! LDCUM - Logical denoting profiles. (CUBASE)
+! KTYPE - Convection type - 1: Penetrative (CUMASTR)
+! 2: Stratocumulus (CUMASTR)
+! 3: Mid-level (CUASC)
+! PTU - Cloud Temperature.
+! PQU - Cloud specific Humidity.
+! PLU - Cloud Liquid Water (Moisture condensed out)
+! PUU [ZUU] - Cloud Momentum U-Component.
+! PVU [ZVU] - Cloud Momentum V-Component.
+! PMFU - Updraft Mass Flux.
+! PENTR [ZENTR] - Entrainment Rate. (CUMASTR ) (CUBASMC)
+! PMFUS [ZMFUS] - Updraft Flux of Dry Static Energy. (CUBASMC)
+! PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity.
+! PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water.
+! PLUDE - Liquid Water Returned to Environment by Detrainment.
+! PDMFUP [ZMFUP] -
+! KCBOT - Cloud Base Level. (CUBASE)
+! KCTOP -
+! KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR)
+! KCUM [ICUM] -
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER klevm1,kcum
+ REAL ZTMST,ZCONS2,ZDZ,ZDRODZ
+ INTEGER JL,JK,IKB,IK,IS,IKT,ICALL
+ REAL ZMFMAX,ZFAC,ZMFTEST,ZDPRHO,ZMSE,ZNEVN,ZODMAX
+ REAL ZQEEN,ZSEEN,ZSCDE,ZGA,ZDT,ZSCOD
+ REAL ZQUDE,ZQCOD, ZMFUSK, ZMFUQK,ZMFULK
+ REAL ZBUO, ZPRCON, ZLNEW, ZZ, ZDMFEU, ZDMFDU
+ REAL ZBUOYZ,ZZDMF
+ REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
+ PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
+ PGEO(KLON,KLEV), PGEOH(KLON,KLEV), &
+ PAP(KLON,KLEV), PAPH(KLON,KLEVP1), &
+ PQSEN(KLON,KLEV), PQTE(KLON,KLEV), &
+ PVERV(KLON,KLEV), PQSENH(KLON,KLEV)
+ REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
+ PUU(KLON,KLEV), PVU(KLON,KLEV), &
+ PMFU(KLON,KLEV), ZPH(KLON), &
+ PMFUB(KLON), PENTR(KLON), &
+ PMFUS(KLON,KLEV), PMFUQ(KLON,KLEV), &
+ PLU(KLON,KLEV), PLUDE(KLON,KLEV), &
+ PMFUL(KLON,KLEV), PDMFUP(KLON,KLEV)
+ REAL ZDMFEN(KLON), ZDMFDE(KLON), &
+ ZMFUU(KLON), ZMFUV(KLON), &
+ ZPBASE(KLON), ZQOLD(KLON), &
+ PHHATT(KLON,KLEV), ZODETR(KLON,KLEV), &
+ ZOENTR(KLON,KLEV), ZBUOY(KLON)
+ REAL PHCBASE(KLON)
+ INTEGER KLWMIN(KLON), KTYPE(KLON), &
+ KLAB(KLON,KLEV), KCBOT(KLON), &
+ KCTOP(KLON), KCTOP0(KLON), &
+ KHMIN(KLON)
+ LOGICAL LDCUM(KLON), LOFLAG(KLON)
+!--------------------------------
+!* 1. SPECIFY PARAMETERS
+!--------------------------------
+ 100 CONTINUE
+ ZCONS2=1./(G*ZTMST)
+!---------------------------------
+! 2. SET DEFAULT VALUES
+!---------------------------------
+ 200 CONTINUE
+ DO 210 JL=1,KLON
+ ZMFUU(JL)=0.
+ ZMFUV(JL)=0.
+ ZBUOY(JL)=0.
+ IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
+ 210 CONTINUE
+ DO 230 JK=1,KLEV
+ DO 230 JL=1,KLON
+ PLU(JL,JK)=0.
+ PMFU(JL,JK)=0.
+ PMFUS(JL,JK)=0.
+ PMFUQ(JL,JK)=0.
+ PMFUL(JL,JK)=0.
+ PLUDE(JL,JK)=0.
+ PDMFUP(JL,JK)=0.
+ ZOENTR(JL,JK)=0.
+ ZODETR(JL,JK)=0.
+ IF(.NOT.LDCUM(JL).OR.KTYPE(JL).EQ.3) KLAB(JL,JK)=0
+ IF(.NOT.LDCUM(JL).AND.PAPH(JL,JK).LT.4.E4) KCTOP0(JL)=JK
+ 230 CONTINUE
+!------------------------------------------------
+! 3.0 INITIALIZE VALUES AT LIFTING LEVEL
+!------------------------------------------------
+ DO 310 JL=1,KLON
+ KCTOP(JL)=KLEVM1
+ IF(.NOT.LDCUM(JL)) THEN
+ KCBOT(JL)=KLEVM1
+ PMFUB(JL)=0.
+ PQU(JL,KLEV)=0.
+ END IF
+ PMFU(JL,KLEV)=PMFUB(JL)
+ PMFUS(JL,KLEV)=PMFUB(JL)*(CPD*PTU(JL,KLEV)+PGEOH(JL,KLEV))
+ PMFUQ(JL,KLEV)=PMFUB(JL)*PQU(JL,KLEV)
+ IF(LMFDUDV) THEN
+ ZMFUU(JL)=PMFUB(JL)*PUU(JL,KLEV)
+ ZMFUV(JL)=PMFUB(JL)*PVU(JL,KLEV)
+ END IF
+ 310 CONTINUE
+!
+!-- 3.1 Find organized entrainment at cloud base
+!
+ DO 322 JL=1,KLON
+ LDCUM(JL)=.FALSE.
+ IF (KTYPE(JL).EQ.1) THEN
+ IKB = KCBOT(JL)
+ ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ &
+ 0.608*(PQU(JL,IKB)-PQENH(JL,IKB)))
+ IF (ZBUOY(JL).GT.0.) THEN
+ ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG
+ ZDRODZ = -LOG(PTEN(JL,IKB-1)/PTEN(JL,IKB))/ZDZ - &
+ G/(RD*PTENH(JL,IKB))
+ ZOENTR(JL,IKB-1)=ZBUOY(JL)*0.5/(1.+ZBUOY(JL)*ZDZ) &
+ +ZDRODZ
+ ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3)
+ ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.)
+ END IF
+ END IF
+ 322 CONTINUE
+!
+!-----------------------------------------------------------------
+! 4. DO ASCENT: SUBCLOUD LAYER (KLAB=1) ,CLOUDS (KLAB=2)
+! BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN
+! BY ADJUSTING T,Q AND L ACCORDINGLY IN *CUADJTQ*,
+! THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY
+!-----------------------------------------------------------------
+ 400 CONTINUE
+ DO 480 JK=KLEVM1,2,-1
+! SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION
+! IN *CUBASMC* IN CASE THERE IS NOT ALREADY CONVECTION
+! ---------------------------------------------------------------------
+ IK=JK
+ IF(LMFMID.AND.IK.LT.KLEVM1.AND.IK.GT.KLEV-13) THEN
+ CALL CUBASMC &
+ (KLON, KLEV, KLEVM1, IK, PTEN, &
+ PQEN, PQSEN, PUEN, PVEN, PVERV, &
+ PGEO, PGEOH, LDCUM, KTYPE, KLAB, &
+ PMFU, PMFUB, PENTR, KCBOT, PTU, &
+ PQU, PLU, PUU, PVU, PMFUS, &
+ PMFUQ, PMFUL, PDMFUP, ZMFUU, ZMFUV)
+ ENDIF
+ IS=0
+ DO 410 JL=1,KLON
+ ZQOLD(JL)=0.0
+ IS=IS+KLAB(JL,JK+1)
+ IF(KLAB(JL,JK+1).EQ.0) KLAB(JL,JK)=0
+ LOFLAG(JL)=KLAB(JL,JK+1).GT.0
+ ZPH(JL)=PAPH(JL,JK)
+ IF(KTYPE(JL).EQ.3.AND.JK.EQ.KCBOT(JL)) THEN
+ ZMFMAX=(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2
+ IF(PMFUB(JL).GT.ZMFMAX) THEN
+ ZFAC=ZMFMAX/PMFUB(JL)
+ PMFU(JL,JK+1)=PMFU(JL,JK+1)*ZFAC
+ PMFUS(JL,JK+1)=PMFUS(JL,JK+1)*ZFAC
+ PMFUQ(JL,JK+1)=PMFUQ(JL,JK+1)*ZFAC
+ ZMFUU(JL)=ZMFUU(JL)*ZFAC
+ ZMFUV(JL)=ZMFUV(JL)*ZFAC
+ PMFUB(JL)=ZMFMAX
+ END IF
+ END IF
+ 410 CONTINUE
+ IF(IS.EQ.0) GO TO 480
+!
+!* SPECIFY ENTRAINMENT RATES IN *CUENTR_NEW*
+! -------------------------------------
+ IK=JK
+ CALL CUENTR_NEW &
+ (KLON, KLEV, KLEVP1, IK, PTENH,&
+ PAPH, PAP, PGEOH, KLWMIN, LDCUM,&
+ KTYPE, KCBOT, KCTOP0, ZPBASE, PMFU, &
+ PENTR, ZDMFEN, ZDMFDE, ZODETR, KHMIN)
+!
+! DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME
+! -------------------------------------------------------
+! Do adiabatic ascent for entraining/detraining plume
+! the cloud ensemble entrains environmental values
+! in turbulent detrainment cloud ensemble values are detrained
+! in organized detrainment the dry static energy and
+! moisture that are neutral compared to the
+! environmental air are detrained
+!
+ DO 420 JL=1,KLON
+ IF(LOFLAG(JL)) THEN
+ IF(JK.LT.KCBOT(JL)) THEN
+ ZMFTEST=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
+ ZMFMAX=MIN(ZMFTEST,(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2)
+ ZDMFEN(JL)=MAX(ZDMFEN(JL)-MAX(ZMFTEST-ZMFMAX,0.),0.)
+ END IF
+ ZDMFDE(JL)=MIN(ZDMFDE(JL),0.75*PMFU(JL,JK+1))
+ PMFU(JL,JK)=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL)
+ IF (JK.LT.kcbot(jl)) THEN
+ zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
+ zoentr(jl,jk) = zoentr(jl,jk)*zdprho*pmfu(jl,jk+1)
+ zmftest = pmfu(jl,jk) + zoentr(jl,jk)-zodetr(jl,jk)
+ zmfmax = MIN(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2)
+ zoentr(jl,jk) = MAX(zoentr(jl,jk)-MAX(zmftest-zmfmax,0.),0.)
+ END IF
+!
+! limit organized detrainment to not allowing for too deep clouds
+!
+ IF (ktype(jl).EQ.1.AND.jk.LT.kcbot(jl).AND.jk.LE.khmin(jl)) THEN
+ zmse = cpd*ptu(jl,jk+1) + alv*pqu(jl,jk+1) + pgeoh(jl,jk+1)
+ ikt = kctop0(jl)
+ znevn=(pgeoh(jl,ikt)-pgeoh(jl,jk+1))*(zmse-phhatt(jl, &
+ jk+1))*zrg
+ IF (znevn.LE.0.) znevn = 1.
+ zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
+ zodmax = ((phcbase(jl)-zmse)/znevn)*zdprho*pmfu(jl,jk+1)
+ zodmax = MAX(zodmax,0.)
+ zodetr(jl,jk) = MIN(zodetr(jl,jk),zodmax)
+ END IF
+ zodetr(jl,jk) = MIN(zodetr(jl,jk),0.75*pmfu(jl,jk))
+ pmfu(jl,jk) = pmfu(jl,jk) + zoentr(jl,jk) - zodetr(jl,jk)
+ ZQEEN=PQENH(JL,JK+1)*ZDMFEN(JL)
+ zqeen=zqeen + pqenh(jl,jk+1)*zoentr(jl,jk)
+ ZSEEN=(CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFEN(JL)
+ zseen=zseen+(cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))* &
+ zoentr(jl,jk)
+ ZSCDE=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFDE(JL)
+! find moist static energy that give nonbuoyant air
+ zga = alv*pqsenh(jl,jk+1)/(rv*(ptenh(jl,jk+1)**2))
+ zdt = (plu(jl,jk+1)-0.608*(pqsenh(jl,jk+1)-pqenh(jl, &
+ jk+1)))/(1./ptenh(jl,jk+1)+0.608*zga)
+ zscod = cpd*ptenh(jl,jk+1) + pgeoh(jl,jk+1) + cpd*zdt
+ zscde = zscde + zodetr(jl,jk)*zscod
+ zqude = pqu(jl,jk+1)*zdmfde(jl)
+ zqcod = pqsenh(jl,jk+1) + zga*zdt
+ zqude = zqude + zodetr(jl,jk)*zqcod
+ plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl)
+ plude(jl,jk) = plude(jl,jk)+plu(jl,jk+1)*zodetr(jl,jk)
+ zmfusk = pmfus(jl,jk+1) + zseen - zscde
+ zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude
+ zmfulk = pmful(jl,jk+1) - plude(jl,jk)
+ plu(jl,jk) = zmfulk*(1./MAX(cmfcmin,pmfu(jl,jk)))
+ pqu(jl,jk) = zmfuqk*(1./MAX(cmfcmin,pmfu(jl,jk)))
+ ptu(jl,jk)=(zmfusk*(1./MAX(cmfcmin,pmfu(jl,jk)))- &
+ pgeoh(jl,jk))*rcpd
+ ptu(jl,jk) = MAX(100.,ptu(jl,jk))
+ ptu(jl,jk) = MIN(400.,ptu(jl,jk))
+ zqold(jl) = pqu(jl,jk)
+ END IF
+ 420 CONTINUE
+!* DO CORRECTIONS FOR MOIST ASCENT
+!* BY ADJUSTING T,Q AND L IN *CUADJTQ*
+!------------------------------------------------
+ IK=JK
+ ICALL=1
+!
+ CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL)
+!
+ DO 440 JL=1,KLON
+ IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL)) THEN
+ KLAB(JL,JK)=2
+ PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL)-PQU(JL,JK)
+ ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK)-PLU(JL,JK))- &
+ PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
+ IF(KLAB(JL,JK+1).EQ.1) ZBUO=ZBUO+ZBUO0
+ IF(ZBUO.GT.0..AND.PMFU(JL,JK).GT.0.01*PMFUB(JL).AND. &
+ JK.GE.KCTOP0(JL)) THEN
+ KCTOP(JL)=JK
+ LDCUM(JL)=.TRUE.
+ IF(ZPBASE(JL)-PAPH(JL,JK).GE.ZDNOPRC) THEN
+ ZPRCON=CPRCON
+ ELSE
+ ZPRCON=0.
+ ENDIF
+ ZLNEW=PLU(JL,JK)/(1.+ZPRCON*(PGEOH(JL,JK)-PGEOH(JL,JK+1)))
+ PDMFUP(JL,JK)=MAX(0.,(PLU(JL,JK)-ZLNEW)*PMFU(JL,JK))
+ PLU(JL,JK)=ZLNEW
+ ELSE
+ KLAB(JL,JK)=0
+ PMFU(JL,JK)=0.
+ END IF
+ END IF
+ IF(LOFLAG(JL)) THEN
+ PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
+ PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
+ PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
+ END IF
+ 440 CONTINUE
+!
+ IF(LMFDUDV) THEN
+!
+ DO 460 JL=1,KLON
+ zdmfen(jl) = zdmfen(jl) + zoentr(jl,jk)
+ zdmfde(jl) = zdmfde(jl) + zodetr(jl,jk)
+ IF(LOFLAG(JL)) THEN
+ IF(KTYPE(JL).EQ.1.OR.KTYPE(JL).EQ.3) THEN
+ IF(ZDMFEN(JL).LE.1.E-20) THEN
+ ZZ=3.
+ ELSE
+ ZZ=2.
+ ENDIF
+ ELSE
+ IF(ZDMFEN(JL).LE.1.0E-20) THEN
+ ZZ=1.
+ ELSE
+ ZZ=0.
+ ENDIF
+ END IF
+ ZDMFEU=ZDMFEN(JL)+ZZ*ZDMFDE(JL)
+ ZDMFDU=ZDMFDE(JL)+ZZ*ZDMFDE(JL)
+ ZDMFDU=MIN(ZDMFDU,0.75*PMFU(JL,JK+1))
+ ZMFUU(JL)=ZMFUU(JL)+ &
+ ZDMFEU*PUEN(JL,JK)-ZDMFDU*PUU(JL,JK+1)
+ ZMFUV(JL)=ZMFUV(JL)+ &
+ ZDMFEU*PVEN(JL,JK)-ZDMFDU*PVU(JL,JK+1)
+ IF(PMFU(JL,JK).GT.0.) THEN
+ PUU(JL,JK)=ZMFUU(JL)*(1./PMFU(JL,JK))
+ PVU(JL,JK)=ZMFUV(JL)*(1./PMFU(JL,JK))
+ END IF
+ END IF
+ 460 CONTINUE
+!
+ END IF
+!
+! Compute organized entrainment
+! for use at next level
+!
+ DO 470 jl = 1, klon
+ IF (loflag(jl).AND.ktype(jl).EQ.1) THEN
+ zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+ &
+ 0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk))
+ zbuoyz = MAX(zbuoyz,0.0)
+ zdz = (pgeo(jl,jk-1)-pgeo(jl,jk))*zrg
+ zdrodz = -LOG(pten(jl,jk-1)/pten(jl,jk))/zdz - &
+ g/(rd*ptenh(jl,jk))
+ zbuoy(jl) = zbuoy(jl) + zbuoyz*zdz
+ zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz
+ zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3)
+ zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.)
+ END IF
+ 470 CONTINUE
+!
+ 480 CONTINUE
+! -----------------------------------------------------------------
+! 5. DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL
+! -----------------------------------------------------------------
+! (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT
+! AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN
+! FROM PREVIOUS CALCULATIONS ABOVE)
+ 500 CONTINUE
+ DO 510 JL=1,KLON
+ IF(KCTOP(JL).EQ.KLEVM1) LDCUM(JL)=.FALSE.
+ KCBOT(JL)=MAX(KCBOT(JL),KCTOP(JL))
+ 510 CONTINUE
+ IS=0
+ DO 520 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ IS=IS+1
+ ENDIF
+ 520 CONTINUE
+ KCUM=IS
+ IF(IS.EQ.0) GO TO 800
+ DO 530 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ JK=KCTOP(JL)-1
+ ZZDMF=CMFCTOP
+ ZDMFDE(JL)=(1.-ZZDMF)*PMFU(JL,JK+1)
+ PLUDE(JL,JK)=ZDMFDE(JL)*PLU(JL,JK+1)
+ PMFU(JL,JK)=PMFU(JL,JK+1)-ZDMFDE(JL)
+ PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK)
+ PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK)
+ PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK)
+ PLUDE(JL,JK-1)=PMFUL(JL,JK)
+ PDMFUP(JL,JK)=0.
+ END IF
+ 530 CONTINUE
+ IF(LMFDUDV) THEN
+ DO 540 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ JK=KCTOP(JL)-1
+ PUU(JL,JK)=PUU(JL,JK+1)
+ PVU(JL,JK)=PVU(JL,JK+1)
+ END IF
+ 540 CONTINUE
+ END IF
+ 800 CONTINUE
+ RETURN
+ END SUBROUTINE CUASC_NEW
+!
+
+!**********************************************
+! SUBROUTINE CUDLFS
+!**********************************************
+ SUBROUTINE CUDLFS &
+ (KLON, KLEV, KLEVP1, PTENH, PQENH, &
+ PUEN, PVEN, PGEOH, PAPH, PTU, &
+ PQU, PUU, PVU, LDCUM, KCBOT, &
+ KCTOP, PMFUB, PRFL, PTD, PQD, &
+ PUD, PVD, PMFD, PMFDS, PMFDQ, &
+ PDMFDP, KDTOP, LDDRAF)
+! THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR
+! CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES
+! M.TIEDTKE E.C.M.W.F. 12/86 MODIF. 12/89
+!***PURPOSE.
+! --------
+! TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS
+! FOR MASSFLUX CUMULUS PARAMETERIZATION
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUMASTR*.
+! INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI
+! AND UPDRAFT VALUES T,Q,U AND V AND ALSO
+! CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE.
+! IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS.
+!***METHOD.
+! --------
+! CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF
+! MOIST ENVIRONMENTAL AIR AND CLOUD AIR.
+!***EXTERNALS
+! ---------
+! *CUADJTQ* FOR CALCULATING WET BULB T AND Q AT LFS
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER JL,KE,JK,IS,IK,ICALL
+ REAL ZTTEST, ZQTEST, ZBUO, ZMFTOP
+ REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
+ PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1), &
+ PTU(KLON,KLEV), PQU(KLON,KLEV), &
+ PUU(KLON,KLEV), PVU(KLON,KLEV), &
+ PMFUB(KLON), PRFL(KLON)
+ REAL PTD(KLON,KLEV), PQD(KLON,KLEV), &
+ PUD(KLON,KLEV), PVD(KLON,KLEV), &
+ PMFD(KLON,KLEV), PMFDS(KLON,KLEV), &
+ PMFDQ(KLON,KLEV), PDMFDP(KLON,KLEV)
+ REAL ZTENWB(KLON,KLEV), ZQENWB(KLON,KLEV), &
+ ZCOND(KLON), ZPH(KLON)
+ INTEGER KCBOT(KLON), KCTOP(KLON), &
+ KDTOP(KLON)
+ LOGICAL LDCUM(KLON), LLo2(KLON), &
+ LDDRAF(KLON)
+!-----------------------------------------------
+! 1. SET DEFAULT VALUES FOR DOWNDRAFTS
+!-----------------------------------------------
+ 100 CONTINUE
+ DO 110 JL=1,KLON
+ LDDRAF(JL)=.FALSE.
+ KDTOP(JL)=KLEVP1
+ 110 CONTINUE
+ IF(.NOT.LMFDD) GO TO 300
+!------------------------------------------------------------
+! 2. DETERMINE LEVEL OF FREE SINKING BY
+! DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS
+! FOR EVERY POINT AND PROCEED AS FOLLOWS:
+! (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q
+! (2) DO MIXING WITH CUMULUS CLOUD AIR
+! (3) CHECK FOR NEGATIVE BUOYANCY
+! THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE
+! OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB
+! TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO
+! EVAPORATION OF RAIN AND CLOUD WATER)
+!------------------------------------------------------------------
+ 200 CONTINUE
+ KE=KLEV-3
+ DO 290 JK=3,KE
+! 2.1 CALCULATE WET-BULB TEMPERATURE AND MOISTURE
+! FOR ENVIRONMENTAL AIR IN *CUADJTQ*
+! -----------------------------------------------------
+ 210 CONTINUE
+ IS=0
+ DO 212 JL=1,KLON
+ ZTENWB(JL,JK)=PTENH(JL,JK)
+ ZQENWB(JL,JK)=PQENH(JL,JK)
+ ZPH(JL)=PAPH(JL,JK)
+ LLO2(JL)=LDCUM(JL).AND.PRFL(JL).GT.0..AND..NOT.LDDRAF(JL).AND. &
+ (JK.LT.KCBOT(JL).AND.JK.GT.KCTOP(JL))
+ IF(LLO2(JL))THEN
+ IS=IS+1
+ ENDIF
+ 212 CONTINUE
+ IF(IS.EQ.0) GO TO 290
+ IK=JK
+ ICALL=2
+ CALL CUADJTQ(KLON,KLEV,IK,ZPH,ZTENWB,ZQENWB,LLO2,ICALL)
+! 2.2 DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR
+! AND CHECK FOR NEGATIVE BUOYANCY.
+! THEN SET VALUES FOR DOWNDRAFT AT LFS.
+! -----------------------------------------------------
+ 220 CONTINUE
+ DO 222 JL=1,KLON
+ IF(LLO2(JL)) THEN
+ ZTTEST=0.5*(PTU(JL,JK)+ZTENWB(JL,JK))
+ ZQTEST=0.5*(PQU(JL,JK)+ZQENWB(JL,JK))
+ ZBUO=ZTTEST*(1.+VTMPC1*ZQTEST)- &
+ PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
+ ZCOND(JL)=PQENH(JL,JK)-ZQENWB(JL,JK)
+ ZMFTOP=-CMFDEPS*PMFUB(JL)
+ IF(ZBUO.LT.0..AND.PRFL(JL).GT.10.*ZMFTOP*ZCOND(JL)) THEN
+ KDTOP(JL)=JK
+ LDDRAF(JL)=.TRUE.
+ PTD(JL,JK)=ZTTEST
+ PQD(JL,JK)=ZQTEST
+ PMFD(JL,JK)=ZMFTOP
+ PMFDS(JL,JK)=PMFD(JL,JK)*(CPD*PTD(JL,JK)+PGEOH(JL,JK))
+ PMFDQ(JL,JK)=PMFD(JL,JK)*PQD(JL,JK)
+ PDMFDP(JL,JK-1)=-0.5*PMFD(JL,JK)*ZCOND(JL)
+ PRFL(JL)=PRFL(JL)+PDMFDP(JL,JK-1)
+ END IF
+ END IF
+ 222 CONTINUE
+ IF(LMFDUDV) THEN
+ DO 224 JL=1,KLON
+ IF(PMFD(JL,JK).LT.0.) THEN
+ PUD(JL,JK)=0.5*(PUU(JL,JK)+PUEN(JL,JK-1))
+ PVD(JL,JK)=0.5*(PVU(JL,JK)+PVEN(JL,JK-1))
+ END IF
+ 224 CONTINUE
+ END IF
+ 290 CONTINUE
+ 300 CONTINUE
+ RETURN
+ END SUBROUTINE CUDLFS
+!
+
+!**********************************************
+! SUBROUTINE CUDDRAF
+!**********************************************
+ SUBROUTINE CUDDRAF &
+ (KLON, KLEV, KLEVP1, PTENH, PQENH, &
+ PUEN, PVEN, PGEOH, PAPH, PRFL, &
+ LDDRAF, PTD, PQD, PUD, PVD, &
+ PMFD, PMFDS, PMFDQ, PDMFDP)
+! THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT
+! M.TIEDTKE E.C.M.W.F. 12/86 MODIF. 12/89
+!***PURPOSE.
+! --------
+! TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS
+! (I.E. T,Q,U AND V AND FLUXES)
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUMASTR*.
+! INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS.
+! IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE
+! AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS
+!***METHOD.
+! --------
+! CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY
+! A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND
+! B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE.
+!***EXTERNALS
+! ---------
+! *CUADJTQ* FOR ADJUSTING T AND Q DUE TO EVAPORATION IN
+! SATURATED DESCENT
+!***REFERENCE
+! ---------
+! (TIEDTKE,1989)
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER JK,IS,JL,ITOPDE, IK, ICALL
+ REAL ZENTR,ZSEEN, ZQEEN, ZSDDE, ZQDDE,ZMFDSK, ZMFDQK
+ REAL ZBUO, ZDMFDP, ZMFDUK, ZMFDVK
+ REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
+ PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1)
+ REAL PTD(KLON,KLEV), PQD(KLON,KLEV), &
+ PUD(KLON,KLEV), PVD(KLON,KLEV), &
+ PMFD(KLON,KLEV), PMFDS(KLON,KLEV), &
+ PMFDQ(KLON,KLEV), PDMFDP(KLON,KLEV), &
+ PRFL(KLON)
+ REAL ZDMFEN(KLON), ZDMFDE(KLON), &
+ ZCOND(KLON), ZPH(KLON)
+ LOGICAL LDDRAF(KLON), LLO2(KLON)
+!--------------------------------------------------------------
+! 1. CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY
+! (A) CALCULATING ENTRAINMENT RATES, ASSUMING
+! LINEAR DECREASE OF MASSFLUX IN PBL
+! (B) DOING MOIST DESCENT - EVAPORATIVE COOLING
+! AND MOISTENING IS CALCULATED IN *CUADJTQ*
+! (C) CHECKING FOR NEGATIVE BUOYANCY AND
+! SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES
+! ----------------------------------------------------------------
+ 100 CONTINUE
+ DO 180 JK=3,KLEV
+ IS=0
+ DO 110 JL=1,KLON
+ ZPH(JL)=PAPH(JL,JK)
+ LLO2(JL)=LDDRAF(JL).AND.PMFD(JL,JK-1).LT.0.
+ IF(LLO2(JL)) THEN
+ IS=IS+1
+ ENDIF
+ 110 CONTINUE
+ IF(IS.EQ.0) GO TO 180
+ DO 122 JL=1,KLON
+ IF(LLO2(JL)) THEN
+ ZENTR=ENTRDD*PMFD(JL,JK-1)*RD*PTENH(JL,JK-1)/ &
+ (G*PAPH(JL,JK-1))*(PAPH(JL,JK)-PAPH(JL,JK-1))
+ ZDMFEN(JL)=ZENTR
+ ZDMFDE(JL)=ZENTR
+ END IF
+ 122 CONTINUE
+ ITOPDE=KLEV-2
+ IF(JK.GT.ITOPDE) THEN
+ DO 124 JL=1,KLON
+ IF(LLO2(JL)) THEN
+ ZDMFEN(JL)=0.
+ ZDMFDE(JL)=PMFD(JL,ITOPDE)* &
+ (PAPH(JL,JK)-PAPH(JL,JK-1))/ &
+ (PAPH(JL,KLEVP1)-PAPH(JL,ITOPDE))
+ END IF
+ 124 CONTINUE
+ END IF
+ DO 126 JL=1,KLON
+ IF(LLO2(JL)) THEN
+ PMFD(JL,JK)=PMFD(JL,JK-1)+ZDMFEN(JL)-ZDMFDE(JL)
+ ZSEEN=(CPD*PTENH(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFEN(JL)
+ ZQEEN=PQENH(JL,JK-1)*ZDMFEN(JL)
+ ZSDDE=(CPD*PTD(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFDE(JL)
+ ZQDDE=PQD(JL,JK-1)*ZDMFDE(JL)
+ ZMFDSK=PMFDS(JL,JK-1)+ZSEEN-ZSDDE
+ ZMFDQK=PMFDQ(JL,JK-1)+ZQEEN-ZQDDE
+ PQD(JL,JK)=ZMFDQK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
+ PTD(JL,JK)=(ZMFDSK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))- &
+ PGEOH(JL,JK))*RCPD
+ PTD(JL,JK)=MIN(400.,PTD(JL,JK))
+ PTD(JL,JK)=MAX(100.,PTD(JL,JK))
+ ZCOND(JL)=PQD(JL,JK)
+ END IF
+ 126 CONTINUE
+ IK=JK
+ ICALL=2
+ CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTD,PQD,LLO2,ICALL)
+ DO 150 JL=1,KLON
+ IF(LLO2(JL)) THEN
+ ZCOND(JL)=ZCOND(JL)-PQD(JL,JK)
+ ZBUO=PTD(JL,JK)*(1.+VTMPC1*PQD(JL,JK))- &
+ PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))
+ IF(ZBUO.GE.0..OR.PRFL(JL).LE.(PMFD(JL,JK)*ZCOND(JL))) THEN
+ PMFD(JL,JK)=0.
+ ENDIF
+ PMFDS(JL,JK)=(CPD*PTD(JL,JK)+PGEOH(JL,JK))*PMFD(JL,JK)
+ PMFDQ(JL,JK)=PQD(JL,JK)*PMFD(JL,JK)
+ ZDMFDP=-PMFD(JL,JK)*ZCOND(JL)
+ PDMFDP(JL,JK-1)=ZDMFDP
+ PRFL(JL)=PRFL(JL)+ZDMFDP
+ END IF
+ 150 CONTINUE
+ IF(LMFDUDV) THEN
+ DO 160 JL=1,KLON
+ IF(LLO2(JL).AND.PMFD(JL,JK).LT.0.) THEN
+ ZMFDUK=PMFD(JL,JK-1)*PUD(JL,JK-1)+ &
+ ZDMFEN(JL)*PUEN(JL,JK-1)-ZDMFDE(JL)*PUD(JL,JK-1)
+ ZMFDVK=PMFD(JL,JK-1)*PVD(JL,JK-1)+ &
+ ZDMFEN(JL)*PVEN(JL,JK-1)-ZDMFDE(JL)*PVD(JL,JK-1)
+ PUD(JL,JK)=ZMFDUK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
+ PVD(JL,JK)=ZMFDVK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))
+ END IF
+ 160 CONTINUE
+ END IF
+ 180 CONTINUE
+ RETURN
+ END SUBROUTINE CUDDRAF
+!
+
+!**********************************************
+! SUBROUTINE CUFLX
+!**********************************************
+ SUBROUTINE CUFLX &
+ (KLON, KLEV, KLEVP1, PQEN, PQSEN, &
+ PTENH, PQENH, PAPH, PGEOH, KCBOT, &
+ KCTOP, KDTOP, KTYPE, LDDRAF, LDCUM, &
+ PMFU, PMFD, PMFUS, PMFDS, PMFUQ, &
+ PMFDQ, PMFUL, PLUDE, PDMFUP, PDMFDP, &
+ PRFL, PRAIN, PTEN, PSFL, PDPMEL, &
+ KTOPM2, ZTMST, sig1)
+! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
+!***PURPOSE
+! -------
+! THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE
+! FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUMASTR*.
+!***EXTERNALS
+! ---------
+! NONE
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER KTOPM2, ITOP, JL, JK, IKB
+ REAL ZTMST, ZCONS1, ZCONS2, ZCUCOV, ZTMELP2
+ REAL ZZP, ZFAC, ZSNMLT, ZRFL, CEVAPCU, ZRNEW
+ REAL ZRMIN, ZRFLN, ZDRFL, ZDPEVAP
+ REAL PQEN(KLON,KLEV), PQSEN(KLON,KLEV), &
+ PTENH(KLON,KLEV), PQENH(KLON,KLEV), &
+ PAPH(KLON,KLEVP1), PGEOH(KLON,KLEV)
+ REAL PMFU(KLON,KLEV), PMFD(KLON,KLEV), &
+ PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), &
+ PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), &
+ PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV), &
+ PMFUL(KLON,KLEV), PLUDE(KLON,KLEV), &
+ PRFL(KLON), PRAIN(KLON)
+ REAL PTEN(KLON,KLEV), PDPMEL(KLON,KLEV), &
+ PSFL(KLON), ZPSUBCL(KLON)
+ REAL sig1(KLEV)
+ INTEGER KCBOT(KLON), KCTOP(KLON), &
+ KDTOP(KLON), KTYPE(KLON)
+ LOGICAL LDDRAF(KLON), LDCUM(KLON)
+!* SPECIFY CONSTANTS
+ ZCONS1=CPD/(ALF*G*ZTMST)
+ ZCONS2=1./(G*ZTMST)
+ ZCUCOV=0.05
+ ZTMELP2=TMELT+2.
+!* 1.0 DETERMINE FINAL CONVECTIVE FLUXES
+!---------------------------------------------
+ 100 CONTINUE
+ ITOP=KLEV
+ DO 110 JL=1,KLON
+ PRFL(JL)=0.
+ PSFL(JL)=0.
+ PRAIN(JL)=0.
+! SWITCH OFF SHALLOW CONVECTION
+ IF(.NOT.LMFSCV.AND.KTYPE(JL).EQ.2)THEN
+ LDCUM(JL)=.FALSE.
+ LDDRAF(JL)=.FALSE.
+ ENDIF
+ ITOP=MIN(ITOP,KCTOP(JL))
+ IF(.NOT.LDCUM(JL).OR.KDTOP(JL).LT.KCTOP(JL)) LDDRAF(JL)=.FALSE.
+ IF(.NOT.LDCUM(JL)) KTYPE(JL)=0
+ 110 CONTINUE
+ KTOPM2=ITOP-2
+ DO 120 JK=KTOPM2,KLEV
+ DO 115 JL=1,KLON
+ IF(LDCUM(JL).AND.JK.GE.KCTOP(JL)-1) THEN
+ PMFUS(JL,JK)=PMFUS(JL,JK)-PMFU(JL,JK)* &
+ (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
+ PMFUQ(JL,JK)=PMFUQ(JL,JK)-PMFU(JL,JK)*PQENH(JL,JK)
+ IF(LDDRAF(JL).AND.JK.GE.KDTOP(JL)) THEN
+ PMFDS(JL,JK)=PMFDS(JL,JK)-PMFD(JL,JK)* &
+ (CPD*PTENH(JL,JK)+PGEOH(JL,JK))
+ PMFDQ(JL,JK)=PMFDQ(JL,JK)-PMFD(JL,JK)*PQENH(JL,JK)
+ ELSE
+ PMFD(JL,JK)=0.
+ PMFDS(JL,JK)=0.
+ PMFDQ(JL,JK)=0.
+ PDMFDP(JL,JK-1)=0.
+ END IF
+ ELSE
+ PMFU(JL,JK)=0.
+ PMFD(JL,JK)=0.
+ PMFUS(JL,JK)=0.
+ PMFDS(JL,JK)=0.
+ PMFUQ(JL,JK)=0.
+ PMFDQ(JL,JK)=0.
+ PMFUL(JL,JK)=0.
+ PDMFUP(JL,JK-1)=0.
+ PDMFDP(JL,JK-1)=0.
+ PLUDE(JL,JK-1)=0.
+ END IF
+ 115 CONTINUE
+ 120 CONTINUE
+ DO 130 JK=KTOPM2,KLEV
+ DO 125 JL=1,KLON
+ IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
+ IKB=KCBOT(JL)
+ ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/ &
+ (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
+ IF(KTYPE(JL).EQ.3) THEN
+ ZZP=ZZP**2
+ ENDIF
+ PMFU(JL,JK)=PMFU(JL,IKB)*ZZP
+ PMFUS(JL,JK)=PMFUS(JL,IKB)*ZZP
+ PMFUQ(JL,JK)=PMFUQ(JL,IKB)*ZZP
+ PMFUL(JL,JK)=PMFUL(JL,IKB)*ZZP
+ END IF
+!* 2. CALCULATE RAIN/SNOW FALL RATES
+!* CALCULATE MELTING OF SNOW
+!* CALCULATE EVAPORATION OF PRECIP
+!----------------------------------------------
+ IF(LDCUM(JL)) THEN
+ PRAIN(JL)=PRAIN(JL)+PDMFUP(JL,JK)
+ IF(PTEN(JL,JK).GT.TMELT) THEN
+ PRFL(JL)=PRFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
+ IF(PSFL(JL).GT.0..AND.PTEN(JL,JK).GT.ZTMELP2) THEN
+ ZFAC=ZCONS1*(PAPH(JL,JK+1)-PAPH(JL,JK))
+ ZSNMLT=MIN(PSFL(JL),ZFAC*(PTEN(JL,JK)-ZTMELP2))
+ PDPMEL(JL,JK)=ZSNMLT
+ PSFL(JL)=PSFL(JL)-ZSNMLT
+ PRFL(JL)=PRFL(JL)+ZSNMLT
+ END IF
+ ELSE
+ PSFL(JL)=PSFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK)
+ END IF
+ END IF
+ 125 CONTINUE
+ 130 CONTINUE
+ DO 230 JL=1,KLON
+ PRFL(JL)=MAX(PRFL(JL),0.)
+ PSFL(JL)=MAX(PSFL(JL),0.)
+ ZPSUBCL(JL)=PRFL(JL)+PSFL(JL)
+ 230 CONTINUE
+ DO 240 JK=KTOPM2,KLEV
+ DO 235 JL=1,KLON
+ IF(LDCUM(JL).AND.JK.GE.KCBOT(JL).AND. &
+ ZPSUBCL(JL).GT.1.E-20) THEN
+ ZRFL=ZPSUBCL(JL)
+ CEVAPCU=CEVAPCU1*SQRT(CEVAPCU2*SQRT(sig1(JK)))
+ ZRNEW=(MAX(0.,SQRT(ZRFL/ZCUCOV)- &
+ CEVAPCU*(PAPH(JL,JK+1)-PAPH(JL,JK))* &
+ MAX(0.,PQSEN(JL,JK)-PQEN(JL,JK))))**2*ZCUCOV
+ ZRMIN=ZRFL-ZCUCOV*MAX(0.,0.8*PQSEN(JL,JK)-PQEN(JL,JK)) &
+ *ZCONS2*(PAPH(JL,JK+1)-PAPH(JL,JK))
+ ZRNEW=MAX(ZRNEW,ZRMIN)
+ ZRFLN=MAX(ZRNEW,0.)
+ ZDRFL=MIN(0.,ZRFLN-ZRFL)
+ PDMFUP(JL,JK)=PDMFUP(JL,JK)+ZDRFL
+ ZPSUBCL(JL)=ZRFLN
+ END IF
+ 235 CONTINUE
+ 240 CONTINUE
+ DO 250 JL=1,KLON
+ ZDPEVAP=ZPSUBCL(JL)-(PRFL(JL)+PSFL(JL))
+ PRFL(JL)=PRFL(JL)+ZDPEVAP*PRFL(JL)* &
+ (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
+ PSFL(JL)=PSFL(JL)+ZDPEVAP*PSFL(JL)* &
+ (1./MAX(1.E-20,PRFL(JL)+PSFL(JL)))
+ 250 CONTINUE
+ RETURN
+ END SUBROUTINE CUFLX
+!
+
+!**********************************************
+! SUBROUTINE CUDTDQ
+!**********************************************
+ SUBROUTINE CUDTDQ &
+ (KLON, KLEV, KLEVP1, KTOPM2, PAPH, &
+ LDCUM, PTEN, PTTE, PQTE, PMFUS, &
+ PMFDS, PMFUQ, PMFDQ, PMFUL, PDMFUP, &
+ PDMFDP, ZTMST, PDPMEL, PRAIN, PRFL, &
+ PSFL, PSRAIN, PSEVAP, PSHEAT, PSMELT, &
+ PRSFC, PSSFC, PAPRC, PAPRSM, PAPRS, &
+ PQEN, PQSEN, PLUDE, PCTE)
+!**** *CUDTDQ* - UPDATES T AND Q TENDENCIES, PRECIPITATION RATES
+! DOES GLOBAL DIAGNOSTICS
+! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
+!***INTERFACE.
+! ----------
+! *CUDTDQ* IS CALLED FROM *CUMASTR*
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER KTOPM2,JL, JK
+ REAL ZTMST, PSRAIN, PSEVAP, PSHEAT, PSMELT, ZDIAGT, ZDIAGW
+ REAL ZALV, RHK, RHCOE, PLDFD, ZDTDT, ZDQDT
+ REAL PTTE(KLON,KLEV), PQTE(KLON,KLEV), &
+ PTEN(KLON,KLEV), PLUDE(KLON,KLEV), &
+ PGEO(KLON,KLEV), PAPH(KLON,KLEVP1), &
+ PAPRC(KLON), PAPRS(KLON), &
+ PAPRSM(KLON), PCTE(KLON,KLEV), &
+ PRSFC(KLON), PSSFC(KLON)
+ REAL PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), &
+ PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), &
+ PMFUL(KLON,KLEV), PQSEN(KLON,KLEV), &
+ PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV),&
+ PRFL(KLON), PRAIN(KLON), &
+ PQEN(KLON,KLEV)
+ REAL PDPMEL(KLON,KLEV), PSFL(KLON)
+ REAL ZSHEAT(KLON), ZMELT(KLON)
+ LOGICAL LDCUM(KLON)
+!--------------------------------
+!* 1.0 SPECIFY PARAMETERS
+!--------------------------------
+ 100 CONTINUE
+ ZDIAGT=ZTMST
+ ZDIAGW=ZDIAGT/RHOH2O
+!--------------------------------------------------
+!* 2.0 INCREMENTATION OF T AND Q TENDENCIES
+!--------------------------------------------------
+ 200 CONTINUE
+ DO 210 JL=1,KLON
+ ZMELT(JL)=0.
+ ZSHEAT(JL)=0.
+ 210 CONTINUE
+ DO 250 JK=KTOPM2,KLEV
+ IF(JK.LT.KLEV) THEN
+ DO 220 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ IF(PTEN(JL,JK).GT.TMELT) THEN
+ ZALV=ALV
+ ELSE
+ ZALV=ALS
+ ENDIF
+ RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
+ RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
+ pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
+ ZDTDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD* &
+ (PMFUS(JL,JK+1)-PMFUS(JL,JK)+ &
+ PMFDS(JL,JK+1)-PMFDS(JL,JK)-ALF*PDPMEL(JL,JK) &
+ -ZALV*(PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd- &
+ (PDMFUP(JL,JK)+PDMFDP(JL,JK))))
+ PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
+ ZDQDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*&
+ (PMFUQ(JL,JK+1)-PMFUQ(JL,JK)+ &
+ PMFDQ(JL,JK+1)-PMFDQ(JL,JK)+ &
+ PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd- &
+ (PDMFUP(JL,JK)+PDMFDP(JL,JK)))
+ PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
+ PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
+ ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
+ ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
+ END IF
+ 220 CONTINUE
+ ELSE
+ DO 230 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ IF(PTEN(JL,JK).GT.TMELT) THEN
+ ZALV=ALV
+ ELSE
+ ZALV=ALS
+ ENDIF
+ RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK))
+ RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC))
+ pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK))
+ ZDTDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD* &
+ (PMFUS(JL,JK)+PMFDS(JL,JK)+ALF*PDPMEL(JL,JK)-ZALV* &
+ (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)+pldfd))
+ PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT
+ ZDQDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+ (PMFUQ(JL,JK)+PMFDQ(JL,JK)+pldfd+ &
+ (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)))
+ PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT
+ PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd
+ ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK))
+ ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK)
+ END IF
+ 230 CONTINUE
+ END IF
+ 250 CONTINUE
+!---------------------------------------------------------
+! 3. UPDATE SURFACE FIELDS AND DO GLOBAL BUDGETS
+!---------------------------------------------------------
+ 300 CONTINUE
+ DO 310 JL=1,KLON
+ PRSFC(JL)=PRFL(JL)
+ PSSFC(JL)=PSFL(JL)
+ PAPRC(JL)=PAPRC(JL)+ZDIAGW*(PRFL(JL)+PSFL(JL))
+ PAPRS(JL)=PAPRSM(JL)+ZDIAGW*PSFL(JL)
+ PSHEAT=PSHEAT+ZSHEAT(JL)
+ PSRAIN=PSRAIN+PRAIN(JL)
+ PSEVAP=PSEVAP-(PRFL(JL)+PSFL(JL))
+ PSMELT=PSMELT+ZMELT(JL)
+ 310 CONTINUE
+ PSEVAP=PSEVAP+PSRAIN
+ RETURN
+ END SUBROUTINE CUDTDQ
+
+!
+!**********************************************
+! SUBROUTINE CUDUDV
+!**********************************************
+ SUBROUTINE CUDUDV &
+ (KLON, KLEV, KLEVP1, KTOPM2, KTYPE, &
+ KCBOT, PAPH, LDCUM, PUEN, PVEN, &
+ PVOM, PVOL, PUU, PUD, PVU, &
+ PVD, PMFU, PMFD, PSDISS)
+!**** *CUDUDV* - UPDATES U AND V TENDENCIES,
+! DOES GLOBAL DIAGNOSTIC OF DISSIPATION
+! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89
+!***INTERFACE.
+! ----------
+! *CUDUDV* IS CALLED FROM *CUMASTR*
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER KTOPM2, JK, IK, JL, IKB
+ REAL PSDISS,ZZP, ZDUDT ,ZDVDT, ZSUM
+ REAL PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PVOL(KLON,KLEV), PVOM(KLON,KLEV), &
+ PAPH(KLON,KLEVP1)
+ REAL PUU(KLON,KLEV), PUD(KLON,KLEV), &
+ PVU(KLON,KLEV), PVD(KLON,KLEV), &
+ PMFU(KLON,KLEV), PMFD(KLON,KLEV)
+ REAL ZMFUU(KLON,KLEV), ZMFDU(KLON,KLEV), &
+ ZMFUV(KLON,KLEV), ZMFDV(KLON,KLEV), &
+ ZDISS(KLON)
+ INTEGER KTYPE(KLON), KCBOT(KLON)
+ LOGICAL LDCUM(KLON)
+!------------------------------------------------------------
+!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES
+! -----------------------------------------------------------
+ 100 CONTINUE
+ DO 120 JK=KTOPM2,KLEV
+ IK=JK-1
+ DO 110 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ ZMFUU(JL,JK)=PMFU(JL,JK)*(PUU(JL,JK)-PUEN(JL,IK))
+ ZMFUV(JL,JK)=PMFU(JL,JK)*(PVU(JL,JK)-PVEN(JL,IK))
+ ZMFDU(JL,JK)=PMFD(JL,JK)*(PUD(JL,JK)-PUEN(JL,IK))
+ ZMFDV(JL,JK)=PMFD(JL,JK)*(PVD(JL,JK)-PVEN(JL,IK))
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ DO 140 JK=KTOPM2,KLEV
+ DO 130 JL=1,KLON
+ IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN
+ IKB=KCBOT(JL)
+ ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/ &
+ (PAPH(JL,KLEVP1)-PAPH(JL,IKB)))
+ IF(KTYPE(JL).EQ.3) THEN
+ ZZP=ZZP**2
+ ENDIF
+ ZMFUU(JL,JK)=ZMFUU(JL,IKB)*ZZP
+ ZMFUV(JL,JK)=ZMFUV(JL,IKB)*ZZP
+ ZMFDU(JL,JK)=ZMFDU(JL,IKB)*ZZP
+ ZMFDV(JL,JK)=ZMFDV(JL,IKB)*ZZP
+ END IF
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 150 JL=1,KLON
+ ZDISS(JL)=0.
+ 150 CONTINUE
+ DO 190 JK=KTOPM2,KLEV
+ IF(JK.LT.KLEV) THEN
+ DO 160 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ ZDUDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+ (ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+ &
+ ZMFDU(JL,JK+1)-ZMFDU(JL,JK))
+ ZDVDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+ (ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+ &
+ ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
+ ZDISS(JL)=ZDISS(JL)+ &
+ PUEN(JL,JK)*(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+ &
+ ZMFDU(JL,JK+1)-ZMFDU(JL,JK))+ &
+ PVEN(JL,JK)*(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+ &
+ ZMFDV(JL,JK+1)-ZMFDV(JL,JK))
+ PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
+ PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
+ END IF
+ 160 CONTINUE
+ ELSE
+ DO 170 JL=1,KLON
+ IF(LDCUM(JL)) THEN
+ ZDUDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+ (ZMFUU(JL,JK)+ZMFDU(JL,JK))
+ ZDVDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* &
+ (ZMFUV(JL,JK)+ZMFDV(JL,JK))
+ ZDISS(JL)=ZDISS(JL)- &
+ (PUEN(JL,JK)*(ZMFUU(JL,JK)+ZMFDU(JL,JK))+ &
+ PVEN(JL,JK)*(ZMFUV(JL,JK)+ZMFDV(JL,JK)))
+ PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT
+ PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT
+ END IF
+ 170 CONTINUE
+ END IF
+ 190 CONTINUE
+ ZSUM=SSUM(KLON,ZDISS(1),1)
+ PSDISS=PSDISS+ZSUM
+ RETURN
+ END SUBROUTINE CUDUDV
+!
+
+!#################################################################
+!
+! LEVEL 4 SUBROUTINES
+!
+!#################################################################
+!**************************************************************
+! SUBROUTINE CUBASMC
+!**************************************************************
+ SUBROUTINE CUBASMC &
+ (KLON, KLEV, KLEVM1, KK, PTEN, &
+ PQEN, PQSEN, PUEN, PVEN, PVERV, &
+ PGEO, PGEOH, LDCUM, KTYPE, KLAB, &
+ PMFU, PMFUB, PENTR, KCBOT, PTU, &
+ PQU, PLU, PUU, PVU, PMFUS, &
+ PMFUQ, PMFUL, PDMFUP, PMFUU, PMFUV)
+! M.TIEDTKE E.C.M.W.F. 12/89
+!***PURPOSE.
+! --------
+! THIS ROUTINE CALCULATES CLOUD BASE VALUES
+! FOR MIDLEVEL CONVECTION
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUASC*.
+! INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
+! IT RETURNS CLOUDBASE VALUES FOR MIDLEVEL CONVECTION
+!***METHOD.
+! -------
+! S. TIEDTKE (1989)
+!***EXTERNALS
+! ---------
+! NONE
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER KLEVM1,KK, JL
+ REAL zzzmb
+ REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), &
+ PUEN(KLON,KLEV), PVEN(KLON,KLEV), &
+ PQSEN(KLON,KLEV), PVERV(KLON,KLEV), &
+ PGEO(KLON,KLEV), PGEOH(KLON,KLEV)
+ REAL PTU(KLON,KLEV), PQU(KLON,KLEV), &
+ PUU(KLON,KLEV), PVU(KLON,KLEV), &
+ PLU(KLON,KLEV), PMFU(KLON,KLEV), &
+ PMFUB(KLON), PENTR(KLON), &
+ PMFUS(KLON,KLEV), PMFUQ(KLON,KLEV), &
+ PMFUL(KLON,KLEV), PDMFUP(KLON,KLEV), &
+ PMFUU(KLON), PMFUV(KLON)
+ INTEGER KTYPE(KLON), KCBOT(KLON), &
+ KLAB(KLON,KLEV)
+ LOGICAL LDCUM(KLON)
+!--------------------------------------------------------
+!* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES
+! -------------------------------------------------------
+ 100 CONTINUE
+ DO 150 JL=1,KLON
+ IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND. &
+ PQEN(JL,KK).GT.0.90*PQSEN(JL,KK)) THEN
+ PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) &
+ *RCPD
+ PQU(JL,KK+1)=PQEN(JL,KK)
+ PLU(JL,KK+1)=0.
+ ZZZMB=MAX(CMFCMIN,-PVERV(JL,KK)/G)
+ ZZZMB=MIN(ZZZMB,CMFCMAX)
+ PMFUB(JL)=ZZZMB
+ PMFU(JL,KK+1)=PMFUB(JL)
+ PMFUS(JL,KK+1)=PMFUB(JL)*(CPD*PTU(JL,KK+1)+PGEOH(JL,KK+1))
+ PMFUQ(JL,KK+1)=PMFUB(JL)*PQU(JL,KK+1)
+ PMFUL(JL,KK+1)=0.
+ PDMFUP(JL,KK+1)=0.
+ KCBOT(JL)=KK
+ KLAB(JL,KK+1)=1
+ KTYPE(JL)=3
+ PENTR(JL)=ENTRMID
+ IF(LMFDUDV) THEN
+ PUU(JL,KK+1)=PUEN(JL,KK)
+ PVU(JL,KK+1)=PVEN(JL,KK)
+ PMFUU(JL)=PMFUB(JL)*PUU(JL,KK+1)
+ PMFUV(JL)=PMFUB(JL)*PVU(JL,KK+1)
+ END IF
+ END IF
+ 150 CONTINUE
+ RETURN
+ END SUBROUTINE CUBASMC
+
+!
+!**************************************************************
+! SUBROUTINE CUADJTQ
+!**************************************************************
+ SUBROUTINE CUADJTQ(KLON,KLEV,KK,PP,PT,PQ,LDFLAG,KCALL)
+! M.TIEDTKE E.C.M.W.F. 12/89
+! D.SALMOND CRAY(UK)) 12/8/91
+!***PURPOSE.
+! --------
+! TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM SUBROUTINES:
+! *CUBASE* (T AND Q AT CONDENSTION LEVEL)
+! *CUASC* (T AND Q AT CLOUD LEVELS)
+! *CUINI* (ENVIRONMENTAL T AND QS VALUES AT HALF LEVELS)
+! INPUT ARE UNADJUSTED T AND Q VALUES,
+! IT RETURNS ADJUSTED VALUES OF T AND Q
+! NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS
+! KCALL=0 ENV. T AND QS IN*CUINI*
+! KCALL=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC)
+! KCALL=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF
+!***EXTERNALS
+! ---------
+! 3 LOOKUP TABLES ( TLUCUA, TLUCUB, TLUCUC )
+! FOR CONDENSATION CALCULATIONS.
+! THE TABLES ARE INITIALISED IN *SETPHYS*.
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV
+ INTEGER KK, KCALL, ISUM, JL
+ REAL ZQSAT, ZCOR, ZCOND1, TT
+ REAL PT(KLON,KLEV), PQ(KLON,KLEV), &
+ ZCOND(KLON), ZQP(KLON), &
+ PP(KLON)
+ LOGICAL LDFLAG(KLON)
+!------------------------------------------------------------------
+! 2. CALCULATE CONDENSATION AND ADJUST T AND Q ACCORDINGLY
+!------------------------------------------------------------------
+ 200 CONTINUE
+ IF (KCALL.EQ.1 ) THEN
+ ISUM=0
+ DO 210 JL=1,KLON
+ ZCOND(JL)=0.
+ IF(LDFLAG(JL)) THEN
+ ZQP(JL)=1./PP(JL)
+ TT=PT(JL,KK)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ ZCOND(JL)=MAX(ZCOND(JL),0.)
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+ IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
+ END IF
+ 210 CONTINUE
+ IF(ISUM.EQ.0) GO TO 230
+ DO 220 JL=1,KLON
+ IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
+ TT=PT(JL,KK)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+ END IF
+ 220 CONTINUE
+ 230 CONTINUE
+ END IF
+ IF(KCALL.EQ.2) THEN
+ ISUM=0
+ DO 310 JL=1,KLON
+ ZCOND(JL)=0.
+ IF(LDFLAG(JL)) THEN
+ TT=PT(JL,KK)
+ ZQP(JL)=1./PP(JL)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ ZCOND(JL)=MIN(ZCOND(JL),0.)
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+ IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
+ END IF
+ 310 CONTINUE
+ IF(ISUM.EQ.0) GO TO 330
+ DO 320 JL=1,KLON
+ IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN
+ TT=PT(JL,KK)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+ END IF
+ 320 CONTINUE
+ 330 CONTINUE
+ END IF
+ IF(KCALL.EQ.0) THEN
+ ISUM=0
+ DO 410 JL=1,KLON
+ TT=PT(JL,KK)
+ ZQP(JL)=1./PP(JL)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+ IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1
+ 410 CONTINUE
+ IF(ISUM.EQ.0) GO TO 430
+ DO 420 JL=1,KLON
+ TT=PT(JL,KK)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+ 420 CONTINUE
+ 430 CONTINUE
+ END IF
+ IF(KCALL.EQ.4) THEN
+ DO 510 JL=1,KLON
+ TT=PT(JL,KK)
+ ZQP(JL)=1./PP(JL)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL)
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL)
+ 510 CONTINUE
+ DO 520 JL=1,KLON
+ TT=PT(JL,KK)
+ ZQSAT=TLUCUA(TT)*ZQP(JL)
+ ZQSAT=MIN(0.5,ZQSAT)
+ ZCOR=1./(1.-VTMPC1*ZQSAT)
+ ZQSAT=ZQSAT*ZCOR
+ ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT))
+ PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1
+ PQ(JL,KK)=PQ(JL,KK)-ZCOND1
+ 520 CONTINUE
+ END IF
+ RETURN
+ END SUBROUTINE CUADJTQ
+
+!
+!**********************************************************
+! SUBROUTINE CUENTR_NEW
+!**********************************************************
+ SUBROUTINE CUENTR_NEW &
+ (KLON, KLEV, KLEVP1, KK, PTENH, &
+ PAPH, PAP, PGEOH, KLWMIN, LDCUM, &
+ KTYPE, KCBOT, KCTOP0, ZPBASE, PMFU, &
+ PENTR, ZDMFEN, ZDMFDE, ZODETR, KHMIN)
+! M.TIEDTKE E.C.M.W.F. 12/89
+! Y.WANG IPRC 11/01
+!***PURPOSE.
+! --------
+! THIS ROUTINE CALCULATES ENTRAINMENT/DETRAINMENT RATES
+! FOR UPDRAFTS IN CUMULUS PARAMETERIZATION
+!***INTERFACE
+! ---------
+! THIS ROUTINE IS CALLED FROM *CUASC*.
+! INPUT ARE ENVIRONMENTAL VALUES T,Q ETC
+! AND UPDRAFT VALUES T,Q ETC
+! IT RETURNS ENTRAINMENT/DETRAINMENT RATES
+!***METHOD.
+! --------
+! S. TIEDTKE (1989), NORDENG(1996)
+!***EXTERNALS
+! ---------
+! NONE
+! ----------------------------------------------------------------
+!-------------------------------------------------------------------
+ IMPLICIT NONE
+!-------------------------------------------------------------------
+ INTEGER KLON, KLEV, KLEVP1
+ INTEGER KK, JL, IKLWMIN,IKB, IKT, IKH
+ REAL ZRRHO, ZDPRHO, ZPMID, ZENTR, ZZMZK, ZTMZK, ARG, ZORGDE
+ REAL PTENH(KLON,KLEV), &
+ PAP(KLON,KLEV), PAPH(KLON,KLEVP1), &
+ PMFU(KLON,KLEV), PGEOH(KLON,KLEV), &
+ PENTR(KLON), ZPBASE(KLON), &
+ ZDMFEN(KLON), ZDMFDE(KLON), &
+ ZODETR(KLON,KLEV)
+ INTEGER KLWMIN(KLON), KTYPE(KLON), &
+ KCBOT(KLON), KCTOP0(KLON), &
+ KHMIN(KLON)
+ LOGICAL LDCUM(KLON),LLO1,LLO2
+!---------------------------------------------------------
+!* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES
+!---------------------------------------------------------
+!* 1.1 SPECIFY ENTRAINMENT RATES FOR SHALLOW CLOUDS
+!----------------------------------------------------------
+!* 1.2 SPECIFY ENTRAINMENT RATES FOR DEEP CLOUDS
+!-------------------------------------------------------
+ DO jl = 1, klon
+ zpbase(jl) = paph(jl,kcbot(jl))
+ zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1)
+ zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg
+ zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl)))
+ zentr = pentr(jl)*pmfu(jl,kk+1)*zdprho*zrrho
+ llo1 = kk.LT.kcbot(jl).AND.ldcum(jl)
+ if(llo1) then
+ zdmfde(jl) = zentr
+ else
+ zdmfde(jl) = 0.0
+ endif
+ llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) &
+ .LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid)
+ if(llo2) then
+ zdmfen(jl) = zentr
+ else
+ zdmfen(jl) = 0.0
+ endif
+ iklwmin = MAX(klwmin(jl),kctop0(jl)+2)
+ llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) &
+ .GT.zpmid)
+ IF (llo2) zdmfen(jl) = zentr
+ llo2 = llo1.AND.ktype(jl).EQ.1
+! Turbulent entrainment
+ IF (llo2) zdmfen(jl) = zentr
+! Organized detrainment, detrainment starts at khmin
+ ikb = kcbot(jl)
+ zodetr(jl,kk) = 0.
+ IF (llo2.AND.kk.LE.khmin(jl).AND.kk.GE.kctop0(jl)) THEN
+ ikt = kctop0(jl)
+ ikh = khmin(jl)
+ IF (ikh.GT.ikt) THEN
+ zzmzk = -(pgeoh(jl,ikh)-pgeoh(jl,kk))*zrg
+ ztmzk = -(pgeoh(jl,ikh)-pgeoh(jl,ikt))*zrg
+ arg = 3.1415*(zzmzk/ztmzk)*0.5
+ zorgde = TAN(arg)*3.1415*0.5/ztmzk
+ zdprho = (paph(jl,kk+1)-paph(jl,kk))*(zrg*zrrho)
+ zodetr(jl,kk) = MIN(zorgde,1.E-3)*pmfu(jl,kk+1)*zdprho
+ END IF
+ END IF
+ ENDDO
+!
+ RETURN
+ END SUBROUTINE CUENTR_NEW
+!
+
+!**********************************************************
+! FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC
+!**********************************************************
+ REAL FUNCTION SSUM ( N, X, IX )
+!
+! COMPUTES SSUM = SUM OF [X(I)]
+! FOR N ELEMENTS OF X WITH SKIP INCREMENT IX FOR VECTOR X
+!
+ IMPLICIT NONE
+ REAL X(*)
+ REAL ZSUM
+ INTEGER N, IX, JX, JL
+!
+ JX = 1
+ ZSUM = 0.0
+ DO JL = 1, N
+ ZSUM = ZSUM + X(JX)
+ JX = JX + IX
+ enddo
+!
+ SSUM=ZSUM
+!
+ RETURN
+ END FUNCTION SSUM
+
+ REAL FUNCTION TLUCUA(TT)
+!
+! Set up lookup tables for cloud ascent calculations.
+!
+ IMPLICIT NONE
+ REAL ZCVM3,ZCVM4,TT !,TLUCUA
+!
+ IF(TT-TMELT.GT.0.) THEN
+ ZCVM3=C3LES
+ ZCVM4=C4LES
+ ELSE
+ ZCVM3=C3IES
+ ZCVM4=C4IES
+ END IF
+ TLUCUA=C2ES*EXP(ZCVM3*(TT-TMELT)*(1./(TT-ZCVM4)))
+!
+ RETURN
+ END FUNCTION TLUCUA
+!
+ REAL FUNCTION TLUCUB(TT)
+!
+! Set up lookup tables for cloud ascent calculations.
+!
+ IMPLICIT NONE
+ REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT !,TLUCUB
+!
+ Z5ALVCP=C5LES*ALV/CPD
+ Z5ALSCP=C5IES*ALS/CPD
+ IF(TT-TMELT.GT.0.) THEN
+ ZCVM4=C4LES
+ ZCVM5=Z5ALVCP
+ ELSE
+ ZCVM4=C4IES
+ ZCVM5=Z5ALSCP
+ END IF
+ TLUCUB=ZCVM5*(1./(TT-ZCVM4))**2
+!
+ RETURN
+ END FUNCTION TLUCUB
+!
+ REAL FUNCTION TLUCUC(TT)
+!
+! Set up lookup tables for cloud ascent calculations.
+!
+ IMPLICIT NONE
+ REAL ZALVDCP,ZALSDCP,TT,ZLDCP !,TLUCUC
+!
+ ZALVDCP=ALV/CPD
+ ZALSDCP=ALS/CPD
+ IF(TT-TMELT.GT.0.) THEN
+ ZLDCP=ZALVDCP
+ ELSE
+ ZLDCP=ZALSDCP
+ END IF
+ TLUCUC=ZLDCP
+!
+ RETURN
+ END FUNCTION TLUCUC
+!
+
+END MODULE module_cu_tiedtke
Modified: trunk/mpas/src/core_init_nhyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/Registry 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_init_nhyd_atmos/Registry 2012-02-10 21:00:58 UTC (rev 1498)
@@ -14,7 +14,7 @@
namelist integer dimensions config_months 12
namelist character data_sources config_geog_data_path /data3/mp/wrfhelp/WPS_GEOG/
namelist character data_sources config_met_prefix FILE
-namelist character data_sources config_sst_prefix FILE
+namelist character data_sources config_sfc_prefix FILE
namelist integer data_sources config_fg_interval 21600
namelist real vertical_grid config_ztop 24000.0
namelist integer vertical_grid config_nsmterrain 2
@@ -22,7 +22,6 @@
namelist logical preproc_stages config_static_interp true
namelist logical preproc_stages config_vertical_grid true
namelist logical preproc_stages config_met_interp true
-namelist logical preproc_stages config_physics_init false
namelist logical preproc_stages config_input_sst false
namelist logical preproc_stages config_frac_seaice false
namelist character io config_input_name grid.nc
@@ -144,8 +143,6 @@
var persistent real fzp ( nVertLevels ) 0 io fzp mesh - -
var persistent real zx ( nVertLevelsP1 nEdges ) 0 io zx mesh - -
var persistent real zz ( nVertLevelsP1 nCells ) 0 io zz mesh - -
-var persistent real zf ( nVertLevelsP1 TWO nEdges ) 0 io zf mesh - -
-var persistent real zf3 ( nVertLevelsP1 TWO nEdges ) 0 io zf3 mesh - -
var persistent real zb ( nVertLevelsP1 TWO nEdges ) 0 io zb mesh - -
var persistent real zb3 ( nVertLevelsP1 TWO nEdges ) 0 io zb3 mesh - -
Modified: trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F
===================================================================
--- trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -83,8 +83,7 @@
do while (associated(block_ptr))
call init_atm_test_case_gfs(domain % dminfo, block_ptr % mesh, block_ptr % fg, block_ptr % state % time_levs(1) % state, &
block_ptr % diag, config_test_case, block_ptr % parinfo)
- if(config_physics_init) &
- call physics_initialize_real(block_ptr % mesh, block_ptr % fg)
+ call physics_initialize_real(block_ptr % mesh, block_ptr % fg)
block_ptr => block_ptr % next
end do
@@ -93,7 +92,7 @@
write(0,*) ' real-data surface (SST) update test case '
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call init_atm_test_case_sst(domain, domain % dminfo, block_ptr % mesh, block_ptr % fg, block_ptr % state % time_levs(1) % state, &
+ call init_atm_test_case_sfc(domain, domain % dminfo, block_ptr % mesh, block_ptr % fg, block_ptr % state % time_levs(1) % state, &
block_ptr % diag, config_test_case, block_ptr % parinfo)
block_ptr => block_ptr % next
end do
@@ -154,7 +153,7 @@
real (kind=RKIND), dimension(:), pointer :: surface_pressure
real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
!.. initialization of moisture:
@@ -232,8 +231,6 @@
CellsOnEdge => grid % CellsOnEdge % array
deriv_two => grid % deriv_two % array
- zf => grid % zf % array
- zf3 => grid % zf3% array
zb => grid % zb % array
zb3 => grid % zb3% array
@@ -778,13 +775,6 @@
zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
- if (k /= 1) then
- zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)
- zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)
- zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)
- zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)
- end if
-
end do
end do
@@ -799,14 +789,16 @@
do k = 2, grid%nVertLevels
flux = (fzm(k)*diag % ru % array(k,iEdge)+fzp(k)*diag % ru % array(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
if (config_theta_adv_order ==3) then
diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
end if
end do
@@ -1487,8 +1479,6 @@
diag % rw % array = 0.
state % w % array = 0.
- grid % zf % array = 0.
- grid % zf3% array = 0.
grid % zb % array = 0.
grid % zb3% array = 0.
@@ -1554,7 +1544,7 @@
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_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zb, zb3
!This is temporary variable here. It just need when calculate tangential velocity v.
integer :: eoe, j
@@ -1621,8 +1611,6 @@
nCellsSolve = grid % nCellsSolve
zgrid => grid % zgrid % array
- zf => grid % zf % array
- zf3 => grid % zf3 % array
zb => grid % zb % array
zb3 => grid % zb3 % array
rdzw => grid % rdzw % array
@@ -2054,13 +2042,6 @@
zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
- if (k /= 1) then
- zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb(k,1,iEdge)
- zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb(k,2,iEdge)
- zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb3(k,1,iEdge)
- zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb3(k,2,iEdge)
- end if
-
end do
end if
@@ -2082,14 +2063,16 @@
if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
do k = 2, grid%nVertLevels
flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
if (config_theta_adv_order ==3) then
diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
end if
end do
@@ -2183,7 +2166,7 @@
real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt
real (kind=RKIND), dimension(:), pointer :: destField1d
real (kind=RKIND), dimension(:,:), pointer :: destField2d
- real (kind=RKIND), dimension(:,:,:), pointer :: zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3
real (kind=RKIND), dimension(:,:,:), pointer :: scalars
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
@@ -2276,8 +2259,6 @@
cellsOnCell => grid % cellsOnCell % array
deriv_two => grid % deriv_two % array
- zf => grid % zf % array
- zf3 => grid % zf3% array
zb => grid % zb % array
zb3 => grid % zb3% array
@@ -3182,7 +3163,7 @@
parinfo % cellsToSend, parinfo % cellsToRecv)
! dzmina = minval(hs(:)-hx(k-1,:))
- dzmina = minval(zw(k)+ah(k)*hs(:)-zw(k-1)-ah(k-1)*hx(k-1,:))
+ dzmina = minval(zw(k)+ah(k)*hs(1:grid%nCellsSolve)-zw(k-1)-ah(k-1)*hx(k-1,1:grid%nCellsSolve))
call mpas_dmpar_min_real(dminfo, dzmina, dzmina_global)
! write(0,*) ' k,i, dzmina, dzmin, zw(k)-zw(k-1) ', k,i, dzmina, dzmin, zw(k)-zw(k-1)
if (dzmina_global >= dzmin*(zw(k)-zw(k-1))) then
@@ -3289,13 +3270,6 @@
zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
- if (k /= 1) then
- zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb(k,1,iEdge)
- zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb(k,2,iEdge)
- zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb3(k,1,iEdge)
- zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb3(k,2,iEdge)
- end if
-
end do
end if
@@ -3883,7 +3857,7 @@
if (field % iproj == PROJ_PS) then
call map_set(PROJ_PS, proj, &
- dx = real(field % dx * 1000.0,RKIND), &
+ dx = real(field % dx,RKIND), &
truelat1 = real(field % truelat1,RKIND), &
stdlon = real(field % xlonc,RKIND), &
knowni = real(field % nx / 2.0,RKIND), &
@@ -4239,14 +4213,16 @@
if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
do k = 2, grid%nVertLevels
flux = (fzm(k)*diag % ru % array(k,iEdge)+fzp(k)*diag % ru % array(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
if (config_theta_adv_order ==3) then
diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
end if
end do
@@ -4286,7 +4262,7 @@
end subroutine init_atm_test_case_gfs
- subroutine init_atm_test_case_sst(domain, dminfo, grid, fg, state, diag, test_case, parinfo)
+ subroutine init_atm_test_case_sfc(domain, dminfo, grid, fg, state, diag, test_case, parinfo)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Real-data test case using SST data
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -4346,12 +4322,12 @@
curr_time = mpas_get_clock_time(fg_clock, MPAS_NOW)
do while (curr_time <= stop_time)
call mpas_get_time(curr_time, dateTimeString=timeString)
- write(0,*) 'Processing ',trim(config_met_prefix)//':'//timeString(1:13)
+ write(0,*) 'Processing ',trim(config_sfc_prefix)//':'//timeString(1:13)
! Open intermediate file
- call read_met_init(trim(config_met_prefix), .false., timeString(1:13), istatus)
+ call read_met_init(trim(config_sfc_prefix), .false., timeString(1:13), istatus)
if (istatus /= 0) then
- write(0,*) 'Error reading ',trim(config_met_prefix)//':'//timeString(1:13)
+ write(0,*) 'Error reading ',trim(config_sfc_prefix)//':'//timeString(1:13)
exit
end if
@@ -4359,6 +4335,11 @@
call read_next_met_field(field, istatus)
do while (istatus == 0)
+ !initialization of sea-surface temperature (SST) and sea-ice fraction (XICE) arrays,
+ !prior to reading the input data:
+ fg % sst % array (1:grid%nCells) = 0.0
+ fg % xice % array (1:grid%nCells) = 0.0
+
if (index(field % field, 'SKINTEMP') /= 0 .or. index(field % field, 'SST') /= 0) then
! Interpolation routines use real(kind=RKIND), so copy from default real array
@@ -4389,6 +4370,15 @@
lat1 = real(field % startlat,RKIND), &
lon1 = real(field % startlon,RKIND))
! nxmax = nint(360.0 / field % deltalon), &
+ else if (field % iproj == PROJ_PS) then
+ call map_set(PROJ_PS, proj, &
+ dx = real(field % dx,RKIND), &
+ truelat1 = real(field % truelat1,RKIND), &
+ stdlon = real(field % xlonc,RKIND), &
+ knowni = real(field % nx / 2.0,RKIND), &
+ knownj = real(field % ny / 2.0,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
end if
! Interpolate SST/SKINTEMP field to each MPAS grid cell
@@ -4413,10 +4403,8 @@
deallocate(slab_r8)
deallocate(field % slab)
- exit
- end if
- if (index(field % field, 'SEAICE') /= 0) then
+ else if (index(field % field, 'SEAICE') /= 0) then
! Interpolation routines use real(kind=RKIND), so copy from default real array
allocate(slab_r8(field % nx, field % ny))
@@ -4446,6 +4434,15 @@
lat1 = real(field % startlat,RKIND), &
lon1 = real(field % startlon,RKIND))
! nxmax = nint(360.0 / field % deltalon), &
+ else if (field % iproj == PROJ_PS) then
+ call map_set(PROJ_PS, proj, &
+ dx = real(field % dx,RKIND), &
+ truelat1 = real(field % truelat1,RKIND), &
+ stdlon = real(field % xlonc,RKIND), &
+ knowni = real(field % nx / 2.0,RKIND), &
+ knownj = real(field % ny / 2.0,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
end if
! Interpolate SEAICE/SKINTEMP field to each MPAS grid cell
@@ -4466,15 +4463,18 @@
call latlon_to_ij(proj, lat, lon, x, y)
end if
fg % xice % array(iCell) = interp_sequence(x, y, 1, slab_r8, 1, field % nx, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1)
+ if (fg % xice % array(iCell) == -1.e30_RKIND) fg % xice % array(iCell) = 0.0_RKIND
end do
deallocate(slab_r8)
deallocate(field % slab)
- exit
+
+ else
+
+ deallocate(field % slab)
end if
- deallocate(field % slab)
call read_next_met_field(field, istatus)
end do
@@ -4495,63 +4495,9 @@
call mpas_output_state_finalize(sfc_update_obj, dminfo)
- end subroutine init_atm_test_case_sst
+ end subroutine init_atm_test_case_sfc
-#if 0
- real function four_pt(nx, ny, array, xx, yy)
- implicit none
-
- integer, intent(in) :: nx, ny
- real (kind=4), dimension(nx, ny), intent(in) :: array
- real (kind=4), intent(in) :: xx, yy
-
- integer :: min_x, max_x, min_y, max_y
-
- min_x = floor(xx)
- min_y = floor(yy)
- max_x = ceiling(xx)
- max_y = ceiling(yy)
-
- if (min_x == 0) min_x = max_x
- if (max_x == nx+1) max_x = min_x
- if (min_y == 0) min_y = max_y
- if (max_y == ny+1) max_y = min_y
-
- if ((min_x < 1) .or. (max_x > nx) .or. (min_y < 1) .or. (max_y > ny)) then
- write(0,*) '(x,y) location out of bounds'
- four_pt = 0.0
- return
- end if
-
- if (min_x == max_x) then
- if (min_y == max_y) then
- four_pt = array(min_x,min_y)
- else
- four_pt = array(min_x,min_y)*(real(max_y)-yy) + &
- array(min_x,max_y)*(yy-real(min_y))
- end if
- else if (min_y == max_y) then
- if (min_x == max_x) then
- four_pt = array(min_x,min_y)
- else
- four_pt = array(min_x,min_y)*(real(max_x)-xx) + &
- array(max_x,min_y)*(xx-real(min_x))
- end if
- else
- four_pt = (yy - min_y) * (array(min_x,max_y)*(real(max_x)-xx) + &
- array(max_x,max_y)*(xx-real(min_x))) + &
- (max_y - yy) * (array(min_x,min_y)*(real(max_x)-xx) + &
- array(max_x,min_y)*(xx-real(min_x)));
- end if
-
- return
-
- end function four_pt
-#endif
-
-!----------------------------------------------------------------------------------------------------------
-
integer function nearest_cell(target_lat, target_lon, &
start_cell, &
nCells, maxEdges, nEdgesOnCell, cellsOnCell, latCell, lonCell)
Modified: trunk/mpas/src/core_nhyd_atmos/Registry
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/Registry 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_nhyd_atmos/Registry 2012-02-10 21:00:58 UTC (rev 1498)
@@ -30,7 +30,6 @@
namelist logical nhyd_model config_monotonic true
namelist logical nhyd_model config_mix_full true
namelist real nhyd_model config_len_disp 0.
-namelist integer nhyd_model config_mp_physics 0.
namelist real nhyd_model config_epssm 0.1
namelist real nhyd_model config_smdiv 0.1
namelist logical nhyd_model config_newpx false
@@ -146,10 +145,10 @@
var persistent real fzp ( nVertLevels ) 0 iro fzp mesh - -
var persistent real zx ( nVertLevelsP1 nEdges ) 0 iro zx mesh - -
var persistent real zz ( nVertLevelsP1 nCells ) 0 iro zz mesh - -
-var persistent real zf ( nVertLevelsP1 TWO nEdges ) 0 iro zf mesh - -
-var persistent real zf3 ( nVertLevelsP1 TWO nEdges ) 0 iro zf3 mesh - -
var persistent real zb ( nVertLevelsP1 TWO nEdges ) 0 iro zb mesh - -
var persistent real zb3 ( nVertLevelsP1 TWO nEdges ) 0 iro zb3 mesh - -
+var persistent real pzm ( nVertLevels nCells ) 0 r pzm mesh - -
+var persistent real pzp ( nVertLevels nCells ) 0 r pzp mesh - -
% coefficients for the vertical tridiagonal solve
% Note: these could be local but...
@@ -411,38 +410,47 @@
%... PARAMETERIZATION OF CONVECTION:
%--------------------------------------------------------------------------------------------------
-% cubot : lowest level of convection (-)
-% cutop : highest level of convection (-)
% cuprec : convective precipitation rate (mm/s)
% rainc : accumulated time-step convective precipitation (mm)
% raincv : time-step convective precipitation (mm)
% rthcuten : tendency of potential temperature due to cumulus convection (K s-1)
% rqvcuten : tendency of water vapor mixing ratio due to cumulus convection (kg/kg s-1)
% rqccuten : tendency of cloud water mixing ratio due to cumulus convection (kg/kg s-1)
-% rqrcuten : tendency of rain mixing ratio due to cumulus convection (kg/kg s-1)
% rqicuten : tendency of cloud ice mixing ratio due to cumulus convection (kg/kg s-1)
-% rqscuten : tendency of snow mixing ratio due to cumulus convection (kg/kg s-1)
-var persistent real cubot ( nCells Time ) 1 ro cubot diag_physics - -
-var persistent real cutop ( nCells Time ) 1 ro cutop diag_physics - -
-var persistent real cuprec ( nCells Time ) 1 ro cuprec diag_physics - -
-var persistent real rainc ( nCells Time ) 1 ro rainc diag_physics - -
-var persistent real raincv ( nCells Time ) 1 ro raincv diag_physics - -
+var persistent real cuprec ( nCells Time ) 1 ro cuprec diag_physics - -
+var persistent real rainc ( nCells Time ) 1 ro rainc diag_physics - -
+var persistent real raincv ( nCells Time ) 1 ro raincv diag_physics - -
-var persistent real rthcuten ( nVertLevels nCells Time ) 1 ro rthcuten tend_physics - -
-var persistent real rqvcuten ( nVertLevels nCells Time ) 1 ro rqvcuten tend_physics - -
-var persistent real rqccuten ( nVertLevels nCells Time ) 1 ro rqccuten tend_physics - -
-var persistent real rqrcuten ( nVertLevels nCells Time ) 1 ro rqrcuten tend_physics - -
-var persistent real rqicuten ( nVertLevels nCells Time ) 1 ro rqicuten tend_physics - -
-var persistent real rqscuten ( nVertLevels nCells Time ) 1 ro rqscuten tend_physics - -
+var persistent real rthcuten ( nVertLevels nCells Time ) 1 ro rthcuten tend_physics - -
+var persistent real rqvcuten ( nVertLevels nCells Time ) 1 ro rqvcuten tend_physics - -
+var persistent real rqccuten ( nVertLevels nCells Time ) 1 ro rqccuten tend_physics - -
+var persistent real rqicuten ( nVertLevels nCells Time ) 1 ro rqicuten tend_physics - -
-%... KAIN_FRITSCH ONLY:
+%... KAIN_FRITSCH:
+% cubot : lowest level of convection (-)
+% cutop : highest level of convection (-)
% nca : relaxation time for KF parameterization of convection (s)
% wavg0 : average vertical velocity (KF scheme only) (m s-1)
+% rqrcuten : tendency of rain mixing ratio due to cumulus convection (kg/kg s-1)
+% rqscuten : tendency of snow mixing ratio due to cumulus convection (kg/kg s-1)
-var persistent real nca ( nCells Time ) 1 ro nca diag_physics - -
-var persistent real w0avg ( nVertLevels nCells Time ) 1 ro w0avg diag_physics - -
+var persistent real nca ( nCells Time ) 1 ro nca diag_physics - -
+var persistent real cubot ( nCells Time ) 1 ro cubot diag_physics - -
+var persistent real cutop ( nCells Time ) 1 ro cutop diag_physics - -
+var persistent real w0avg ( nVertLevels nCells Time ) 1 ro w0avg diag_physics - -
+var persistent real rqrcuten ( nVertLevels nCells Time ) 1 ro rqrcuten tend_physics - -
+var persistent real rqscuten ( nVertLevels nCells Time ) 1 ro rqscuten tend_physics - -
+%... TIEDTKE:
+% rucuten : tendency of zonal wind due to cumulus convection (m/s-1)
+% rvcuten : tendency of meridional wind due to cumulus convection (m/s-1)
+% rqvdynten : tendency of water vapor due to horizontal and vertical advections (kg/kg/s-1)
+
+var persistent real rqvdynten ( nVertLevels nCells Time ) 1 ro rqvdynten tend_physics - -
+var persistent real rucuten ( nVertLevels nCells Time ) 1 ro rucuten tend_physics - -
+var persistent real rvcuten ( nVertLevels nCells Time ) 1 ro rvcuten tend_physics - -
+
%--------------------------------------------------------------------------------------------------
%... PARAMETERIZATION OF PLANETARY BOUNDARY LAYER PROCESSES:
%--------------------------------------------------------------------------------------------------
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -334,6 +334,12 @@
if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
call mpas_reset_clock_alarm(clock, restartAlarmID, ierr=ierr)
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call atm_compute_restart_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % diag, block_ptr % mesh)
+ block_ptr => block_ptr % next
+ end do
+
! Write one restart time per file
call mpas_output_state_init(restart_obj, domain, "RESTART", trim(timeStamp))
call mpas_output_state_for_domain(restart_obj, domain, 1)
@@ -389,7 +395,7 @@
subroutine atm_compute_output_diagnostics(state, diag, grid)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields for a domain
+ ! Compute diagnostic fields for a domain to be written to history files
!
! Input: state - contains model prognostic fields
! grid - contains grid metadata
@@ -418,6 +424,37 @@
end subroutine atm_compute_output_diagnostics
+ subroutine atm_compute_restart_diagnostics(state, diag, grid)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute diagnostic fields for a domain to be written to restart files
+ !
+ ! Input: state - contains model prognostic fields
+ ! grid - contains grid metadata
+ !
+ ! Output: state - upon returning, diagnostic fields will have be computed
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mpas_grid_types
+
+ implicit none
+
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+ type (mesh_type), intent(in) :: grid
+
+ integer :: i, eoe
+ integer :: iCell, k
+
+ do iCell=1,grid%nCells
+ do k=1,grid%nVertLevels
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * state % scalars % array(state % index_qv,k,iCell))
+ diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * grid % zz % array(k,iCell)
+ end do
+ end do
+
+ end subroutine atm_compute_restart_diagnostics
+
+
subroutine atm_do_timestep(domain, dt, itimestep)
use mpas_grid_types
@@ -560,12 +597,14 @@
type (mesh_type), intent(inout) :: mesh
- integer :: iEdge, iCell1, iCell2, k
+ integer :: iEdge, iCell1, iCell2, k, iCell, nz, nz1
real (kind=RKIND) :: d1, d2, d3
- real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, zgrid
+ real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, zgrid, pzp, pzm
cpr => mesh % cpr % array
cpl => mesh % cpl % array
+ pzp => mesh % pzp % array
+ pzm => mesh % pzm % array
zgrid => mesh % zgrid % array
!**** coefficient arrays for new pressure gradient calculation
@@ -575,28 +614,70 @@
if (config_newpx) then
do iEdge=1,mesh%nEdges
+
iCell1 = mesh % cellsOnEdge % array(1,iEdge)
iCell2 = mesh % cellsOnEdge % array(2,iEdge)
d1 = .25*(zgrid(1,iCell2)+zgrid(2,iCell2)-zgrid(1,iCell1)-zgrid(2,iCell1))
d2 = d1+.5*(zgrid(3,iCell2)-zgrid(1,iCell2))
d3 = d2+.5*(zgrid(4,iCell2)-zgrid(2,iCell2))
- cpr(1,iEdge) = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cpr(2,iEdge) = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cpr(3,iEdge) = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cpr(1,iEdge) = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cpr(2,iEdge) = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cpr(3,iEdge) = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+ cpr(1,iEdge) = d2/(d2-d1)
+ cpr(2,iEdge) = -d1/(d2-d1)
+ cpr(3,iEdge) = 0.
+
d1 = .25*(zgrid(1,iCell1)+zgrid(2,iCell1)-zgrid(1,iCell2)-zgrid(2,iCell2))
d2 = d1+.5*(zgrid(3,iCell1)-zgrid(1,iCell1))
d3 = d2+.5*(zgrid(4,iCell1)-zgrid(2,iCell1))
- cpl(1,iEdge) = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cpl(2,iEdge) = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
- cpl(3,iEdge) = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cpl(1,iEdge) = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cpl(2,iEdge) = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+! cpl(3,iEdge) = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1))
+ cpl(1,iEdge) = d2/(d2-d1)
+ cpl(2,iEdge) = -d1/(d2-d1)
+ cpl(3,iEdge) = 0.
+
end do
+
! write(6,*) 'cpr1 = ',cpr(1,1),' cpl1 = ',cpl(1,1)
! write(6,*) 'cpr2 = ',cpr(2,1),' cpl2 = ',cpl(2,1)
! write(6,*) 'cpr3 = ',cpr(3,1),' cpl3 = ',cpl(3,1)
+ else
+
+! Coefficients for computing vertical pressure gradient dp/dz
+! dp/dz (k,iCell) = pzp(k,iCell) * (p(k+1,iCell) - p(k,iCell)) +pzm(k,iCell) * (p(k,iCell) - p(k-1,iCell))
+
+ nz1 = mesh % nVertLevels
+ nz = nz1 + 1
+
+ do iCell=1, mesh % nCells
+
+ d1 = zgrid(3,iCell)-zgrid(1,iCell)
+ d2 = zgrid(4,iCell)-zgrid(2,iCell)
+ d3 = d1+d2
+ pzm(1,iCell) = 2.*d3/(d1*d2)
+ pzp(1,iCell) = -2.*d1/(d2*d3)
+
+ do k=2,nz1-1
+ pzp(k,iCell) = 2.*(zgrid(k+1,iCell)-zgrid(k-1,iCell))/ &
+ & ((zgrid(k+2,iCell)-zgrid(k ,iCell))* &
+ & (zgrid(k+2,iCell)-zgrid(k ,iCell) &
+ & +zgrid(k+1,iCell)-zgrid(k-1,iCell)))
+ pzm(k,iCell) = 2.*(zgrid(k+2,iCell)-zgrid(k ,iCell))/ &
+ & ((zgrid(k+1,iCell)-zgrid(k-1,iCell))* &
+ & (zgrid(k+2,iCell)-zgrid(k ,iCell) &
+ & +zgrid(k+1,iCell)-zgrid(k-1,iCell)))
+ end do
+
+ pzp(nz1,iCell) = 0.
+ pzm(nz1,iCell) = 2./(zgrid(nz,iCell)-zgrid(nz1-1,iCell))
+
+ end do
+
end if
end subroutine atm_compute_pgf_coefs
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_test_cases.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_test_cases.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_test_cases.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -141,7 +141,7 @@
real (kind=RKIND), dimension(:), pointer :: surface_pressure
real (kind=RKIND), dimension(:,:), pointer :: zgrid, zx, zz, hx
real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt
- real (kind=RKIND), dimension(:,:,:), pointer :: zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
!.. initialization of moisture:
@@ -219,8 +219,6 @@
CellsOnEdge => grid % CellsOnEdge % array
deriv_two => grid % deriv_two % array
- zf => grid % zf % array
- zf3 => grid % zf3% array
zb => grid % zb % array
zb3 => grid % zb3% array
@@ -765,13 +763,6 @@
zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
- if (k /= 1) then
- zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)
- zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)
- zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)
- zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)
- end if
-
end do
end do
@@ -786,14 +777,16 @@
do k = 2, grid%nVertLevels
flux = (fzm(k)*diag % ru % array(k,iEdge)+fzp(k)*diag % ru % array(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
if (config_theta_adv_order ==3) then
diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ - sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ + sign(1.0_RKIND,diag % ru % array(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
end if
end do
@@ -1474,8 +1467,6 @@
diag % rw % array = 0.
state % w % array = 0.
- grid % zf % array = 0.
- grid % zf3% array = 0.
grid % zb % array = 0.
grid % zb3% array = 0.
@@ -1541,7 +1532,7 @@
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_zz, rb, rr, tb, rtb, p, pp, dss, t, rt, u, ru
- real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zf, zf3, zb, zb3
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zb, zb3
!This is temporary variable here. It just need when calculate tangential velocity v.
integer :: eoe, j
@@ -1608,8 +1599,6 @@
nCellsSolve = grid % nCellsSolve
zgrid => grid % zgrid % array
- zf => grid % zf % array
- zf3 => grid % zf3 % array
zb => grid % zb % array
zb3 => grid % zb3 % array
rdzw => grid % rdzw % array
@@ -2041,13 +2030,6 @@
zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
- if (k /= 1) then
- zf(k,1,iEdge) = ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb(k,1,iEdge)
- zf(k,2,iEdge) = ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb(k,2,iEdge)
- zf3(k,1,iEdge)= ( fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1) )*zb3(k,1,iEdge)
- zf3(k,2,iEdge)= ( fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2) )*zb3(k,2,iEdge)
- end if
-
end do
end if
@@ -2069,14 +2051,16 @@
if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
do k = 2, grid%nVertLevels
flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + zf(k,2,iEdge)*flux
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - zf(k,1,iEdge)*flux
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb(k,2,iEdge)*flux
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb(k,1,iEdge)*flux
if (config_theta_adv_order ==3) then
diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
- - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,2,iEdge)*flux
+ - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell2)+fzp(k)*zz(k-1,cell2))*zb3(k,2,iEdge)*flux
diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
- + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order*zf3(k,1,iEdge)*flux
+ + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* &
+ (fzm(k)*zz(k,cell1)+fzp(k)*zz(k-1,cell1))*zb3(k,1,iEdge)*flux
end if
end do
Modified: trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F
===================================================================
--- trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F 2012-02-10 20:32:23 UTC (rev 1497)
+++ trunk/mpas/src/core_nhyd_atmos/mpas_atm_time_integration.F 2012-02-10 21:00:58 UTC (rev 1498)
@@ -674,14 +674,16 @@
type (tend_type) :: tend
type (diag_type) :: diag
type (mesh_type) :: grid
- integer :: iCell, iEdge, k, cell1, cell2
+ !SHP-w
+ integer :: iCell, iEdge, k, cell1, cell2, coef_3rd_order
integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND), dimension(:,:,:), pointer :: zf, zf3
real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, areaCell
real (kind=RKIND) :: flux
+ !SHP-w
+ coef_3rd_order = config_coef_3rd_order
+ if(config_theta_adv_order /=3) coef_3rd_order = 0
- zf => grid % zf % array
- zf3 => grid % zf3 % array
+ !SHP-w
fzm => grid % fzm % array
fzp => grid % fzp % array
dvEdge => grid % dvEdge % array
@@ -708,18 +710,15 @@
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+ !SHP-w
do k = 2, grid%nVertLevels
flux = fzm(k) * tend % u % array(k,iEdge) + fzp(k) * tend % u % array(k-1,iEdge)
- tend % w % array(k,cell2) = tend % w % array(k,cell2) + zf(k,2,iEdge)*flux
- tend % w % array(k,cell1) = tend % w % array(k,cell1) - zf(k,1,iEdge)*flux
-!3rd order stencil
- if (config_theta_adv_order == 3) then
- tend % w % array(k,cell2) = tend % w % array(k,cell2) + sign(1.0_RKIND,tend % u % array(k,iEdge)) &
- *config_coef_3rd_order*zf3(k,2,iEdge)*flux
- tend % w % array(k,cell1) = tend % w % array(k,cell1) - sign(1.0_RKIND,tend % u % array(k,iEdge)) &
- *config_coef_3rd_order*zf3(k,1,iEdge)*flux
- end if
-
+ tend % w % array(k,cell2) = tend % w % array(k,cell2) &
+ + (grid % zb % array(k,2,iEdge) + coef_3rd_order*sign(1.0_RKIND,tend % u % array(k,iEdge))*grid %zb3 % array(k,2,iEdge))*flux &
+ * (fzm(k) * grid % zz % array(k,cell2) + fzp(k) * grid % zz % array(k-1,cell2))
+ tend % w % array(k,cell1) = tend % w % array(k,cell1) &
+ - (grid % zb % array(k,1,iEdge) + coef_3rd_order*sign(1.0_RKIND,tend % u % array(k,iEdge))*grid %zb3 % array(k,1,iEdge))*flux &
+ * (fzm(k) * grid % zz % array(k,cell1) + fzp(k) * grid % zz % array(k-1,cell1))
end do
end do
@@ -749,7 +748,7 @@
zgrid, cofwr, cofwz, w, h_divergence
real (kind=RKIND), dimension(:), pointer :: fzm, fzp, rdzw, dcEdge, AreaCell, cofrz, dvEdge
- real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl
+ real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, pzp, pzm
real (kind=RKIND) :: smdiv, c2, rcv
real (kind=RKIND), dimension( grid % nVertLevels ) :: du
@@ -797,6 +796,9 @@
gamma_tri => diag % gamma_tri % array
dss => grid % dss % array
+ pzp => grid % pzp % array
+ pzm => grid % pzm % array
+
tend_ru => tend % u % array
tend_rho => tend % rho_zz % array
tend_rt => tend % theta_m % array
@@ -883,23 +885,54 @@
else
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)))
+! 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)))
+
+ dpzx(k) = .25*(zx(k,iEdge)+zx(k+1,iEdge)) &
+ *(pzm(k,cell2)*(zz(k+1,cell2)*rtheta_pp_old(k+1,cell2) &
+ -zz(k ,cell2)*rtheta_pp_old(k ,cell2)) &
+ +pzm(k,cell1)*(zz(k+1,cell1)*rtheta_pp_old(k+1,cell1) &
+ -zz(k ,cell1)*rtheta_pp_old(k ,cell1)) &
+ +pzp(k,cell2)*(zz(k+2,cell2)*rtheta_pp_old(k+2,cell2) &
+ -zz(k ,cell2)*rtheta_pp_old(k ,cell2)) &
+ +pzp(k,cell1)*(zz(k+2,cell1)*rtheta_pp_old(k+2,cell1) &
+ -zz(k ,cell1)*rtheta_pp_old(k ,cell1)))
+
+ do k=2,grid % nVertLevels-1
+! 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)))
+ dpzx(k) = .25*(zx(k,iEdge)+zx(k+1,iEdge)) &
+ *(pzp(k,cell2)*(zz(k+1,cell2)*rtheta_pp_old(k+1,cell2) &
+ -zz(k ,cell2)*rtheta_pp_old(k ,cell2)) &
+ +pzm(k,cell2)*(zz(k ,cell2)*rtheta_pp_old(k ,cell2) &
+ -zz(k-1,cell2)*rtheta_pp_old(k-1,cell2)) &
+ +pzp(k,cell1)*(zz(k+1,cell1)*rtheta_pp_old(k+1,cell1) &
+ -zz(k ,cell1)*rtheta_pp_old(k ,cell1)) &
+ +pzm(k,cell1)*(zz(k ,cell1)*rtheta_pp_old(k ,cell1) &
+ -zz(k-1,cell1)*rtheta_pp_old(k-1,cell1)))
end do
- dpzx(nVertLevels + 1) = 0.
+ k=grid % nVertLevels
+ dpzx(k) = .25*(zx(k,iEdge)+zx(k+1,iEdge)) &
+ *(pzm(k,cell2)*(zz(k ,cell2)*rtheta_pp_old(k ,cell2) &
+ -zz(k-1,cell2)*rtheta_pp_old(k-1,cell2)) &
+ +pzm(k,cell1)*(zz(k ,cell1)*rtheta_pp_old(k ,cell1) &
+ -zz(k-1,cell1)*rtheta_pp_old(k-1,cell1)))
+
+! 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 = (rtheta_pp_old(k,cell2)-rtheta_pp_old(k,cell1))/dcEdge(iEdge) &
+! - rdzw(k)*(dpzx(k+1)-dpzx(k))
+ pgrad = ((rtheta_pp_old(k,cell2)*zz(k,cell2) &
+ -rtheta_pp_old(k,cell1)*zz(k,cell1))/dcEdge(iEdge) &
+ -dpzx(k))/(.5*(zz(k,cell2)+zz(k,cell1)))
pgrad = 0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad
du(k) = dts*(tend_ru(k,iEdge) - cqu(k,iEdge) * pgrad)
! + (0.05/6.)*dcEdge(iEdge)*(h_divergence(k,cell2)-h_divergence(k,cell1))
@@ -987,11 +1020,11 @@
end do ! end of loop over cells
- end subroutine atm_advance_acoustic_step
+ end subroutine atm_advance_acoustic_step
!------------------------
- subroutine atm_recover_large_step_variables( s, diag, tend, grid, dt, ns, rk_step )
+ subroutine atm_recover_large_step_variables( s, diag, tend, grid, dt, ns, rk_step )
implicit none
type (state_type) :: s
@@ -1171,7 +1204,7 @@
enddo
- end subroutine atm_recover_large_step_variables
+ end subroutine atm_recover_large_step_variables
!---------------------------------------------------------------------------------------
@@ -1841,7 +1874,7 @@
real (kind=RKIND), dimension(:), pointer :: rdzu, rdzw, fzm, fzp, qv_init
real (kind=RKIND), dimension(:,:), pointer :: t_init
- real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl
+ real (kind=RKIND), dimension(:,:), pointer :: cpr, cpl, pzp, pzm
integer :: kr, kl
real (kind=RKIND), allocatable, dimension(:,:) :: rv, divergence_ru, qtot
@@ -1907,7 +1940,10 @@
pressure_b => diag % pressure_base % array
h_divergence => diag % h_divergence % array
+ pzp => grid % pzp % array
+ pzm => grid % pzm % array
+
weightsOnEdge => grid % weightsOnEdge % array
cellsOnEdge => grid % cellsOnEdge % array
verticesOnEdge => grid % verticesOnEdge % array
@@ -2046,16 +2082,69 @@
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.
+ if(newpx) then
+ k = 1
+ pr = cpr(k,iEdge)*pp(k,cell2)+cpr(k+1,iEdge)*pp(k+1,cell2)+cpr(k+2,iEdge)*pp(k+2,cell2)
+ pl = cpl(k,iEdge)*pp(k,cell1)+cpl(k+1,iEdge)*pp(k+1,cell1)+cpl(k+2,iEdge)*pp(k+2,cell1)
+ tend_u(k,iEdge) = - cqu(k,iEdge)*2./(zz(k,cell1)+zz(k,cell2))*(pr-pl)/dcEdge(iEdge)
+
+ do k=2,nVertLevels
+
+ kr = min(nVertLevels,k+ nint(.5-sign(0.5_RKIND,zx(k,iEdge)+zx(k+1,iEdge))))
+ kl = min(nVertLevels,2*k+1-kr)
+
+ pr = pp(k,cell2)+.5*(zgrid(k ,cell1)+zgrid(k +1,cell1)-zgrid(k ,cell2)-zgrid(k +1,cell2)) &
+ /(zgrid(kr+1,cell2)-zgrid(kr-1,cell2))*( pp(kr,cell2)-pp (kr-1,cell2))
+ pl = pp(k,cell1)+.5*(zgrid(k ,cell2)+zgrid(k +1,cell2)-zgrid(k ,cell1)-zgrid(k +1,cell1)) &
+ /(zgrid(kl+1,cell1)-zgrid(kl-1,cell1))*( pp(kl,cell1)-pp (kl-1,cell1))
+ tend_u(k,iEdge) = - cqu(k,iEdge)*2./(zz(k,cell1)+zz(k,cell2))*(pr-pl)/dcEdge(iEdge)
+
+ end do
+
+ else
+ 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)))
+
+ dpzx(k) = .25*(zx(k,iEdge)+zx(k+1,iEdge)) &
+ *(pzm(k,cell2)*(pp(k+1,cell2)-pp(k,cell2)) &
+ +pzm(k,cell1)*(pp(k+1,cell1)-pp(k,cell1)) &
+ +pzp(k,cell2)*(pp(k+2,cell2)-pp(k,cell2)) &
+ +pzp(k,cell1)*(pp(k+2,cell1)-pp(k,cell1)))
+
+ do k = 2, nVertLevels-1
+
+!! dpzx(k) = .5*zx(k,iEdge)*(fzm(k)*(pp(k ,cell2)+pp(k ,cell1)) &
+!! +fzp(k)*(pp(k-1,cell2)+pp(k-1,cell1)))
+
+ dpzx(k) = .25*(zx(k,iEdge)+zx(k+1,iEdge)) &
+ *(pzp(k,cell2)*(pp(k+1,cell2)-pp(k ,cell2)) &
+ +pzm(k,cell2)*(pp(k ,cell2)-pp(k-1,cell2)) &
+ +pzp(k,cell1)*(pp(k+1,cell1)-pp(k ,cell1)) &
+ +pzm(k,cell1)*(pp(k ,cell1)-pp(k-1,cell1)))
+
+ end do
+
+ k = nVertLevels
+ dpzx(k) = .25*(zx(k,iEdge)+zx(k+1,iEdge)) &
+ *(pzm(k,cell2)*(pp(k ,cell2)-pp(k-1,cell2)) &
+ +pzm(k,cell1)*(pp(k ,cell1)-pp(k-1,cell1)))
+
+!! dpzx(nVertLevels+1) = 0.
+
+ do k=1,nVertLevels
+
+!! tend_u(k,iEdge) = - cqu(k,iEdge)*( (pp(k,cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) &
+!! / dcEdge(iEdge) - rdzw(k)*(dpzx(k+1)-dpzx(k)) )
+
+ tend_u(k,iEdge) = - cqu(k,iEdge)*((pp(k,cell2)-pp(k,cell1))/dcEdge(iEdge) &
+ - dpzx(k) ) / (.5*(zz(k,cell2)+zz(k,cell1)))
+ end do
+
+ end if
+
wduz(1) = 0.
k = 2
wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2) )*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge))
@@ -2068,8 +2157,8 @@
wduz(nVertLevels+1) = 0.
do k=1,nVertLevels
- tend_u(k,iEdge) = - cqu(k,iEdge)*( (pp(k,cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) &
- / dcEdge(iEdge) - rdzw(k)*(dpzx(k+1)-dpzx(k)) )
+! tend_u(k,iEdge) = - cqu(k,iEdge)*( (pp(k,cell2)/zz(k,cell2) - pp(k,cell1)/zz(k,cell1)) &
+! / dcEdge(iEdge) - rdzw(k)*(dpzx(k+1)-dpzx(k)) )
tend_u(k,iEdge) = tend_u(k,iEdge) - rdzw(k)*(wduz(k+1)-wduz(k))
end do
@@ -2592,7 +2681,7 @@
do k=2,nVertLevels
tend_w(k,iCell) = tend_w(k,iCell)/areaCell(iCell) -rdzu(k)*(wdwz(k+1)-wdwz(k)) &
-!SHP-w
+!SHP-buoy
- cqw(k,iCell)*( rdzu(k)*(pp(k,iCell)-pp(k-1,iCell)) &
+ gravity* &
( fzm(k)*(rb(k,iCell)*(qtot(k,iCell)) + &
@@ -3254,9 +3343,14 @@
type (diag_type), intent(inout) :: diag
type (mesh_type), intent(inout) :: grid
- integer :: k,iCell,iEdge,i,iCell1,iCell2, cell1, cell2
+ !SHP-w
+ integer :: k,iCell,iEdge,i,iCell1,iCell2, cell1, cell2, coef_3rd_order
real (kind=RKIND) :: p0, rcv, flux
+ !SHP-w
+ coef_3rd_order = config_coef_3rd_order
+ if(config_theta_adv_order /=3) coef_3rd_order = 0
+
rcv = rgas / (cp-rgas)
p0 = 1.e5 ! this should come from somewhere else...
@@ -3300,27 +3394,22 @@
* (grid % fzp % array(k) * grid % zz % array(k-1,iCell) + grid % fzm % array(k) * grid % zz % array(k,iCell))
end do
end do
+
+ !SHP-w
! next, the piece that depends on ru
do iEdge=1,grid%nEdges
cell1 = grid % CellsOnEdge % array(1,iEdge)
cell2 = grid % CellsOnEdge % array(2,iEdge)
do k = 2, grid % nVertLevels
flux = (grid % fzm % array(k) * diag % ru % array(k,iEdge)+grid % fzp % array(k) * diag % ru % array(k-1,iEdge))
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + grid % zb % array(k,2,iEdge)*flux &
+ diag % rw % array(k,cell2) = diag % rw % array(k,cell2) &
+ + (grid % zb % array(k,2,iEdge) + coef_3rd_order * sign(1.0_RKIND,flux) * grid % zb3 % array(k,2,iEdge))*flux &
* (grid % fzp % array(k) * grid % zz % array(k-1,cell2) + grid % fzm % array(k) * grid % zz % array(k,cell2))
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - grid % zb % array(k,1,iEdge)*flux &
+ diag % rw % array(k,cell1) = diag % rw % array(k,cell1) &
+ - (grid % zb % array(k,1,iEdge) + coef_3rd_order * sign(1.0_RKIND,flux) * grid % zb3 % array(k,1,iEdge))*flux &
* (grid % fzp % array(k) * grid % zz % array(k-1,cell1) + grid % fzm % array(k) * grid % zz % array(k,cell1))
-!3rd order! stencil
- if (config_theta_adv_order ==3) then
- diag % rw % array(k,cell2) = diag % rw % array(k,cell2) + sign(1.0_RKIND,flux)*config_coef_3rd_order &
- * grid % zb3 % array(k,2,iEdge)*flux &
- * (grid % fzp % array(k) * grid % zz % array(k-1,cell2) + grid % fzm % array(k) * grid % zz % array(k,cell2))
- diag % rw % array(k,cell1) = diag % rw % array(k,cell1) - sign(1.0_RKIND,flux)*config_coef_3rd_order &
- * grid % zb3 % array(k,1,iEdge)*flux &
- * (grid % fzp % array(k) * grid % zz % array(k-1,cell1) + grid % fzm % array(k) * grid % zz % array(k,cell1))
- end if
- enddo
- enddo
+ end do
+ end do
! end WCS bug fix
</font>
</pre>