<p><b>mpetersen@lanl.gov</b> 2012-03-28 16:32:39 -0600 (Wed, 28 Mar 2012)</p><p>Merged trunk to new pio branch. Compiled successfully.<br>
</p><hr noshade><pre><font color="gray">
Property changes on: branches/ocean_projects/pio_trunk_merge
___________________________________________________________________
Modified: svn:mergeinfo
- /branches/ocean_projects/imp_vert_mix_mrp:754-986
/branches/ocean_projects/split_explicit_mrp:1134-1138
/branches/ocean_projects/split_explicit_timestepping:1044-1097
/branches/ocean_projects/vert_adv_mrp:704-745
/branches/source_renaming:1082-1113
/branches/time_manager:924-962
+ /branches/cam_mpas_nh:1260-1270
/branches/ocean_projects/ale_split_exp:1437-1483
/branches/ocean_projects/ale_vert_coord:1225-1383
/branches/ocean_projects/ale_vert_coord_new:1387-1428
/branches/ocean_projects/gmvar:1214-1494
/branches/ocean_projects/imp_vert_mix_mrp:754-986
/branches/ocean_projects/monotonic_advection:1499-1640
/branches/ocean_projects/split_explicit_mrp:1134-1138
/branches/ocean_projects/split_explicit_timestepping:1044-1097
/branches/ocean_projects/vert_adv_mrp:704-745
/branches/source_renaming:1082-1113
/branches/time_manager:924-962
/trunk/mpas:1191-1731
Modified: branches/ocean_projects/pio_trunk_merge/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -14,230 +14,181 @@
dummy:
- @( echo "try one of:"; \
- echo " make xlf"; \
- echo " make pgi"; \
- echo " make ifort"; \
- echo " make gfortran"; \
- )
+ ( $(MAKE) error )
-xlf-serial:
- ( make all \
- "FC = xlf90" \
- "CC = xlc" \
- "SFC = xlf90" \
- "SCC = xlc" \
- "FFLAGS = -qrealsize=8 -g -C " \
- "CFLAGS = -g" \
- "LDFLAGS = -g -C" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-
xlf:
- ( make all \
- "FC = mpxlf90" \
- "CC = mpcc" \
- "SFC = xlf90" \
- "SCC = xlc" \
- "FFLAGS = -O3 -qrealsize=8" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = mpxlf90" \
+ "CC_PARALLEL = mpcc" \
+ "FC_SERIAL = xlf90" \
+ "CC_SERIAL = xlc" \
+ "FFLAGS_OPT = -O3 -qrealsize=8" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
ftn:
- ( make all \
- "FC = ftn" \
- "CC = cc" \
- "SFC = ftn" \
- "SCC = cc" \
- "FFLAGS = -i4 -r8 -gopt -O2 -Mvect=nosse -Kieee -convert big_endian" \
- "CFLAGS = -fast" \
- "LDFLAGS = " \
+ ( $(MAKE) all \
+ "FC_PARALLEL = ftn" \
+ "CC_PARALLEL = cc" \
+ "FC_SERIAL = ftn" \
+ "CC_SERIAL = cc" \
+ "FFLAGS_OPT = -i4 -r8 -gopt -O2 -Mvect=nosse -Kieee -convert big_endian" \
+ "CFLAGS_OPT = -fast" \
+ "LDFLAGS_OPT = " \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
pgi:
- ( make all \
- "FC = mpif90" \
- "CC = mpicc" \
- "SFC = pgf90" \
- "SCC = pgcc" \
- "FFLAGS = -r8 -O3 -byteswapio -Mfree" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = mpif90" \
+ "CC_PARALLEL = mpicc" \
+ "FC_SERIAL = pgf90" \
+ "CC_SERIAL = pgcc" \
+ "FFLAGS_OPT = -r8 -O3 -byteswapio -Mfree" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
+ "FFLAGS_DEBUG = -r8 -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree" \
+ "CFLAGS_DEBUG = -O0 -g" \
+ "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
pgi-nersc:
- ( make all \
- "FC = ftn" \
- "CC = cc" \
- "SFC = ftn" \
- "SCC = cc" \
- "FFLAGS = -r8 -O3 -byteswapio -Mfree" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = ftn" \
+ "CC_PARALLEL = cc" \
+ "FC_SERIAL = ftn" \
+ "CC_SERIAL = cc" \
+ "FFLAGS_OPT = -r8 -O3 -byteswapio -Mfree" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
pgi-llnl:
- ( make all \
- "FC = mpipgf90" \
- "CC = pgcc" \
- "SFC = pgf90" \
- "SCC = pgcc" \
- "FFLAGS = -i4 -r8 -g -O2 -byteswapio" \
- "CFLAGS = -fast" \
- "LDFLAGS = " \
+ ( $(MAKE) all \
+ "FC_PARALLEL = mpipgf90" \
+ "CC_PARALLEL = pgcc" \
+ "FC_SERIAL = pgf90" \
+ "CC_SERIAL = pgcc" \
+ "FFLAGS_OPT = -i4 -r8 -g -O2 -byteswapio" \
+ "CFLAGS_OPT = -fast" \
+ "LDFLAGS_OPT = " \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-pgi-serial:
- ( make all \
- "FC = pgf90" \
- "CC = pgcc" \
- "SFC = pgf90" \
- "SCC = pgcc" \
- "FFLAGS = -r8 -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree" \
- "CFLAGS = -O0 -g" \
- "LDFLAGS = -O0 -g -Mbounds -Mchkptr" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-
-ifort-serial:
- ( make all \
- "FC = ifort" \
- "CC = gcc" \
- "SFC = ifort" \
- "SCC = gcc" \
- "FFLAGS = -real-size 64 -O3 -convert big_endian -FR" \
- "CFLAGS = -O3 -m64" \
- "LDFLAGS = -O3" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-
-ifort-papi:
- ( make all \
- "FC = mpif90" \
- "CC = gcc" \
- "SFC = ifort" \
- "SCC = gcc" \
- "FFLAGS = -real-size 64 -O3 -convert big_endian -FR" \
- "CFLAGS = -O3 -m64" \
- "LDFLAGS = -O3" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_PAPI -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" \
- "PAPILIBS = -L$(PAPI)/lib -lpapi" )
-
-ifort-papi-serial:
- ( make all \
- "FC = ifort" \
- "CC = gcc" \
- "SFC = ifort" \
- "SCC = gcc" \
- "FFLAGS = -real-size 64 -O3 -convert big_endian -FR" \
- "CFLAGS = -O3 -m64" \
- "LDFLAGS = -O3" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_PAPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" \
- "PAPILIBS = -L$(PAPI)/lib -lpapi" )
-
ifort:
- ( make all \
- "FC = mpif90" \
- "CC = gcc" \
- "SFC = ifort" \
- "SCC = gcc" \
- "FFLAGS = -real-size 64 -O3 -convert big_endian -FR" \
- "CFLAGS = -O3 -m64" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = mpif90" \
+ "CC_PARALLEL = gcc" \
+ "FC_SERIAL = ifort" \
+ "CC_SERIAL = gcc" \
+ "FFLAGS_OPT = -real-size 64 -O3 -convert big_endian -FR" \
+ "CFLAGS_OPT = -O3 -m64" \
+ "LDFLAGS_OPT = -O3" \
+ "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -FR -CU -CB -check all" \
+ "CFLAGS_DEBUG = -g -m64" \
+ "LDFLAGS_DEBUG = -g" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
gfortran:
- ( make all \
- "FC = mpif90" \
- "CC = mpicc" \
- "SFC = gfortran" \
- "SCC = gcc" \
- "FFLAGS = -O3 -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form" \
- "CFLAGS = -O3 -m64" \
- "LDFLAGS = -O3 -m64" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = mpif90" \
+ "CC_PARALLEL = mpicc" \
+ "FC_SERIAL = gfortran" \
+ "CC_SERIAL = gcc" \
+ "FFLAGS_OPT = -O3 -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form" \
+ "CFLAGS_OPT = -O3 -m64" \
+ "LDFLAGS_OPT = -O3 -m64" \
+ "FFLAGS_DEBUG = -g -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form -fbounds-check" \
+ "CFLAGS_DEBUG = -g -m64" \
+ "LDFLAGS_DEBUG = -g -m64" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-gfortran-serial:
- ( make all \
- "FC = gfortran" \
- "CC = gcc" \
- "SFC = gfortran" \
- "SCC = gcc" \
- "FFLAGS = -O3 -m64 -ffree-line-length-none -fdefault-real-8 -fconvert=big-endian -ffree-form" \
- "CFLAGS = -O3 -m64" \
- "LDFLAGS = -O3 -m64" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE -m64 $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-
g95:
- ( make all \
- "FC = mpif90" \
- "CC = mpicc" \
- "SFC = g95" \
- "SCC = gcc" \
- "FFLAGS = -O3 -ffree-line-length-huge -r8 -fendian=big" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = mpif90" \
+ "CC_PARALLEL = mpicc" \
+ "FC_SERIAL = g95" \
+ "CC_SERIAL = gcc" \
+ "FFLAGS_OPT = -O3 -ffree-line-length-huge -r8 -fendian=big" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-g95-serial:
- ( make all \
- "FC = g95" \
- "CC = gcc" \
- "SFC = g95" \
- "SCC = gcc" \
- "FFLAGS = -O3 -ffree-line-length-huge -r8 -fendian=big" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
- "CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
-
pathscale-nersc:
- ( make all \
- "FC = ftn" \
- "CC = cc" \
- "SFC = ftn" \
- "SCC = cc" \
- "FFLAGS = -r8 -O3 -freeform -extend-source" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = ftn" \
+ "CC_PARALLEL = cc" \
+ "FC_SERIAL = ftn" \
+ "CC_SERIAL = cc" \
+ "FFLAGS_OPT = -r8 -O3 -freeform -extend-source" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
cray-nersc:
- ( make all \
- "FC = ftn" \
- "CC = cc" \
- "SFC = ftn" \
- "SCC = cc" \
- "FFLAGS = -default64 -O3 -f free" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = ftn" \
+ "CC_PARALLEL = cc" \
+ "FC_SERIAL = ftn" \
+ "CC_SERIAL = cc" \
+ "FFLAGS_OPT = -default64 -O3 -f free" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
intel-nersc:
- ( make all \
- "FC = ftn" \
- "CC = cc" \
- "SFC = ftn" \
- "SCC = cc" \
- "FFLAGS = -real-size 64 -O3 -FR" \
- "CFLAGS = -O3" \
- "LDFLAGS = -O3" \
+ ( $(MAKE) all \
+ "FC_PARALLEL = ftn" \
+ "CC_PARALLEL = cc" \
+ "FC_SERIAL = ftn" \
+ "CC_SERIAL = cc" \
+ "FFLAGS_OPT = -real-size 64 -O3 -FR" \
+ "CFLAGS_OPT = -O3" \
+ "LDFLAGS_OPT = -O3" \
"CORE = $(CORE)" \
- "CPPFLAGS = -DRKIND=8 $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
+ "DEBUG = $(DEBUG)" \
+ "SERIAL = $(SERIAL)" \
+ "USE_PAPI = $(USE_PAPI)" \
+ "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE $(FILE_OFFSET) $(ZOLTAN_DEFINE)" )
CPPINCLUDES = -I../inc -I$(NETCDF)/include -I$(PAPI)/include -I$(PIO) -I$(PNETCDF)/include
FCINCLUDES = -I../inc -I$(NETCDF)/include -I$(PAPI)/include -I$(PIO) -I$(PNETCDF)/include
@@ -268,34 +219,113 @@
ifdef CORE
+ifeq "$(DEBUG)" "true"
+
+ifndef FFLAGS_DEBUG
+ FFLAGS=$(FFLAGS_OPT)
+ CFLAGS=$(CFLAGS_OPT)
+ LDFLAGS=$(LDFLAGS_OPT)
+ DEBUG_MESSAGE="Debug flags are not defined for this compile group. Defaulting to Optimized flags"
+else # FFLAGS_DEBUG IF
+ FFLAGS=$(FFLAGS_DEBUG) -DMPAS_DEBUG
+ CFLAGS=$(CFLAGS_DEBUG) -DMPAS_DEBUG
+ LDFLAGS=$(LDFLAGS_DEBUG) -DMPAS_DEBUG
+ DEBUG_MESSAGE="Debugging is on."
+endif # FFLAGS_DEBUG IF
+
+else # DEBUG IF
+ FFLAGS=$(FFLAGS_OPT)
+ CFLAGS=$(CFLAGS_OPT)
+ LDFLAGS=$(LDFLAGS_OPT)
+ DEBUG_MESSAGE="Debugging is off."
+endif # DEBUG IF
+
+ifeq "$(SERIAL)" "true"
+ FC=$(FC_SERIAL)
+ CC=$(CC_SERIAL)
+ SFC=$(FC_SERIAL)
+ SCC=$(CC_SERIAL)
+ SERIAL_MESSAGE="Serial version is on."
+else # SERIAL IF
+ FC=$(FC_PARALLEL)
+ CC=$(CC_PARALLEL)
+ SFC=$(FC_SERIAL)
+ SCC=$(CC_SERIAL)
+ override CPPFLAGS += -D_MPI
+ SERIAL_MESSAGE="Parallel version is on."
+endif # SERIAL IF
+
+ifeq "$(USE_PAPI)" "true"
+ CPPINCLUDES += -I$(PAPI)/include -D_PAPI
+ FCINCLUDES += -I$(PAPI)/include
+ LIBS += -L$(PAPI)/lib -lpapi
+ PAPI_MESSAGE="Papi libraries are on."
+else # USE_PAPI IF
+ PAPI_MESSAGE="Papi libraries are off."
+endif # USE_PAPI IF
+
+ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4
+ LIBS += -lnetcdff
+endif # CHECK FOR NETCDF4
+
all: mpas_main
mpas_main:
- cd src; make FC="$(FC)" \
- CC="$(CC)" \
- CFLAGS="$(CFLAGS)" \
- FFLAGS="$(FFLAGS)" \
- LDFLAGS="$(LDFLAGS)" \
- RM="$(RM)" \
- CPP="$(CPP)" \
- CPPFLAGS="$(CPPFLAGS)" \
- LIBS="$(LIBS)" \
- CPPINCLUDES="$(CPPINCLUDES)" \
- FCINCLUDES="$(FCINCLUDES)" \
- CORE="$(CORE)"
+ cd src; $(MAKE) -j1 FC="$(FC)" \
+ CC="$(CC)" \
+ SFC="$(SFC)" \
+ SCC="$(SCC)" \
+ CFLAGS="$(CFLAGS)" \
+ FFLAGS="$(FFLAGS)" \
+ LDFLAGS="$(LDFLAGS)" \
+ RM="$(RM)" \
+ CPP="$(CPP)" \
+ CPPFLAGS="$(CPPFLAGS)" \
+ LIBS="$(LIBS)" \
+ CPPINCLUDES="$(CPPINCLUDES)" \
+ FCINCLUDES="$(FCINCLUDES)" \
+ CORE="$(CORE)"
if [ ! -e $(CORE)_model.exe ]; then ln -s src/$(CORE)_model.exe .; fi
-
+ @echo ""
+ @echo $(DEBUG_MESSAGE)
+ @echo $(SERIAL_MESSAGE)
+ @echo $(PAPI_MESSAGE)
clean:
- cd src; make clean RM="$(RM)" CORE="$(CORE)"
+ cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)"
$(RM) $(CORE)_model.exe
+error: errmsg
-else
+else # CORE IF
-all: errmsg
+all: error
clean: errmsg
-errmsg:
+error: errmsg
@echo "************ ERROR ************"
@echo "No CORE specified. Quitting."
@echo "************ ERROR ************"
+ @echo ""
-endif
+endif # CORE IF
+
+errmsg:
+ @echo ""
+ @echo "Usage: $(MAKE) target CORE=[core] [options]"
+ @echo ""
+ @echo "Example targets:"
+ @echo " ifort"
+ @echo " gfortran"
+ @echo " xlf"
+ @echo " pgi"
+ @echo ""
+ @echo "Availabe Cores:"
+ @cd src; ls -d core_* | grep ".*" | sed "s/core_/ /g"
+ @echo ""
+ @echo "Available Options:"
+ @echo " SERIAL=true - builds serial version. Default is parallel version."
+ @echo " DEBUG=true - builds debug version. Default is optimized version."
+ @echo " USE_PAPI=true - builds version using PAPI for timers and hardware counters. Default is off."
+ @echo ""
+ @echo "Ensure that NETCDF (and PAPI if USE_PAPI=true) are environment variables"
+ @echo "that point to the absolute paths for the libraries."
+ @echo ""
+
Copied: branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_cells.ncl (from rev 1731, trunk/mpas/graphics/ncl/atm_cells.ncl)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_cells.ncl (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_cells.ncl 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_contours.ncl (from rev 1731, trunk/mpas/graphics/ncl/atm_contours.ncl)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_contours.ncl (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_contours.ncl 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_mesh.ncl (from rev 1731, trunk/mpas/graphics/ncl/atm_mesh.ncl)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_mesh.ncl (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_mesh.ncl 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_xsec.ncl (from rev 1731, trunk/mpas/graphics/ncl/atm_xsec.ncl)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_xsec.ncl (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/graphics/ncl/atm_xsec.ncl 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/namelist.input
===================================================================
--- branches/ocean_projects/pio_trunk_merge/namelist.input 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/namelist.input 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1 +1 @@
-link namelist.input.sw
\ No newline at end of file
+link namelist.input.ocean
\ No newline at end of file
Modified: branches/ocean_projects/pio_trunk_merge/namelist.input.init_nhyd_atmos
===================================================================
--- branches/ocean_projects/pio_trunk_merge/namelist.input.init_nhyd_atmos 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/namelist.input.init_nhyd_atmos 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos
===================================================================
--- branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,4 @@
&nhyd_model
- config_test_case = 0
config_time_integration = 'SRK3'
config_dt = 450.0
config_start_time = '2010-10-23_00:00:00'
Modified: branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos_mtn_wave
===================================================================
--- branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos_mtn_wave 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos_mtn_wave 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,49 +1,72 @@
&nhyd_model
- config_test_case = 6
config_time_integration = 'SRK3'
- config_dt = 6.
- config_ntimesteps = 3000
- config_output_interval = 100
+ config_dt = 6.0
+ config_start_time = '0000-01-01_00:00:00'
+ config_run_duration = '05:00:00'
config_number_of_sub_steps = 6
config_h_mom_eddy_visc2 = 10.
config_h_mom_eddy_visc4 = 0.
- config_v_mom_eddy_visc2 = 10.
+ config_v_mom_eddy_visc2 = 10.0
config_h_theta_eddy_visc2 = 10.
config_h_theta_eddy_visc4 = 0.
config_v_theta_eddy_visc2 = 10.
+ config_horiz_mixing = '2d_fixed'
config_theta_adv_order = 3
config_w_adv_order = 3
+ config_u_vadv_order = 3
+ config_w_vadv_order = 3
+ config_theta_vadv_order = 3
+ config_coef_3rd_order = 0.25
config_scalar_advection = .false.
- config_positive_definite = .false.
- config_monotonic = .false.
- config_mix_full = .false.
- config_horiz_mixing = '2d_fixed'
- config_coef_3rd_order = 0.25
- config_epssm = 0.2
+ config_epssm = 0.1
+ config_smdiv = 0.1
config_newpx = .false.
/
-
&damping
- config_zd = 22000.0
- config_xnutr = 0.0
+ config_zd = 10500.0
+ config_xnutr = 0.1
/
&dimensions
- config_nvertlevels = 26
+ config_nvertlevels = 70
/
&io
- config_input_name = 'grid.nc'
+ config_input_name = 'mtn_wave_init.nc'
config_output_name = 'output.nc'
config_restart_name = 'restart.nc'
+ config_output_interval = '00:30:00'
+ config_frames_per_outfile = 0
/
&restart
- config_restart_interval = 3000
+ config_restart_interval = '1_00:00:00'
config_do_restart = .false.
- config_restart_time = 1036800.0
/
&physics
+ config_frac_seaice = .false.
+ config_sfc_albedo = .false.
+ config_sst_update = .false.
+ config_sstdiurn_update = .false.
+ config_deepsoiltemp_update = .false.
+
+ config_n_microp = 5
+
+ config_radtlw_interval = '00:00:00'
+ config_radtsw_interval = '00:00:00'
+ config_conv_interval = 'none'
+ config_pbl_interval = 'none'
+
+ config_microp_scheme = 'off'
+ config_conv_shallow_scheme = 'off'
+ config_conv_deep_scheme = 'off'
+ config_eddy_scheme = 'off'
+ config_lsm_scheme = 'off'
+ config_pbl_scheme = 'off'
+ config_radt_cld_scheme = 'off'
+ config_radt_lw_scheme = 'off'
+ config_radt_sw_scheme = 'off'
+ config_sfclayer_scheme = 'off'
/
Modified: branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos_squall
===================================================================
--- branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos_squall 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/namelist.input.nhyd_atmos_squall 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,43 +1,74 @@
&nhyd_model
- config_test_case = 4
config_time_integration = 'SRK3'
- config_dt = 6.
- config_ntimesteps = 600
- config_output_interval = 100
+ config_dt = 3.0
+ config_start_time = '0000-01-01_00:00:00'
+ config_run_duration = '02:00:00'
config_number_of_sub_steps = 6
config_h_mom_eddy_visc2 = 500.
config_h_mom_eddy_visc4 = 0.
config_v_mom_eddy_visc2 = 500.0
config_h_theta_eddy_visc2 = 500.
- config_h_theta_eddy_visc4 = 00.
- config_v_theta_eddy_visc2 = 500.0
- config_theta_adv_order = 2
- config_scalar_adv_order = 2
- config_positive_definite = .false.
- config_monotonic = .false.
- config_newpx = .false.
+ config_h_theta_eddy_visc4 = 0.
+ config_v_theta_eddy_visc2 = 500.
+ config_horiz_mixing = '2d_fixed'
+ config_theta_adv_order = 3
+ config_w_adv_order = 3
+ config_u_vadv_order = 3
+ config_w_vadv_order = 3
+ config_theta_vadv_order = 3
+ config_coef_3rd_order = 0.25
+ config_epssm = 0.1
+ config_smdiv = 0.1
+ config_mix_full = .false.
+ config_monotonic = .true.
/
&damping
- config_zd = 22000.0
+ config_zd = 20000.0
config_xnutr = 0.0
/
&dimensions
- config_nvertlevels = 26
+ config_nvertlevels = 40
/
&io
- config_input_name = 'grid.nc'
+ config_input_name = 'supercell_init.nc'
config_output_name = 'output.nc'
config_restart_name = 'restart.nc'
+ config_output_interval = '00:30:00'
+ config_frames_per_outfile = 0
/
&restart
- config_restart_interval = 3000
+ config_restart_interval = '1_00:00:00'
config_do_restart = .false.
- config_restart_time = 1036800.0
/
&physics
+ config_frac_seaice = .false.
+ config_sfc_albedo = .false.
+ config_sst_update = .false.
+ config_sstdiurn_update = .false.
+ config_deepsoiltemp_update = .false.
+
+ config_n_microp = 1
+
+ config_radtlw_interval = '00:30:00'
+ config_radtsw_interval = '00:30:00'
+ config_conv_interval = 'none'
+ config_pbl_interval = 'none'
+
+ config_microp_scheme = 'kessler'
+ config_conv_shallow_scheme = 'off'
+ config_conv_deep_scheme = 'off'
+ config_eddy_scheme = 'off'
+ config_lsm_scheme = 'off'
+ config_pbl_scheme = 'off'
+ config_radt_cld_scheme = 'off'
+ config_radt_lw_scheme = 'off'
+ config_radt_sw_scheme = 'off'
+ config_sfclayer_scheme = 'off'
/
+
+
Modified: branches/ocean_projects/pio_trunk_merge/namelist.input.ocean
===================================================================
--- branches/ocean_projects/pio_trunk_merge/namelist.input.ocean 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/namelist.input.ocean 2012-03-28 22:32:39 UTC (rev 1732)
@@ -2,7 +2,7 @@
config_test_case = 0
config_time_integration = 'split_explicit'
config_rk_filter_btr_mode = .false.
- config_dt = 10.0
+ config_dt = 100.0
config_start_time = '0000-01-01_00:00:00'
config_run_duration = '2000_00:00:00'
config_stats_interval = 1920
@@ -20,6 +20,7 @@
/
&grid
config_vert_grid_type = 'zlevel'
+ config_pressure_type = 'pressure'
config_rho0 = 1000
/
&split_explicit_ts
@@ -31,24 +32,18 @@
config_n_btr_cor_iter = 2
config_u_correction = .true.
config_filter_btr_mode = .false.
- config_btr_mom_decay = .false.
- config_btr_mom_decay_time = 3600.0
- config_btr_mom_eddy_visc2 = 0.0
config_btr_subcycle_loop_factor = 2
- config_SSH_from = 'avg_flux'
- config_new_btr_variables_from = 'btr_avg'
config_btr_gam1_uWt1 = 0.5
config_btr_gam2_SSHWt1 = 1.0
config_btr_gam3_uWt2 = 1.0
config_btr_solve_SSH2 = .false.
+/
&hmix
config_h_mom_eddy_visc2 = 1.0e5
config_h_mom_eddy_visc4 = 0.0
config_visc_vorticity_term = .true.
- config_h_tracer_eddy_diff2 = 1.0e4
+ config_h_tracer_eddy_diff2 = 1.0e5
config_h_tracer_eddy_diff4 = 0.0
- config_mom_decay = .false.
- config_mom_decay_time = 3600.0
/
&vmix
config_vert_visc_type = 'rich'
@@ -59,11 +54,11 @@
config_bottom_drag_coeff = 1.0e-3
/
&vmix_const
- config_vert_visc = 2.5e-5
- config_vert_diff = 2.5e-5
+ config_vert_visc = 1.0e-5
+ config_vert_diff = 1.0e-5
/
&vmix_rich
- config_bkrd_vert_visc = 1.0e-4
+ config_bkrd_vert_visc = 1.0e-5
config_bkrd_vert_diff = 1.0e-5
config_rich_mix = 0.005
/
@@ -81,9 +76,8 @@
&advection
config_vert_tracer_adv = 'stencil'
config_vert_tracer_adv_order = 2
- config_tracer_adv_order = 2
+ config_horiz_tracer_adv_order = 2
config_thickness_adv_order = 2
- config_positive_definite = .false.
config_monotonic = .false.
/
&restore
Modified: branches/ocean_projects/pio_trunk_merge/src/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -6,35 +6,35 @@
$(FC) $(LDFLAGS) -o $(CORE)_model.exe driver/*.o -L. -ldycore -lops -lframework $(LIBS) -I./external/esmf_time_f90 -L./external/esmf_time_f90 -lesmf_time
reg_includes:
- ( cd registry; make CC="$(SCC)" )
- ( cd inc; ../registry/parse ../core_$(CORE)/Registry )
+ ( cd registry; $(MAKE) CC="$(SCC)" )
+ ( cd inc; $(CPP) ../core_$(CORE)/Registry | ../registry/parse > Registry.processed)
-externals:
- ( cd external; make FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" )
+externals: reg_includes
+ ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" )
-frame:
- ( cd framework; make all )
+frame: reg_includes externals
+ ( cd framework; $(MAKE) all )
ln -sf framework/libframework.a libframework.a
-ops:
- ( cd operators; make all )
+ops: reg_includes externals frame
+ ( cd operators; $(MAKE) all )
ln -sf operators/libops.a libops.a
-dycore:
- ( cd core_$(CORE); make all )
+dycore: reg_includes externals frame ops
+ ( cd core_$(CORE); $(MAKE) all )
ln -sf core_$(CORE)/libdycore.a libdycore.a
-drver:
- ( cd driver; make all )
+drver: reg_includes externals frame ops dycore
+ ( cd driver; $(MAKE) all )
clean:
$(RM) $(CORE)_model.exe libframework.a libops.a libdycore.a
- ( cd registry; make clean )
- ( cd external; make clean )
- ( cd framework; make clean )
- ( cd operators; make clean )
- ( cd inc; rm -f *.inc )
+ ( cd registry; $(MAKE) clean )
+ ( cd external; $(MAKE) clean )
+ ( cd framework; $(MAKE) clean )
+ ( cd operators; $(MAKE) clean )
+ ( cd inc; rm -f *.inc Registry.processed )
if [ -d core_$(CORE) ] ; then \
- ( cd core_$(CORE); make clean ) \
+ ( cd core_$(CORE); $(MAKE) clean ) \
fi;
- ( cd driver; make clean )
+ ( cd driver; $(MAKE) clean )
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: \
@@ -192,23 +194,28 @@
mpas_atmphys_vars.o
mpas_atmphys_driver_microphysics.o: \
- ./physics_wrf/module_mp_kessler.o \
- ./physics_wrf/module_mp_thompson.o \
- ./physics_wrf/module_mp_wsm6.o \
+ ./physics_wrf/module_mp_kessler.o \
+ ./physics_wrf/module_mp_thompson.o \
+ ./physics_wrf/module_mp_wsm6.o \
mpas_atmphys_constants.o \
mpas_atmphys_interface_nhyd.o \
mpas_atmphys_vars.o
mpas_atmphys_driver.o: \
- mpas_atmphys_driver_convection_deep.o \
- mpas_atmphys_driver_pbl.o \
- mpas_atmphys_driver_radiation_lw.o \
- mpas_atmphys_driver_radiation_sw.o \
- mpas_atmphys_driver_sfclayer.o \
- mpas_atmphys_constants.o \
- mpas_atmphys_interface_nhyd.o \
+ mpas_atmphys_driver_convection_deep.o \
+ mpas_atmphys_driver_pbl.o \
+ mpas_atmphys_driver_radiation_lw.o \
+ mpas_atmphys_driver_radiation_sw.o \
+ mpas_atmphys_driver_sfclayer.o \
+ mpas_atmphys_constants.o \
+ mpas_atmphys_interface_nhyd.o \
+ mpas_atmphys_update.o \
mpas_atmphys_vars.o
+mpas_atmphys_update.o: \
+ mpas_atmphys_driver_convection_deep.o \
+ mpas_atmphys_vars.o
+
endif
clean:
Copied: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/checkout_data_files.sh (from rev 1731, trunk/mpas/src/core_atmos_physics/checkout_data_files.sh)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/checkout_data_files.sh (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/checkout_data_files.sh 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+svn co https://svn-mpas-model.cgd.ucar.edu/data/physics_wrf/files physics_wrf/files
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_camrad_init.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_camrad_init.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_camrad_init.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -327,36 +327,6 @@
DM_BCAST_MACRO(ln_ah2ow)
DM_BCAST_MACRO(ln_eh2ow)
-!101 format(i4,7(1x,e19.12))
-!write(0,*) 'ah2onw'
-!do i_te = 1,21
-! write(0,101) i_te,(ah2onw(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-!write(0,*) 'eh2onw'
-!do i_te = 1,21
-! write(0,101) i_te,(eh2onw(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-!write(0,*) 'ah2ow'
-!do i_te = 1,21
-! write(0,101) i_te,(ah2ow(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-!write(0,*) 'cn_ah2ow'
-!do i_te = 1,21
-! write(0,101) i_te,(cn_ah2ow(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-!write(0,*) 'cn_eh2ow'
-!do i_te = 1,21
-! write(0,101) i_te,(cn_eh2ow(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-!write(0,*) 'ln_ah2ow'
-!do i_te = 1,21
-! write(0,101) i_te,(ln_ah2ow(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-!write(0,*) 'ln_eh2ow'
-!do i_te = 1,21
-! write(0,101) i_te,(ln_eh2ow(1,1,1,i_te,i_rh),i_rh=1,n_rh)
-!enddo
-
if(dminfo % my_proc_id == IO_NODE) close(cam_abs_unit)
! Set up table of H2O saturation vapor pressures for use in calculation effective path RH.
@@ -612,14 +582,15 @@
DM_BCAST_MACRO(kcb)
DM_BCAST_MACRO(wcb)
DM_BCAST_MACRO(gcb)
- DM_BCAST_MACRO(kvolc)
- DM_BCAST_MACRO(wvolc)
DM_BCAST_MACRO(kdst)
DM_BCAST_MACRO(wdst)
DM_BCAST_MACRO(gdst)
DM_BCAST_MACRO(kbg)
DM_BCAST_MACRO(wbg)
DM_BCAST_MACRO(gbg)
+ DM_BCAST_MACRO(kvolc)
+ DM_BCAST_MACRO(wvolc)
+ DM_BCAST_MACRO(gvolc)
if(dminfo % my_proc_id == IO_NODE) close(cam_aer_unit)
@@ -676,7 +647,7 @@
enddo
enddo
-!write(0,*) '--- end subroutine aer_optics_initialize:'
+ write(0,*) '--- end subroutine aer_optics_initialize:'
end subroutine aer_optics_initialize
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_control.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_control.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_control.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_date_time.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_date_time.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_date_time.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,6 +1,8 @@
!=============================================================================================
module mpas_atmphys_date_time
+ use mpas_kind_types
+
implicit none
private
public:: get_julgmt, &
@@ -94,9 +96,9 @@
!---------------------------------------------------------------------------------------------
- write(0,*)
- write(0,*) '--- enter subroutine monthly_interp_to_date:'
- write(0,*) '--- current_date =',date_str
+!write(0,*)
+!write(0,*) '--- enter subroutine monthly_interp_to_date:'
+!write(0,*) '--- current_date = ',date_str
write(day15,fmt='(I2.2)') 15
do l = 1 , 12
@@ -114,8 +116,8 @@
call get_julgmt(date_str,target_julyr,target_julday,gmt)
target_date = target_julyr * 1000 + target_julday
- write(0,*) '--- target_julday =',target_julday
- write(0,*) '--- target_date =',target_date
+!write(0,*) '--- target_julday =',target_julday
+!write(0,*) '--- target_date =',target_date
find_month : do l = 0 , 12
if((middle(l) .lt. target_date) .and. (middle(l+1) .ge. target_date)) then
@@ -129,8 +131,8 @@
month2 = month1 + 1
endif
if(n == 1) then
- write(0,*) '--- month1=',month1
- write(0,*) '--- month2=',month2
+! write(0,*) '--- month1 =',month1
+! write(0,*) '--- month2 =',month2
endif
field_out(n) = ( field_in(month2,n) * (target_date - middle(l)) &
+ field_in(month1,n) * (middle(l+1) - target_date)) &
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -11,6 +11,7 @@
use mpas_atmphys_driver_radiation_lw
use mpas_atmphys_driver_sfclayer
use mpas_atmphys_constants
+ use mpas_atmphys_update
use mpas_atmphys_vars
#ifdef non_hydrostatic_core
use mpas_atmphys_interface_nhyd
@@ -71,7 +72,7 @@
!call to short wave radiation scheme:
if(l_radtsw) then
- call allocate_radiation_sw
+ call allocate_radiation_sw(xtime_s)
call driver_radiation_sw(itimestep,block%mesh,block%state%time_levs(1)%state, &
block%diag_physics,block%sfc_input,block%tend_physics, &
xtime_s)
@@ -79,12 +80,17 @@
!call to long wave radiation scheme:
if(l_radtlw) then
- call allocate_radiation_lw
- call driver_radiation_lw(itimestep,block%mesh,block%state%time_levs(1)%state, &
- block%diag_physics,block%sfc_input,block%tend_physics, &
- xtime_s)
+ call allocate_radiation_lw(xtime_s)
+ call driver_radiation_lw(xtime_s,block%mesh,block%state%time_levs(1)%state, &
+ block%diag_physics,block%sfc_input,block%tend_physics)
endif
+ if(l_camlw .and. config_radt_lw_scheme .eq. 'cam_lw') &
+ call radiation_camlw_to_MPAS(block%diag_physics)
+ !call to accumulate long- and short-wave diagnostics if needed:
+ if(config_bucket_update /= 'none' .and. config_bucket_radt .gt. 0._RKIND) &
+ call update_radiation_diagnostics(config_bucket_radt,block%mesh,block%diag_physics)
+
!deallocate all radiation arrays:
if(config_radt_sw_scheme.ne.'off' .or. config_radt_lw_scheme.ne.'off') &
call deallocate_cloudiness
@@ -115,8 +121,12 @@
!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
+
+ !update diagnostics:
+ call update_convection_deep(config_bucket_rainc,block%mesh,block%diag_physics)
endif
!deallocate arrays shared by all physics parameterizations:
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_convection_deep.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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,15 +193,10 @@
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 , &
+ areaCell = area_p , cudt = cudt , &
curr_secs = curr_secs , adapt_step_flag = adapt_step_flag , &
rho = rho_p , raincv = raincv_p , &
pratec = pratec_p , nca = nca_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
@@ -351,12 +413,12 @@
end subroutine convection_to_MPAS
!=============================================================================================
- subroutine update_convection_deep(dt_dyn,mesh,diag_physics)
+ subroutine update_convection_deep(bucket_rainc,mesh,diag_physics)
!=============================================================================================
!input arguments:
type(mesh_type),intent(in):: mesh
- real(kind=RKIND),intent(in):: dt_dyn
+ real(kind=RKIND),intent(in):: bucket_rainc
!inout arguments:
type(diag_physics_type),intent(inout):: diag_physics
@@ -365,11 +427,19 @@
integer:: iCell
!---------------------------------------------------------------------------------------------
-
-!update the accumuluted precipitation rate at the end of each dynamic time-step:
- do iCell = 1, mesh % nCells
+
+!update the accumulated precipitation at the end of each dynamic time-step:
+ do iCell = 1, mesh % nCellsSolve
diag_physics % rainc % array(iCell) = diag_physics % rainc % array(iCell) &
+ diag_physics % cuprec % array(iCell) * dt_dyn
+
+ if(l_acrain .and. bucket_rainc.gt.0._RKIND .and. &
+ diag_physics%rainc%array(iCell).gt.bucket_rainc) then
+ diag_physics % i_rainc % array(iCell) = diag_physics % i_rainc % array(iCell) + 1
+ diag_physics % rainc % array(iCell) = diag_physics % rainc % array(iCell) &
+ - bucket_rainc
+ endif
+
enddo
end subroutine update_convection_deep
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_microphysics.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -296,7 +296,7 @@
!... copy updated precipitation from the wrf-physics grid back to the geodesic-dynamics grid:
- call precip_to_MPAS(diag_physics)
+ call precip_to_MPAS(config_bucket_rainnc,diag_physics)
!... copy updated cloud microphysics variables from the wrf-physics grid back to the geodesic-
! dynamics grid:
@@ -374,10 +374,11 @@
end subroutine precip_from_MPAS
!=============================================================================================
- subroutine precip_to_MPAS(diag_physics)
+ subroutine precip_to_MPAS(bucket_rainnc,diag_physics)
!=============================================================================================
!output variables:
+ real(kind=RKIND),intent(in):: bucket_rainnc
type(diag_physics_type),intent(inout):: diag_physics
!local variables:
@@ -396,7 +397,13 @@
!accumulated precipitation:
diag_physics % rainnc % array(i) = diag_physics % rainnc % array(i) &
+ diag_physics % rainncv % array(i)
-
+
+ if(l_acrain .and. bucket_rainnc.gt.0._RKIND .and. &
+ diag_physics%rainnc%array(i).gt.bucket_rainnc) then
+ diag_physics % i_rainnc % array(i) = diag_physics % i_rainnc % array(i) + 1
+ diag_physics % rainnc % array(i) = diag_physics % rainnc % array(i) - bucket_rainnc
+ endif
+
enddo
enddo
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_radiation_lw.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,6 @@
!=============================================================================================
module mpas_atmphys_driver_radiation_lw
+ use mpas_configure, only: config_do_restart
use mpas_grid_types
use mpas_timer
@@ -19,19 +20,25 @@
public:: allocate_radiation_lw, &
deallocate_radiation_lw, &
driver_radiation_lw, &
- init_radiation_lw
+ init_radiation_lw, &
+ radiation_camlw_to_MPAS
integer,private:: i,j,k,n
contains
!=============================================================================================
- subroutine allocate_radiation_lw
+ subroutine allocate_radiation_lw(xtime_s)
!=============================================================================================
- if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) )
- if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) )
+!input arguments:
+ real(kind=RKIND),intent(in):: xtime_s
+!---------------------------------------------------------------------------------------------
+
+ if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) )
+
if(.not.allocated(sfc_emiss_p) ) allocate(sfc_emiss_p(ims:ime,jms:jme) )
if(.not.allocated(snow_p) ) allocate(snow_p(ims:ime,jms:jme) )
if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) )
@@ -93,11 +100,14 @@
if(.not.allocated(aerosolcp_p) ) &
allocate(aerosolcp_p(ims:ime,1:num_aerlevels,jms:jme,num_aerosols) )
- if(.not.allocated(emstot_p) ) allocate(emstot_p(ims:ime,kms:kme,jms:jme) )
- if(.not.allocated(abstot_p) ) &
- allocate(abstot_p(ims:ime,kms:kme,cam_abs_dim2,jms:jme) )
- if(.not.allocated(absnxt_p) ) &
- allocate(absnxt_p(ims:ime,kms:kme,cam_abs_dim1,jms:jme) )
+ !allocate these arrays on the first time step, only:
+ if(xtime_s .lt. 1.e-12) then
+ if(.not.allocated(emstot_p) ) allocate(emstot_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(abstot_p) ) &
+ allocate(abstot_p(ims:ime,kms:kme,cam_abs_dim2,jms:jme) )
+ if(.not.allocated(absnxt_p) ) &
+ allocate(absnxt_p(ims:ime,kms:kme,cam_abs_dim1,jms:jme) )
+ endif
case default
@@ -169,10 +179,6 @@
if(allocated(aerosolcn_p) ) deallocate(aerosolcn_p )
if(allocated(aerosolcp_p) ) deallocate(aerosolcp_p )
- if(allocated(abstot_p) ) deallocate(abstot_p )
- if(allocated(absnxt_p) ) deallocate(absnxt_p )
- if(allocated(emstot_p) ) deallocate(emstot_p )
-
case default
end select radiation_lw_select
@@ -180,7 +186,7 @@
end subroutine deallocate_radiation_lw
!=============================================================================================
- subroutine radiation_lw_from_MPAS(mesh,state,diag_physics,sfc_input)
+ subroutine radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,sfc_input)
!=============================================================================================
!input arguments:
@@ -189,6 +195,8 @@
type(sfc_input_type) ,intent(in):: sfc_input
type(diag_physics_type),intent(in):: diag_physics
+ real(kind=RKIND),intent(in):: xtime_s
+
!---------------------------------------------------------------------------------------------
do j = jts,jte
@@ -283,42 +291,34 @@
enddo
enddo
- call mpas_timer_start("CAM lw: read arrays for infrared absorption")
- !infrared absorption:
- do j = jts,jte
- do n = 1,cam_abs_dim1
- do k = kts,kte
- do i = its,ite
- absnxt_p(i,k,n,j) = diag_physics % absnxt % array(k,n,i)
- enddo
- enddo
- enddo
- do n = 1,cam_abs_dim2
- do k = kts,kte+1
- do i = its,ite
- abstot_p(i,k,n,j) = diag_physics % abstot % array(k,n,i)
- enddo
- enddo
- enddo
- do k = kts,kte+1
- do i = its,ite
- emstot_p(i,k,j) = diag_physics % emstot % array(k,i)
- enddo
- enddo
- enddo
- call mpas_timer_stop("CAM lw: read arrays for infrared absorption")
-! write(0,*) '--- end radiation_lw_from_MPAS: doabsems=',doabsems
-! do k = kts,kte+1
-! write(0,102) k,(maxval(abstot_p(its:ite,k,n,jts:jte)),n=1,10)
-! enddo
-! write(0,*)
-! do k = kts,kte
-! write(0,102) k,(maxval(absnxt_p(its:ite,k,n,jts:jte)),n=1,cam_abs_dim1)
-! enddo
-! write(0,*)
-! do k = kts,kte+1
-! write(0,102) k,maxval(emstot_p(its:ite,k,jts:jte))
-! enddo
+ !On the first time-step of each model run, the local arrays absnxt_p, absnst_p,
+ !and emstot_p are filled with the MPAS arrays abstot, absnxt, and emstot. If it
+ !is a new run, these three arrays will be initialized to zero;If a restart run,
+ !these three arrays will be filled with the restart values.
+ call mpas_timer_start("CAM lw: fill arrays for infrared absorption")
+ if(xtime_s .lt. 1.e-12) then
+ do j = jts,jte
+ do n = 1,cam_abs_dim1
+ do k = kts,kte
+ do i = its,ite
+ absnxt_p(i,k,n,j) = diag_physics % absnxt % array(k,n,i)
+ enddo
+ enddo
+ enddo
+ do n = 1,cam_abs_dim2
+ do k = kts,kte+1
+ do i = its,ite
+ abstot_p(i,k,n,j) = diag_physics % abstot % array(k,n,i)
+ enddo
+ enddo
+ enddo
+ do k = kts,kte+1
+ do i = its,ite
+ emstot_p(i,k,j) = diag_physics % emstot % array(k,i)
+ enddo
+ enddo
+ enddo
+ endif
call mpas_timer_start("CAM lw: ozone and aerosols")
!ozone mixing ratio:
@@ -378,27 +378,18 @@
do j = jts,jte
do i = its,ite
- diag_physics % glw % array(i) = glw_p(i,j)
- diag_physics % lwcf % array(i) = lwcf_p(i,j)
- diag_physics % lwdnb % array(i) = lwdnb_p(i,j)
- diag_physics % lwdnbc % array(i) = lwdnbc_p(i,j)
- diag_physics % lwdnt % array(i) = lwdnt_p(i,j)
- diag_physics % lwdntc % array(i) = lwdntc_p(i,j)
- diag_physics % lwupb % array(i) = lwupb_p(i,j)
- diag_physics % lwupbc % array(i) = lwupbc_p(i,j)
- diag_physics % lwupt % array(i) = lwupt_p(i,j)
- diag_physics % lwuptc % array(i) = lwuptc_p(i,j)
- diag_physics % olrtoa % array(i) = olrtoa_p(i,j)
+ diag_physics % glw % array(i) = glw_p(i,j)
+ diag_physics % lwcf % array(i) = lwcf_p(i,j)
+ diag_physics % lwdnb % array(i) = lwdnb_p(i,j)
+ diag_physics % lwdnbc % array(i) = lwdnbc_p(i,j)
+ diag_physics % lwdnt % array(i) = lwdnt_p(i,j)
+ diag_physics % lwdntc % array(i) = lwdntc_p(i,j)
+ diag_physics % lwupb % array(i) = lwupb_p(i,j)
+ diag_physics % lwupbc % array(i) = lwupbc_p(i,j)
+ diag_physics % lwupt % array(i) = lwupt_p(i,j)
+ diag_physics % lwuptc % array(i) = lwuptc_p(i,j)
+ diag_physics % olrtoa % array(i) = olrtoa_p(i,j)
enddo
-!not needed:
-!do k = kts,kte+2
-!do i = its,ite
-! diag_physics % lwdnflx % array(k,i) = lwdnflx_p(i,k,j)
-! diag_physics % lwdnflxc % array(k,i) = lwdnflxc_p(i,k,j)
-! diag_physics % lwupflx % array(k,i) = lwupflx_p(i,k,j)
-! diag_physics % lwupflxc % array(k,i) = lwupflxc_p(i,k,j)
-!enddo
-!enddo
do k = kts,kte
do i = its,ite
@@ -407,54 +398,44 @@
enddo
enddo
- radiation_lw_select: select case (trim(radt_lw_scheme))
+!end select radiation_lw_select
- case("cam_lw")
- !infrared absorption:
- do j = jts,jte
- do n = 1,cam_abs_dim1
- do k = kts,kte
- do i = its,ite
- diag_physics % absnxt % array(k,n,i) = absnxt_p(i,k,n,j)
- enddo
- enddo
- enddo
- do n = 1,cam_abs_dim2
- do k = kts,kte+1
- do i = its,ite
- diag_physics % abstot % array(k,n,i) = abstot_p(i,k,n,j)
- enddo
- enddo
- enddo
- do k = kts,kte+1
- do i = its,ite
- diag_physics % emstot % array(k,i) = emstot_p(i,k,j)
- enddo
- enddo
- enddo
-! write(0,*) '--- end radiation_lw_to_MPAS: doabsems=',doabsems
-! do k = kts,kte+1
-! write(0,102) k,(maxval(abstot_p(its:ite,k,n,jts:jte)),n=1,10)
-! enddo
-! write(0,*)
-! do k = kts,kte
-! write(0,102) k,(maxval(absnxt_p(its:ite,k,n,jts:jte)),n=1,cam_abs_dim1)
-! enddo
-! write(0,*)
-! do k = kts,kte+1
-! write(0,102) k,maxval(emstot_p(its:ite,k,jts:jte))
-! enddo
+ end subroutine radiation_lw_to_MPAS
- case default
+!=============================================================================================
+ subroutine radiation_camlw_to_MPAS(diag_physics)
+!=============================================================================================
- end select radiation_lw_select
+!input arguments:
+ type(diag_physics_type),intent(inout):: diag_physics
-!format:
- 101 format(i3,2i6,12(1x,e15.8))
- 102 format(i6,12(1x,e15.8))
+!---------------------------------------------------------------------------------------------
- end subroutine radiation_lw_to_MPAS
+!write(0,*) '--- writing absnxt,abstot,and emstot to restart =', l_camlw
+ do j = jts,jte
+ do n = 1,cam_abs_dim1
+ do k = kts,kte
+ do i = its,ite
+ diag_physics % absnxt % array(k,n,i) = absnxt_p(i,k,n,j)
+ enddo
+ enddo
+ enddo
+ do n = 1,cam_abs_dim2
+ do k = kts,kte+1
+ do i = its,ite
+ diag_physics % abstot % array(k,n,i) = abstot_p(i,k,n,j)
+ enddo
+ enddo
+ enddo
+ do k = kts,kte+1
+ do i = its,ite
+ diag_physics % emstot % array(k,i) = emstot_p(i,k,j)
+ enddo
+ enddo
+ enddo
+ end subroutine radiation_camlw_to_MPAS
+
!=============================================================================================
subroutine init_radiation_lw(dminfo,mesh,state_1,state_2)
!=============================================================================================
@@ -490,12 +471,10 @@
end subroutine init_radiation_lw
!=============================================================================================
- subroutine driver_radiation_lw(itimestep,mesh,state,diag_physics,sfc_input, &
- tend_physics,xtime_s)
+ subroutine driver_radiation_lw(xtime_s,mesh,state,diag_physics,sfc_input,tend_physics)
!=============================================================================================
!input arguments:
- integer,intent(in):: itimestep
type(mesh_type),intent(in) :: mesh
real(kind=RKIND),intent(in):: xtime_s
@@ -510,14 +489,14 @@
!---------------------------------------------------------------------------------------------
call mpas_timer_start("radiation_lw")
- write(0,100) itimestep
+ write(0,100)
!formats:
100 format(/,' --- enter subroutine driver_radiation_lw: ',i6)
101 format(i8,12(1x,e15.8))
!copy all MPAS arrays to rectangular grid:
- call radiation_lw_from_MPAS(mesh,state,diag_physics,sfc_input)
+ call radiation_lw_from_MPAS(xtime_s,mesh,state,diag_physics,sfc_input)
!call to longwave radiation scheme:
radiation_lw_select: select case (trim(radt_lw_scheme))
@@ -560,6 +539,8 @@
radt = dt_radtlw/60.
call mpas_timer_start("camrad")
+ write(0,*) '--- enter subroutine camrad_lw: doabsems=',doabsems
+ call mpas_timer_start("camrad")
call camrad( dolw = .true. , dosw = .false. , &
rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
swupt = swupt_p , swuptc = swuptc_p , &
@@ -579,7 +560,7 @@
xlat = xlat_p , xlong = xlon_p , &
t_phy = t_p , pi_phy = pi_p , &
p_phy = pres_p , p8w = pres2_p , &
- z = z_p , dz8w = dz_p , &
+ z = zmid_p , dz8w = dz_p , &
rho_phy = rho_p , qv3d = qv_p , &
qc3d = qc_p , qr3d = qr_p , &
qi3d = qi_p , qs3d = qs_p , &
@@ -609,17 +590,13 @@
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
call mpas_timer_stop("camrad")
- write(0,*) '--- end subroutince camrad lw: doabsems=',doabsems
write(0,*) 'max lwupb =',maxval(lwupb_p(its:ite,jms:jme))
- write(0,*) 'min lwupb =',minval(lwupb_p(its:ite,jms:jme))
write(0,*) 'max lwupbc =',maxval(lwupbc_p(its:ite,jms:jme))
- write(0,*) 'min lwupbc =',minval(lwupbc_p(its:ite,jms:jme))
write(0,*) 'max lwupt =',maxval(lwupt_p(its:ite,jms:jme))
- write(0,*) 'min lwupt =',minval(lwupt_p(its:ite,jms:jme))
write(0,*) 'max lwuptc =',maxval(lwuptc_p(its:ite,jms:jme))
- write(0,*) 'min lwuptc =',minval(lwuptc_p(its:ite,jms:jme))
write(0,*) 'max rthratenlw =',maxval(rthratenlw_p(its:ite,kts:kte,jms:jme))
write(0,*) 'min rthratenlw =',minval(rthratenlw_p(its:ite,kts:kte,jms:jme))
+ write(0,*) '--- end subroutine camrad lw: doabsems=',doabsems
case default
@@ -628,9 +605,12 @@
!copy all arrays back to MPAS geodesic grid:
call radiation_lw_to_MPAS(diag_physics,tend_physics)
- write(0,*) '--- end subroutine driver_radiation_lw:'
+ write(0,*) '--- end subroutine driver_radiation_lw'
call mpas_timer_stop("radiation_lw")
+!formats:
+ 200 format(i3,i3,8(1x,e15.8))
+
end subroutine driver_radiation_lw
!=============================================================================================
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_driver_radiation_sw.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -27,12 +27,17 @@
contains
!=============================================================================================
- subroutine allocate_radiation_sw
+ subroutine allocate_radiation_sw(xtime_s)
!=============================================================================================
- if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) )
- if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) )
+!input arguments:
+ real(kind=RKIND),intent(in):: xtime_s
+!---------------------------------------------------------------------------------------------
+
+ if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(f_rain) ) allocate(f_rain(ims:ime,kms:kme,jms:jme) )
+
if(.not.allocated(xlat_p) ) allocate(xlat_p(ims:ime,jms:jme) )
if(.not.allocated(xlon_p) ) allocate(xlon_p(ims:ime,jms:jme) )
@@ -65,9 +70,6 @@
if(.not.allocated(swupflxc_p) ) allocate(swupflxc_p(ims:ime,kms:kme+1,jms:jme) )
case("cam_sw")
- if(.not.allocated(xlat_p) ) allocate(xlat_p(ims:ime,jms:jme) )
- if(.not.allocated(xlon_p) ) allocate(xlon_p(ims:ime,jms:jme) )
-
if(.not.allocated(glw_p) ) allocate(glw_p(ims:ime,jms:jme) )
if(.not.allocated(lwcf_p) ) allocate(lwcf_p(ims:ime,jms:jme) )
if(.not.allocated(lwdnb_p) ) allocate(lwdnb_p(ims:ime,jms:jme) )
@@ -98,12 +100,17 @@
if(.not.allocated(aerosolcp_p) ) &
allocate(aerosolcp_p(ims:ime,1:num_aerlevels,jms:jme,num_aerosols) )
- if(.not.allocated(emstot_p) ) allocate(emstot_p(ims:ime,kms:kme,jms:jme) )
- if(.not.allocated(abstot_p) ) &
- allocate(abstot_p(ims:ime,kms:kme,cam_abs_dim2,jms:jme) )
- if(.not.allocated(absnxt_p) ) &
- allocate(absnxt_p(ims:ime,kms:kme,cam_abs_dim1,jms:jme) )
+ !allocate these arrays on the first time step, only:
+ if(xtime_s .lt. 1.e-12) then
+ if(.not.allocated(emstot_p) ) allocate(emstot_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(abstot_p) ) &
+ allocate(abstot_p(ims:ime,kms:kme,cam_abs_dim2,jms:jme) )
+ if(.not.allocated(absnxt_p) ) &
+ allocate(absnxt_p(ims:ime,kms:kme,cam_abs_dim1,jms:jme) )
+
+ endif
+
case default
end select radiation_sw_select
@@ -176,10 +183,6 @@
if(allocated(aerosolcn_p) ) deallocate(aerosolcn_p )
if(allocated(aerosolcp_p) ) deallocate(aerosolcp_p )
- if(allocated(abstot_p) ) deallocate(abstot_p )
- if(allocated(absnxt_p) ) deallocate(absnxt_p )
- if(allocated(emstot_p) ) deallocate(emstot_p )
-
case default
end select radiation_sw_select
@@ -187,7 +190,7 @@
end subroutine deallocate_radiation_sw
!=============================================================================================
- subroutine radiation_sw_from_MPAS(mesh,state,diag_physics,sfc_input)
+ subroutine radiation_sw_from_MPAS(mesh,state,diag_physics,sfc_input,xtime_s)
!=============================================================================================
!input arguments:
@@ -196,6 +199,8 @@
type(diag_physics_type),intent(inout):: diag_physics
type(sfc_input_type) ,intent(inout):: sfc_input
+ real(kind=RKIND),intent(in):: xtime_s
+
!---------------------------------------------------------------------------------------------
do j = jts,jte
@@ -265,7 +270,6 @@
enddo
case("cam_sw")
-
do j = jts,jte
do i = its,ite
sfc_emiss_p(i,j) = diag_physics % sfc_emiss % array(i)
@@ -292,39 +296,29 @@
enddo
enddo
!infrared absorption:
- do j = jts,jte
- do n = 1,cam_abs_dim1
- do k = kts,kte
- do i = its,ite
- absnxt_p(i,k,n,j) = diag_physics % absnxt % array(k,n,i)
- enddo
- enddo
- enddo
- do n = 1,cam_abs_dim2
- do k = kts,kte+1
- do i = its,ite
- abstot_p(i,k,n,j) = diag_physics % abstot % array(k,n,i)
- enddo
- enddo
- enddo
- do k = kts,kte+1
- do i = its,ite
- emstot_p(i,k,j) = diag_physics % emstot % array(k,i)
- enddo
- enddo
- enddo
-! write(0,*) '--- end radiation_sw_from_MPAS: doabsems=',doabsems
-! do k = kts,kte+1
-! write(0,102) k,(maxval(abstot_p(its:ite,k,n,jts:jte)),n=1,10)
-! enddo
-! write(0,*)
-! do k = kts,kte
-! write(0,102) k,(maxval(absnxt_p(its:ite,k,n,jts:jte)),n=1,cam_abs_dim1)
-! enddo
-! write(0,*)
-! do k = kts,kte+1
-! write(0,102) k,maxval(emstot_p(its:ite,k,jts:jte))
-! enddo
+ if(xtime_s .lt. 1.e-12) then
+ do j = jts,jte
+ do n = 1,cam_abs_dim1
+ do k = kts,kte
+ do i = its,ite
+ absnxt_p(i,k,n,j) = 0.
+ enddo
+ enddo
+ enddo
+ do n = 1,cam_abs_dim2
+ do k = kts,kte+1
+ do i = its,ite
+ abstot_p(i,k,n,j) = 0.
+ enddo
+ enddo
+ enddo
+ do k = kts,kte+1
+ do i = its,ite
+ emstot_p(i,k,j) = 0.
+ enddo
+ enddo
+ enddo
+ endif
!ozone mixing ratio:
do k = 1, num_oznlevels
pin_p(k) = mesh % pin % array(k,1)
@@ -412,35 +406,6 @@
enddo
- radiation_sw_select: select case (trim(radt_sw_scheme))
- case("cam_sw")
- !infrared absorption:
- do j = jts,jte
- do n = 1,cam_abs_dim1
- do k = kts,kte
- do i = its,ite
- diag_physics % absnxt % array(k,n,i) = absnxt_p(i,k,n,j)
- enddo
- enddo
- enddo
- do n = 1,cam_abs_dim2
- do k = kts,kte+1
- do i = its,ite
- diag_physics % abstot % array(k,n,i) = abstot_p(i,k,n,j)
- enddo
- enddo
- enddo
- do k = kts,kte+1
- do i = its,ite
- diag_physics % emstot % array(k,i) = emstot_p(i,k,j)
- enddo
- enddo
- enddo
-
- case default
-
- end select radiation_sw_select
-
end subroutine radiation_sw_to_MPAS
!=============================================================================================
@@ -456,7 +421,7 @@
!---------------------------------------------------------------------------------------------
write(0,*)
- write(0,*) '--- begin radiation_sw initialization:'
+ write(0,*) '--- enter radiation_sw initialization:'
!call to shortwave radiation scheme:
radiation_sw_select: select case (trim(radt_sw_scheme))
@@ -475,7 +440,7 @@
end select radiation_sw_select
- write(0,*) '--- end radiation_sw initialization:'
+ write(0,*) '--- end radiation_sw initialization'
end subroutine init_radiation_sw
@@ -517,7 +482,7 @@
xtime_m = xtime_s/60.
!copy all MPAS arrays to rectangular grid:
- call radiation_sw_from_MPAS(mesh,state,diag_physics,sfc_input)
+ call radiation_sw_from_MPAS(mesh,state,diag_physics,sfc_input,xtime_s)
!... calculates solar declination:
!call radconst(declin,solcon,julday,degrad,dpd)
@@ -531,6 +496,7 @@
radiation_sw_select: select case (trim(radt_sw_scheme))
case ("rrtmg_sw")
+
write(0,*) '--- enter subroutine rrtmg_swrad:'
call rrtmg_swrad( &
rthratensw = rthratensw_p , swupt = swupt_p , swuptc = swuptc_p , &
@@ -562,6 +528,8 @@
write(0,*) '--- exit subroutine rrtmg_swrad'
case ("cam_sw")
+
+ write(0,*) '--- enter subroutine camrad_sw:'
call camrad( dolw = .false. , dosw = .true. , &
rthratenlw = rthratenlw_p , rthratensw = rthratensw_p , &
swupt = swupt_p , swuptc = swuptc_p , &
@@ -581,7 +549,7 @@
xlat = xlat_p , xlong = xlon_p , &
t_phy = t_p , pi_phy = pi_p , &
p_phy = pres_p , p8w = pres2_p , &
- z = z_p , dz8w = dz_p , &
+ z = zmid_p , dz8w = dz_p , &
rho_phy = rho_p , qv3d = qv_p , &
qc3d = qc_p , qr3d = qr_p , &
qi3d = qi_p , qs3d = qs_p , &
@@ -610,19 +578,14 @@
ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , &
its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte &
)
-
- write(0,*) '--- end subroutine camrad sw'
write(0,*) 'doabsems =',doabsems
write(0,*) 'max swupb =',maxval(swupb_p(its:ite,jms:jme))
- write(0,*) 'min swupb =',minval(swupb_p(its:ite,jms:jme))
write(0,*) 'max swupbc =',maxval(swupbc_p(its:ite,jms:jme))
- write(0,*) 'min swupbc =',minval(swupbc_p(its:ite,jms:jme))
write(0,*) 'max swupt =',maxval(swupt_p(its:ite,jms:jme))
- write(0,*) 'min swupt =',minval(swupt_p(its:ite,jms:jme))
write(0,*) 'max swuptc =',maxval(swuptc_p(its:ite,jms:jme))
- write(0,*) 'min swuptc =',minval(swuptc_p(its:ite,jms:jme))
write(0,*) 'max rthratensw =',maxval(rthratensw_p(its:ite,kts:kte,jms:jme))
write(0,*) 'min rthratensw =',minval(rthratensw_p(its:ite,kts:kte,jms:jme))
+ write(0,*) '--- end subroutine camrad sw'
case default
@@ -631,8 +594,11 @@
!copy all arrays back to MPAS geodesic grid:
call radiation_sw_to_MPAS(diag_physics,tend_physics)
- write(0,*) '--- end subroutine driver_radiation_sw:'
+ write(0,*) '--- end subroutine driver_radiation_sw'
+!formats:
+ 200 format(i3,i6,8(1x,e15.8))
+
end subroutine driver_radiation_sw
!=============================================================================================
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_init.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_init.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_init.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -58,19 +58,72 @@
!edges:
call init_dirs_forphys(mesh)
-!initialization of temperatures needed for updating the deep soil temperature:
- do iCell = 1, mesh % nCellsSolve
- diag_physics % nsteps_accum % array(iCell) = 0
- diag_physics % ndays_accum % array(iCell) = 1
+!initialization of counters i_rainc and i_rainnc. i_rainc and i_rainnc track the number of
+!times the accumulated convective (rainc) and grid-scale (rainnc) rain exceed the prescribed
+!threshold value:
+ if(.not. config_do_restart) then
+ do iCell = 1, mesh % nCellsSolve
+ diag_physics % i_rainc % array(iCell) = 0
+ diag_physics % i_rainnc % array(iCell) = 0
+ enddo
+ endif
- diag_physics % tday_accum % array(iCell) = sfc_input % tmn % array(iCell)
- diag_physics % tyear_mean % array(iCell) = sfc_input % tmn % array(iCell)
- diag_physics % tyear_accum % array(iCell) = sfc_input % tmn % array(iCell)
- do iLag = 1, mesh % nLags
- diag_physics % tlag % array(iLag,iCell) = sfc_input % tmn % array(iCell)
+!initialization of counters i_acsw* and i_aclw*. i_acsw* and i_aclw* track the number of times
+!the accumulated long and short-wave radiation fluxes exceed their prescribed theshold values.
+ if(.not. config_do_restart) then
+ do iCell = 1, mesh % nCellsSolve
+ diag_physics % i_acswdnb % array(iCell) = 0
+ diag_physics % i_acswdnbc % array(iCell) = 0
+ diag_physics % i_acswdnt % array(iCell) = 0
+ diag_physics % i_acswdntc % array(iCell) = 0
+ diag_physics % i_acswupb % array(iCell) = 0
+ diag_physics % i_acswupbc % array(iCell) = 0
+ diag_physics % i_acswupt % array(iCell) = 0
+ diag_physics % i_acswuptc % array(iCell) = 0
+
+ diag_physics % i_aclwdnb % array(iCell) = 0
+ diag_physics % i_aclwdnbc % array(iCell) = 0
+ diag_physics % i_aclwdnt % array(iCell) = 0
+ diag_physics % i_aclwdntc % array(iCell) = 0
+ diag_physics % i_aclwupb % array(iCell) = 0
+ diag_physics % i_aclwupbc % array(iCell) = 0
+ diag_physics % i_aclwupt % array(iCell) = 0
+ diag_physics % i_aclwuptc % array(iCell) = 0
+
+ diag_physics % acswdnb % array(iCell) = 0._RKIND
+ diag_physics % acswdnbc % array(iCell) = 0._RKIND
+ diag_physics % acswdnt % array(iCell) = 0._RKIND
+ diag_physics % acswdntc % array(iCell) = 0._RKIND
+ diag_physics % acswupb % array(iCell) = 0._RKIND
+ diag_physics % acswupbc % array(iCell) = 0._RKIND
+ diag_physics % acswupt % array(iCell) = 0._RKIND
+ diag_physics % acswuptc % array(iCell) = 0._RKIND
+
+ diag_physics % aclwdnb % array(iCell) = 0._RKIND
+ diag_physics % aclwdnbc % array(iCell) = 0._RKIND
+ diag_physics % aclwdnt % array(iCell) = 0._RKIND
+ diag_physics % aclwdntc % array(iCell) = 0._RKIND
+ diag_physics % aclwupb % array(iCell) = 0._RKIND
+ diag_physics % aclwupbc % array(iCell) = 0._RKIND
+ diag_physics % aclwupt % array(iCell) = 0._RKIND
+ diag_physics % aclwuptc % array(iCell) = 0._RKIND
enddo
- enddo
+ endif
+!initialization of temperatures needed for updating the deep soil temperature:
+ if(.not. config_do_restart) then
+ do iCell = 1, mesh % nCellsSolve
+ diag_physics % nsteps_accum % array(iCell) = 0._RKIND
+ diag_physics % ndays_accum % array(iCell) = 0._RKIND
+ diag_physics % tday_accum % array(iCell) = 0._RKIND
+ diag_physics % tyear_accum % array(iCell) = 0._RKIND
+ diag_physics % tyear_mean % array(iCell) = sfc_input % tmn % array(iCell)
+ do iLag = 1, mesh % nLags
+ diag_physics % tlag % array(iLag,iCell) = sfc_input % tmn % array(iCell)
+ enddo
+ enddo
+ endif
+
!initialization of global surface properties. set here for now, but may be moved when time
!manager is implemented:
call landuse_init_forMPAS(dminfo,julday,mesh,diag_physics,sfc_input)
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_initialize_real.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_initialize_real.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,11 +1,12 @@
!=============================================================================================
module mpas_atmphys_initialize_real
+ use mpas_kind_types
use mpas_configure, only: config_met_prefix, &
config_frac_seaice, &
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
@@ -51,22 +52,24 @@
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)
do while (istatus == 0)
-
- write(0,*) field % field
- if(index(field % field,'SST' ) /= 0 .or. &
- index(field % field,'SEAICE') /= 0 .or. &
- index(field % field,'ALBEDO') /= 0 .or. &
- index(field % field,'VEGFRA') /= 0 ) then
- write(0,*) field % field
+ !initialization of the sea-surface temperature (SST) and sea-ice fraction (XICE) arrays,
+ !prior to reading the input data:
+ fg % sst % array (1:mesh%nCells) = 0.0_RKIND
+ fg % xice % array (1:mesh%nCells) = 0.0_RKIND
+
+ if(index(field % field,'SKINTEMP') /= 0 .or. &
+ index(field % field,'SST' ) /= 0 .or. &
+ 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))
do j=1,field % ny
@@ -82,14 +85,30 @@
if(field % iproj == PROJ_LATLON) then
call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat), &
- loninc = real(field % deltalon), &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ latinc = real(field % deltalat,RKIND), &
+ loninc = real(field % deltalon,RKIND), &
+ knowni = 1.0_RKIND, &
+ 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:
do iCell=1,mesh % nCells
lat = mesh % latCell % array(iCell) * DEG_PER_RAD
@@ -107,13 +126,13 @@
lon = lon - 360.0
call latlon_to_ij(proj, lat, lon, x, y)
end if
-
+
if(index(field % field,'SST') /= 0) then
fg % sst % array(iCell) = interp_sequence(x,y,1,slab_r8,1,field%nx, &
- 1,field%ny,1,1,-1.e30,interp_list,1)
+ 1,field%ny,1,1,-1.e30_RKIND,interp_list,1)
elseif(index(field % field,'SEAICE') /= 0) then
fg % xice % array(iCell) = interp_sequence(x,y,1,slab_r8,1,field%nx, &
- 1,field%ny,1,1,-1.e30,interp_list,1)
+ 1,field%ny,1,1,-1.e30_RKIND,interp_list,1)
endif
end do
@@ -122,9 +141,7 @@
! exit
end if
call read_next_met_field(field,istatus)
-
enddo
- write(0,*) '--- end subroutine physics_initialize_sst:'
end subroutine physics_initialize_sst
@@ -185,16 +202,28 @@
if(config_input_sst) then
call physics_initialize_sst(mesh,fg)
+ if(maxval(xice(1:nCellsSolve)) == 0._RKIND .and. minval(xice(1:nCellsSolve)) == 0._RKIND) then
+ write(0,*)
+ write(0,*) "The input file does not contain sea-ice data. We freeze the really cold ocean instead"
+ do iCell = 1, nCellsSolve
+ if(landmask(iCell).eq.0 .and. sst(iCell).lt.271._RKIND) xice(iCell) = 1._RKIND
+ enddo
+ endif
+ write(0,*) 'max sst =',maxval(fg % sst % array(1:mesh%nCells))
+ write(0,*) 'min sst =',minval(fg % sst % array(1:mesh%nCells))
+ write(0,*) 'max xice =',maxval(fg % xice % array(1:mesh%nCells))
+ write(0,*) 'min xice =',minval(fg % xice % array(1:mesh%nCells))
+
do iCell = 1, nCellsSolve
!recalculate the sea-ice flag:
- if(xice(iCell) .gt. 0.) then
- seaice(iCell) = 1
+ if(xice(iCell) .gt. 0._RKIND) then
+ seaice(iCell) = 1._RKIND
else
- seaice(iCell) = 0
+ seaice(iCell) = 0._RKIND
endif
!set the skin temperature to the sea-surface temperature over the oceans:
- if(landmask(iCell).eq.0 .and. sst(iCell).gt.170. .and. sst(iCell).lt.400.) &
+ if(landmask(iCell).eq.0 .and. sst(iCell).gt.170._RKIND .and. sst(iCell).lt.400._RKIND) &
skintemp(iCell) = sst(iCell)
enddo
endif
@@ -205,8 +234,8 @@
call monthly_interp_to_date(nCellsSolve,initial_date,albedo12m,sfc_albbck)
do iCell = 1, nCellsSolve
- sfc_albbck(iCell) = sfc_albbck(iCell) / 100.
- if(landmask(iCell) .eq. 0) sfc_albbck(iCell) = 0.08
+ sfc_albbck(iCell) = sfc_albbck(iCell) / 100._RKIND
+ if(landmask(iCell) .eq. 0) sfc_albbck(iCell) = 0.08_RKIND
enddo
!initialization of the green-ness (vegetation) fraction: interpolation of the monthly values to
@@ -220,10 +249,10 @@
!limit the annual maximum snow albedo to 0.08 over open-ocean and to 0.75 over sea-ice cells::
do iCell = 1, nCellsSolve
- if(landmask(iCell) .eq. 0 .and. seaice(iCell) .eq. 0.) then
- snoalb(iCell) = 0.08
- elseif(landmask(iCell) .eq. 0 .and. seaice(iCell) .eq. 1.) then
- snoalb(iCell) = 0.75
+ if(landmask(iCell) .eq. 0 .and. seaice(iCell) .eq. 0._RKIND) then
+ snoalb(iCell) = 0.08_RKIND
+ elseif(landmask(iCell) .eq. 0 .and. seaice(iCell) .eq. 1._RKIND) then
+ snoalb(iCell) = 0.75_RKIND
endif
enddo
@@ -231,12 +260,12 @@
!(m) as functions of the input snow water content (kg/m2). we use a 5:1 ratio from liquid
!water equivalent to snow depth:
do iCell = 1, nCellsSolve
- if(snow(iCell) .ge. 10.) then
- snowc(iCell) = 1.
+ if(snow(iCell) .ge. 10._RKIND) then
+ snowc(iCell) = 1._RKIND
else
- snowc(iCell) = 0.
+ snowc(iCell) = 0._RKIND
endif
- snowh(iCell) = snow(iCell) * 5.0 / 1000.
+ snowh(iCell) = snow(iCell) * 5.0_RKIND / 1000._RKIND
enddo
!initialization of soil layers properties:
@@ -247,10 +276,10 @@
!define xland over land and ocean:
do iCell = 1, nCellsSolve
- if(landmask(iCell) .eq. 1 .or. (landmask(iCell).eq.0 .and. seaice(iCell).eq.1.)) then
- xland(iCell) = 1.
+ if(landmask(iCell) .eq. 1 .or. (landmask(iCell).eq.0 .and. seaice(iCell).eq.1._RKIND)) then
+ xland(iCell) = 1._RKIND
elseif(landmask(iCell) .eq. 0) then
- xland(iCell) = 2.
+ xland(iCell) = 2._RKIND
endif
enddo
@@ -425,8 +454,8 @@
nCells = mesh % nCells
nSoilLevels = mesh % nSoilLevels
nFGSoilLevels = mesh % nFGSoilLevels
- write(0,*) 'nSoilLevels =',nSoilLevels
- write(0,*) 'nFGSoilLevels=',nFGSoilLevels
+ write(0,*) 'nSoilLevels =',nSoilLevels
+ write(0,*) 'nFGSoilLevels =',nFGSoilLevels
landmask => mesh % landmask % array
@@ -606,7 +635,7 @@
endif
!make sure that all the cells flagged as sea-ice cells are defined as ocean cells:
-!num_seaice_changes = 0
+ num_seaice_changes = 0
do iCell = 1, nCellsSolve
if((landmask(iCell).eq.1 .and. xice(iCell).gt.0.) .or. xice(iCell).gt.200.) then
num_seaice_changes = num_seaice_changes + 1
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_interface_nhyd.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -23,15 +23,18 @@
subroutine allocate_forall_physics
!=============================================================================================
- if(.not.allocated(psfc_p)) allocate(psfc_p(ims:ime,jms:jme) )
- if(.not.allocated(ptop_p)) allocate(ptop_p(ims:ime,jms:jme) )
+ if(.not.allocated(psfc_p) ) allocate(psfc_p(ims:ime,jms:jme) )
+ if(.not.allocated(ptop_p) ) allocate(ptop_p(ims:ime,jms:jme) )
if(.not.allocated(u_p) ) allocate(u_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(v_p) ) allocate(v_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(fzm_p) ) allocate(fzm_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(fzp_p) ) allocate(fzp_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(zz_p) ) allocate(zz_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(pres_p) ) allocate(pres_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(pi_p) ) allocate(pi_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(z_p) ) allocate(z_p(ims:ime,kms:kme,jms:jme) )
+ if(.not.allocated(zmid_p) ) allocate(zmid_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(dz_p) ) allocate(dz_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(t_p) ) allocate(t_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) )
@@ -42,44 +45,7 @@
if(.not.allocated(w_p) ) allocate(w_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(pres2_p)) allocate(pres2_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(t2_p) ) allocate(t2_p(ims:ime,kms:kme,jms:jme) )
-
- if(.not.allocated(pres_hyd_p) ) allocate(pres_hyd_p(ims:ime,kms:kme,jms:jme) )
- if(.not.allocated(pres2_hyd_p)) allocate(pres2_hyd_p(ims:ime,kms:kme,jms:jme) )
- do j = jms,jme
- do i = ims,ime
- psfc_p(i,j) = 0.
- ptop_p(i,j) = 0.
- enddo
- enddo
-
- do j = jms,jme
- do k = kms,kme
- do i = ims,ime
- u_p(i,k,j) = 0.
- v_p(i,k,j) = 0.
- w_p(i,k,j) = 0.
- pres_p(i,k,j) = 0.
- pi_p(i,k,j) = 0.
- z_p(i,k,j) = 0.
- dz_p(i,k,j) = 0.
- t_p(i,k,j) = 0.
- th_p(i,k,j) = 0.
- al_p(i,k,j) = 0.
- rho_p(i,k,j) = 0.
- rh_p(i,k,j) = 0.
-
- w_p(i,k,j) = 0.
- pres2_p(i,k,j) = 0.
- t2_p(i,k,j) = 0.
-
- pres_hyd_p(i,k,j) = 0.
- pres2_hyd_p(i,k,j) = 0.
- enddo
- enddo
- enddo
-
-!allocate moist species (to be revisited!):
if(.not.allocated(qv_p) ) allocate(qv_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(qc_p) ) allocate(qc_p(ims:ime,kms:kme,jms:jme) )
if(.not.allocated(qr_p) ) allocate(qr_p(ims:ime,kms:kme,jms:jme) )
@@ -93,16 +59,18 @@
subroutine deallocate_forall_physics
!=============================================================================================
-!de-allocation of all physics arrays:
if(allocated(psfc_p) ) deallocate(psfc_p )
if(allocated(ptop_p) ) deallocate(ptop_p )
if(allocated(u_p) ) deallocate(u_p )
if(allocated(v_p) ) deallocate(v_p )
+ if(allocated(fzm_p) ) deallocate(fzm_p )
+ if(allocated(fzp_p) ) deallocate(fzp_p )
if(allocated(zz_p) ) deallocate(zz_p )
if(allocated(pres_p) ) deallocate(pres_p )
if(allocated(pi_p) ) deallocate(pi_p )
if(allocated(z_p) ) deallocate(z_p )
+ if(allocated(zmid_p) ) deallocate(zmid_p )
if(allocated(dz_p) ) deallocate(dz_p )
if(allocated(t_p) ) deallocate(t_p )
if(allocated(th_p) ) deallocate(th_p )
@@ -114,9 +82,6 @@
if(allocated(pres2_p) ) deallocate(pres2_p )
if(allocated(t2_p) ) deallocate(t2_p )
- if(allocated(pres_hyd_p) ) deallocate(pres_hyd_p )
- if(allocated(pres2_hyd_p)) deallocate(pres2_hyd_p )
-
if(allocated(qv_p) ) deallocate(qv_p )
if(allocated(qc_p) ) deallocate(qc_p )
if(allocated(qr_p) ) deallocate(qr_p )
@@ -141,12 +106,13 @@
real(kind=RKIND),dimension(:),pointer:: latCell,lonCell
real(kind=RKIND),dimension(:),pointer :: fzm,fzp,rdzw
+ real(kind=RKIND),dimension(:),pointer :: sfc_pressure
real(kind=RKIND),dimension(:,:),pointer:: zgrid
real(kind=RKIND),dimension(:,:),pointer:: zz,exner,pressure_b,rtheta_p,rtheta_b
real(kind=RKIND),dimension(:,:),pointer:: rho_zz,theta_m,qv,pressure_p,u,v,w
real(kind=RKIND),dimension(:,:),pointer:: qvs,rh
- integer:: ip,iEdg
+ real(kind=RKIND):: rho1,rho2,tem1,tem2
!---------------------------------------------------------------------------------------------
@@ -164,25 +130,50 @@
latCell => mesh % latCell % array
lonCell => mesh % lonCell % array
- fzm => mesh % fzm % array
- fzp => mesh % fzp % array
- rdzw => mesh % rdzw % array
- zgrid => mesh % zgrid % array
- zz => mesh % zz % array
- exner => diag % exner % array
- pressure_b => diag % pressure_base % array
- pressure_p => diag % pressure_p % array
- rtheta_p => diag % rtheta_p % array
- rtheta_b => diag % rtheta_base % array
+ fzm => mesh % fzm % array
+ fzp => mesh % fzp % array
+ rdzw => mesh % rdzw % array
+ zgrid => mesh % zgrid % array
+ zz => mesh % zz % array
+ sfc_pressure => diag % surface_pressure % array
+ exner => diag % exner % array
+ pressure_b => diag % pressure_base % array
+ pressure_p => diag % pressure_p % array
+ rtheta_p => diag % rtheta_p % array
+ rtheta_b => diag % rtheta_base % array
- rho_zz => state % rho_zz % array
- theta_m => state % theta_m % array
- qv => state % scalars % array(state%index_qv,:,:)
+ rho_zz => state % rho_zz % array
+ theta_m => state % theta_m % array
+ qv => state % scalars % array(state%index_qv,:,:)
- w => state % w % array
- u => diag % uReconstructZonal % array
- v => diag % uReconstructMeridional % array
+ w => state % w % array
+ u => diag % uReconstructZonal % array
+ v => diag % uReconstructMeridional % array
+!ldf (2012-01-06): updates the surface pressure as is done in subroutine microphysics_to_MPAS.
+!do j = jts,jte
+!do i = its,ite
+! sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) &
+! * (1.25 * rho_zz(1,i) * zz(1,i) * (1. + qv(1,i)) &
+! - 0.25 * rho_zz(2,i) * zz(2,i) * (1. + qv(1,i)))
+! sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
+!enddo
+!enddo
+!ldf end.
+!ldf (2012-01-09): updates the surface pressure using zgrid.
+ do j = jts,jte
+ do i = its,ite
+ tem1 = zgrid(2,i)-zgrid(1,i)
+ tem2 = zgrid(3,i)-zgrid(2,i)
+ rho1 = rho_zz(1,i) * zz(1,i) * (1. + qv(1,i))
+ rho2 = rho_zz(2,i) * zz(2,i) * (1. + qv(2,i))
+ sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) &
+ * (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2))
+ sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
+ enddo
+ enddo
+!ldf end.
+
!copy sounding variables from the geodesic grid to the rectangular grid:
do j = jts, jte
do i = its, ite
@@ -215,11 +206,18 @@
pi_p(i,k,j) = exner(k,i)
pres_p(i,k,j) = pressure_p(k,i) + pressure_b(k,i)
- dz_p(i,k,j) = zgrid(k+1,i)-zgrid(k,i)
+ zmid_p(i,k,j) = 0.5*(zgrid(k+1,i)+zgrid(k,i))
+ dz_p(i,k,j) = zgrid(k+1,i)-zgrid(k,i)
- !arrays located at w points:
+ enddo
+ enddo
+ enddo
+
+ do j = jts, jte
+ do k = kts,kte+1
+ do i = its,ite
w_p(i,k,j) = w(k,i)
-
+ z_p(i,k,j) = zgrid(k,i)
enddo
enddo
enddo
@@ -247,11 +245,23 @@
enddo
!interpolation of pressure and temperature from theta points to w points:
+!do j = jts,jte
+!do k = kts+1,kte
+!do i = its,ite
+! t2_p(i,k,j) = fzm(k)*t_p(i,k,j) + fzp(k)*t_p(i,k-1,j)
+! pres2_p(i,k,j) = fzm(k)*pres_p(i,k,j) + fzp(k)*pres_p(i,k-1,j)
+!enddo
+!enddo
+!enddo
+!ldf(2011-01-10):
do j = jts,jte
do k = kts+1,kte
do i = its,ite
- t2_p(i,k,j) = fzm(k)*t_p(i,k,j) + fzp(k)*t_p(i,k-1,j)
- pres2_p(i,k,j) = fzm(k)*pres_p(i,k,j) + fzp(k)*pres_p(i,k-1,j)
+ tem1 = 1./(zgrid(k+1,i)-zgrid(k-1,i))
+ fzm_p(i,k,j) = (zgrid(k,i)-zgrid(k-1,i)) * tem1
+ fzp_p(i,k,j) = (zgrid(k+1,i)-zgrid(k,i)) * tem1
+ t2_p(i,k,j) = fzm_p(i,k,j)*t_p(i,k,j) + fzp_p(i,k,j)*t_p(i,k-1,j)
+ pres2_p(i,k,j) = fzm_p(i,k,j)*pres_p(i,k,j) + fzp_p(i,k,j)*pres_p(i,k-1,j)
enddo
enddo
enddo
@@ -311,17 +321,6 @@
enddo
enddo
-!calculation of the hydrostatic pressure at w points:
- do j = jts,jte
- do i = its,ite
- pres2_hyd_p(i,1,j) = psfc_p(i,j)
- do k = kts+1,kte+1
- pres2_hyd_p(i,k,j) = pres2_hyd_p(i,k-1,j) &
- - rho_p(i,k-1,j)*(1+qv_p(i,k-1,j))*g*dz_p(i,k-1,j)
- enddo
- enddo
- enddo
-
!formats:
201 format(3i8,10(1x,e15.8))
202 format(2i6,10(1x,e15.8))
@@ -480,6 +479,13 @@
real(kind=RKIND),dimension(:,:),pointer:: rho_zz,theta_m,pressure_p
real(kind=RKIND),dimension(:,:),pointer:: rt_diabatic_tend
+!ldf(2011-11-12): surface pressure.
+ real(kind=RKIND):: rho1,rho2,tem1,tem2
+ real(kind=RKIND),dimension(:),pointer:: rdzw
+ real(kind=RKIND),dimension(:),pointer:: sfc_pressure
+ real(kind=RKIND),dimension(:,:),pointer:: zgrid
+!ldf end.
+
!---------------------------------------------------------------------------------------------
write(0,*)
@@ -487,6 +493,7 @@
!initialization:
zz => mesh % zz % array
+ zgrid => mesh % zgrid % array
exner => diag % exner % array
exner_b => diag % exner_base % array
pressure_b => diag % pressure_base % array
@@ -499,6 +506,11 @@
rt_diabatic_tend => tend % rt_diabatic_tend % array
+!ldf (2011-11-12): update surface pressure.
+ rdzw => mesh % rdzw % array
+ sfc_pressure => diag % surface_pressure % array
+!ldf end.
+
!variables common to all cloud microphysics schemes:
do j = jts, jte
@@ -529,7 +541,30 @@
enddo
enddo
enddo
-
+
+!updates the surface pressure.
+!do j = jts,jte
+!do i = its,ite
+! sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) &
+! * (1.25 * rho_zz(1,i) * zz(1,i) * (1. + qv_p(i,1,j)) &
+! - 0.25 * rho_zz(2,i) * zz(2,i) * (1. + qv_p(i,2,j)))
+! sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
+!enddo
+!enddo
+!ldf (2012-01-09):
+ do j = jts,jte
+ do i = its,ite
+ tem1 = zgrid(2,i)-zgrid(1,i)
+ tem2 = zgrid(3,i)-zgrid(2,i)
+ rho1 = rho_zz(1,i) * zz(1,i) * (1. + qv_p(i,1,j))
+ rho2 = rho_zz(2,i) * zz(2,i) * (1. + qv_P(i,2,j))
+ sfc_pressure(i) = 0.5*g*(zgrid(2,i)-zgrid(1,i)) &
+ * (rho1 + 0.5*(rho2-rho1)*tem1/(tem1+tem2))
+ sfc_pressure(i) = sfc_pressure(i) + pressure_p(1,i) + pressure_b(1,i)
+ enddo
+ enddo
+!ldf end.
+
!variables specific to different cloud microphysics schemes:
microp_select_init: select case(microp_scheme)
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_lsm_noahinit.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_lsm_noahinit.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_lsm_noahinit.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -9,7 +9,7 @@
use mpas_configure, only: restart => config_do_restart, &
mminlu => input_landuse_data, &
mminsl => input_soil_data , &
- input_sfc_albedo => config_sfc_albedo
+ input_sfc_albedo => config_sfc_snowalbedo
use mpas_dmpar
use mpas_grid_types
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_manager.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_manager.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_manager.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -38,6 +38,22 @@
!between updates is 6 hours and is set with config_camrad_abs_update (00:30:00).
integer, parameter:: camAlarmID = 17
+!defines alarm to save the CAM arrays absnst, absnxt, and emstot to restart files. When the
+!alarm rings, the local arrays absnt_p, absnxt_p, and emstot_p are copied to the MPAS arrays
+!for writing to restart files at the bottom of the time-step:
+ integer, parameter:: camlwAlarmID = 18
+ type(MPAS_TimeInterval_Type):: camlwTimeStep
+
+!defines alarm to check if the accumulated rain due to cloud microphysics and convection is
+!greater than its maximum allowed value:
+ integer, parameter:: acrainAlarmID = 19
+ type(MPAS_TimeInterval_Type):: acrainTimeStep
+
+!defines alarm to check if the accumulated radiation diagnostics due to long- and short-wave
+!radiation is greater than its maximum allowed value:
+ integer, parameter:: acradtAlarmID = 20
+ type(MPAS_TimeInterval_Type):: acradtTimeStep
+
integer :: h, m, s, s_n, s_d, DoY, yr
real(kind=RKIND) :: utc_h
@@ -76,7 +92,8 @@
' GMT =', f16.9,/, &
' UTC_H =', f16.9,/, &
' CURR_JULDAY =', f16.9,/, &
- ' LEAP_YEAR =', 1x,l1,/)
+ ' LEAP_YEAR =', 1x,l1,/, &
+ ' TIME STAMP =', 1x,a32,/)
currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr)
call mpas_get_time(curr_time=currTime,dateTimeString=timeStamp,YYYY=yr,H=h,M=m, &
@@ -88,7 +105,7 @@
julday = DoY
curr_julday = real(julday-1) + utc_h / 24.0
LeapYear = isLeapYear(year)
- write(0,100) year,julday,gmt,utc_h,curr_julday,LeapYear
+ write(0,100) year,julday,gmt,utc_h,curr_julday,LeapYear,timeStamp
block => domain % blocklist
do while(associated(block))
@@ -97,7 +114,7 @@
!monthly values to current day:
if(mpas_is_alarm_ringing(clock,greenAlarmID,ierr=ierr)) then
call mpas_reset_clock_alarm(clock,greenAlarmID,ierr=ierr)
- write(0,*) '--- update background surface albedo, greeness fraction:', timeStamp
+ write(0,*) '--- time to update background surface albedo, greeness fraction.'
call physics_update_surface(timeStamp,block%mesh,block%sfc_input)
endif
@@ -133,7 +150,6 @@
elseif(config_radtlw_interval == "none") then
l_radtlw = .true.
endif
- write(0,*)
write(0,*) '--- time to run the LW radiation scheme L_RADLW =',l_radtlw
endif
@@ -151,6 +167,21 @@
write(0,*) '--- time to run the SW radiation scheme L_RADSW =',l_radtsw
endif
+!check to see if it is time to run the parameterization of convection:
+ if(trim(config_conv_deep_scheme) /= "off") then
+ l_conv = .false.
+
+ if(config_conv_interval /= "none") then
+ if(mpas_is_alarm_ringing(clock,convAlarmID,ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock,convAlarmID,ierr=ierr)
+ l_conv = .true.
+ endif
+ elseif(config_conv_interval == "none") then
+ l_conv = .true.
+ endif
+ write(0,*) '--- time to run the convection scheme L_CONV =',l_conv
+ endif
+
!check to see if it is time to update the ozone trace gas path lengths,the total emissivity,
!and the total absorptivity in the "CAM" long-wave radiation codes.
if(trim(config_radt_lw_scheme) .eq. "cam_lw" .or. &
@@ -161,13 +192,42 @@
call mpas_reset_clock_alarm(clock,camAlarmID,ierr=ierr)
doabsems = .true.
endif
- write(0,*) '--- update CAM absorptivity and emissivity arrays DOABSEMS =',doabsems
+ write(0,*) '--- time to update CAM absorptivity and emissivity arrays DOABSEMS =',doabsems
+ endif
+!check to see if it is time to save the local CAM arrays absnst_p, absnxt_p, and emstot_p to
+!the MPAS arrays:
+ if(trim(config_radt_lw_scheme) .eq. "cam_lw") then
+ l_camlw = .false.
+ if(mpas_is_alarm_ringing(clock,camlwAlarmID,camlwTimeStep,ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock,camlwAlarmID,camlwTimeStep,ierr=ierr)
+ l_camlw = .true.
+ endif
+ write(0,*) '--- time to write local CAM arrays to MPAS arrays L_CAMLW =',l_camlw
endif
-
-!formats:
- 101 format(3x,'l_radtlw = ',l1,3x,'l_radtsw = ',l1)
+!check to see if it is time to apply limit to the accumulated rain due to cloud microphysics
+!and convection:
+ if(trim(config_conv_deep_scheme) /= "off") then
+ l_acrain = .false.
+ if(mpas_is_alarm_ringing(clock,acrainAlarmID,acrainTimeStep,ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock,acrainAlarmID,acrainTimeStep,ierr=ierr)
+ l_acrain = .true.
+ endif
+ write(0,*) '--- time to apply limit to accumulated rainc and rainnc L_ACRAIN =',l_acrain
+ endif
+
+!check to see if it is time to apply limit to the accumulated radiation diagnostics due to
+!long- and short-wave radiation:
+ if(trim(config_radt_lw_scheme) /= "off" .or. trim(config_radt_sw_scheme) /= "off") then
+ l_acradt = .false.
+ if(mpas_is_alarm_ringing(clock,acradtAlarmID,acradtTimeStep,ierr=ierr)) then
+ call mpas_reset_clock_alarm(clock,acradtAlarmID,acradtTimeStep,ierr=ierr)
+ l_acradt = .true.
+ endif
+ write(0,*) '--- time to apply limit to accumulated radiation diags. L_ACRADT =',l_acradt
+ endif
+
end subroutine physics_timetracker
!=============================================================================================
@@ -290,7 +350,7 @@
if(ierr /= 0) &
call physics_error_fatal('subroutine physics_run_init: error defining dt_pbl')
- elseif(trim(config_conv_interval) == "none") then
+ elseif(trim(config_pbl_interval) == "none") then
dt_pbl = config_dt
else
@@ -325,6 +385,39 @@
call physics_error_fatal('subroutine physics_init: error creating alarm CAM')
endif
+!set alarm to write the "CAM" local arrays absnst_p, absnxt_p, and emstot_p to the MPAS arrays
+!for writing to the restart file at the bottom of the time-step:
+ if(trim(config_radt_lw_scheme) .eq. "cam_lw" ) then
+ call mpas_set_timeInterval(camlwTimeStep,dt=config_dt,ierr=ierr)
+ call mpas_set_timeInterval(alarmTimeStep,timeString=config_restart_interval,ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock,camlwAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr)
+ if(ierr /= 0) &
+ call physics_error_fatal('subroutine physics_init: error creating alarm CAMLW')
+ endif
+
+!set alarm to check if the accumulated rain due to cloud microphysics and convection is
+!greater than its maximum allowed value:
+ if(config_bucket_update /= "none") then
+ call mpas_set_timeInterval(acrainTimeStep,dt=config_dt,ierr=ierr)
+ call mpas_set_timeInterval(alarmTimeStep,timeString=config_bucket_update,ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock,acrainAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr)
+ if(ierr /= 0) &
+ call physics_error_fatal('subroutine physics_init: error creating alarm rain limit')
+ endif
+
+!set alarm to check if the accumulated radiation diagnostics due to long- and short-wave radiation
+!is greater than its maximum allowed value:
+ if(config_bucket_update /= "none") then
+ call mpas_set_timeInterval(acradtTimeStep,dt=config_dt,ierr=ierr)
+ call mpas_set_timeInterval(alarmTimeStep,timeString=config_bucket_update,ierr=ierr)
+ alarmStartTime = startTime + alarmTimeStep
+ call mpas_add_clock_alarm(clock,acradtAlarmID,alarmStartTime,alarmTimeStep,ierr=ierr)
+ if(ierr /= 0) &
+ call physics_error_fatal('subroutine physics_init: error creating alarm radiation limit')
+ endif
+
write(0,102) dt_radtlw,dt_radtsw,dt_cu,dt_pbl
!initialization of physics dimensions to mimic a rectangular grid:
@@ -344,31 +437,39 @@
ids,ide,jds,jde,kds,kde, &
its,ite,jts,jte,kts,kte
-!initialization:
+!initialization local physics variables:
num_months = mesh % nMonths
+ num_soils = mesh% nSoilLevels
-!initialization of physics time-steps:
- dt_dyn = config_dt
- n_microp = config_n_microp
- n_cu = config_n_conv
-
- dt_microp = dt_dyn/n_microp !for now.
-
-!write(0,*) 'mod =',mod(dt_dyn,dt_radtsw)
-!write(0,*) 'mod =',mod(dt_dyn,dt_microp)
-!stop
-
-!cloud microphysics scheme:
- microp_scheme = trim(config_microp_scheme)
conv_deep_scheme = trim(config_conv_deep_scheme)
conv_shallow_scheme = trim(config_conv_shallow_scheme)
- sfclayer_scheme = trim(config_sfclayer_scheme)
+ lsm_scheme = trim(config_lsm_scheme)
+ microp_scheme = trim(config_microp_scheme)
pbl_scheme = trim(config_pbl_scheme)
radt_cld_scheme = trim(config_radt_cld_scheme)
radt_lw_scheme = trim(config_radt_lw_scheme)
radt_sw_scheme = trim(config_radt_sw_scheme)
+ sfclayer_scheme = trim(config_sfclayer_scheme)
-!CAM radiation schemes:
+!initialization of local physics time-steps:
+!... dynamics:
+ dt_dyn = config_dt
+!... cloud microphysics:
+ n_microp = config_n_microp
+ dt_microp = dt_dyn/n_microp !for now.
+!... convection:
+ l_conv = .false.
+ n_cu = nint(dt_cu/dt_dyn)
+ n_cu = max(n_cu,1)
+!... radiation:
+ l_radtlw = .false.
+ l_radtsw = .false.
+!... others:
+ l_camlw = .false.
+ l_acrain = .false.
+ l_acradt = .false.
+
+!initialization for CAM radiation schemes only:
if(trim(config_radt_lw_scheme) .eq. "cam_lw" .or. &
trim(config_radt_sw_scheme) .eq. "cam_sw" ) then
@@ -387,10 +488,7 @@
endif
-!land-surface scheme:
- lsm_scheme = trim(config_lsm_scheme)
- num_soils = mesh% nSoilLevels
-
+!initialization of sea-ice threshold:
if(.not. config_frac_seaice) then
xice_threshold = 0.5
elseif(config_frac_seaice) then
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_todynamics.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_todynamics.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_todynamics.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -3,7 +3,7 @@
use mpas_configure
use mpas_grid_types
- use mpas_atmphys_constants, only: R_d,R_v
+ use mpas_atmphys_constants, only: R_d,R_v,degrad
implicit none
private
@@ -34,9 +34,9 @@
!local variables:
!----------------
- integer:: i,k,nCells,nCellsSolve,nEdges,nEdgesSolve,nVertLevels
+ integer:: i,iCell,k,n,nCells,nCellsSolve,nEdges,nEdgesSolve,nVertLevels
- real(kind=RKIND),dimension(:,:),pointer:: theta,theta_m,qv
+ real(kind=RKIND),dimension(:,:),pointer:: theta_m,qv
real(kind=RKIND),dimension(:,:),pointer:: rthblten,rqvblten,rqcblten, &
rqiblten,rublten,rvblten
real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, &
@@ -49,6 +49,10 @@
real(kind=RKIND):: tem
real(kind=RKIND),dimension(:,:),allocatable:: rublten_Edge
+!ldf (2011-12-16):
+ real(kind=RKIND),dimension(:,:),allocatable:: theta,tend_th
+!ldf end.
+
!=============================================================================================
!write(0,*)
!write(0,*) '--- enter subroutine physics_add_tend:'
@@ -59,7 +63,7 @@
nEdgesSolve = mesh % nEdgesSolve
nVertLevels = mesh % nVertLevels
- theta => diag % theta % array
+!theta => diag % theta % array
theta_m => state % theta_m % array
qv => state % scalars % array(state%index_qv,:,:)
@@ -84,6 +88,11 @@
tend_theta => tend % theta_m % array
tend_scalars => tend % scalars % array
+!initialize the tendency for the potential temperature and all scalars due to PBL, convection,
+!and longwave and shortwave radiation:
+ allocate(theta(nVertLevels,nCellsSolve) )
+ allocate(tend_th(nVertLevels,nCellsSolve))
+ tend_th = 0.
tend_scalars = 0.
!add coupled tendencies due to PBL processes:
@@ -96,24 +105,25 @@
tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i)
enddo
enddo
-
deallocate(rublten_Edge)
do i = 1, nCellsSolve
do k = 1, nVertLevels
- tend_theta(k,i)=tend_theta(k,i)+rthblten(k,i)*mass(k,i)
+ tend_th(k,i) = tend_th(k,i)+rthblten(k,i)*mass(k,i)
tend_scalars(tend%index_qv,k,i)=tend_scalars(tend%index_qv,k,i)+rqvblten(k,i)*mass(k,i)
tend_scalars(tend%index_qc,k,i)=tend_scalars(tend%index_qc,k,i)+rqcblten(k,i)*mass(k,i)
tend_scalars(tend%index_qi,k,i)=tend_scalars(tend%index_qi,k,i)+rqiblten(k,i)*mass(k,i)
enddo
enddo
endif
+ write(0,*) 'max rthblten = ',maxval(rthblten(:,1:nCellsSolve))
+ write(0,*) 'min rthblten = ',minval(rthblten(:,1:nCellsSolve))
!add coupled tendencies due to convection:
if(config_conv_deep_scheme .ne. 'off') then
do i = 1, nCellsSolve
do k = 1, nVertLevels
- tend_theta(k,i)=tend_theta(k,i)+rthcuten(k,i)*mass(k,i)
+ tend_th(k,i)=tend_th(k,i)+rthcuten(k,i)*mass(k,i)
tend_scalars(tend%index_qv,k,i)=tend_scalars(tend%index_qv,k,i)+rqvcuten(k,i)*mass(k,i)
tend_scalars(tend%index_qc,k,i)=tend_scalars(tend%index_qc,k,i)+rqccuten(k,i)*mass(k,i)
tend_scalars(tend%index_qr,k,i)=tend_scalars(tend%index_qr,k,i)+rqrcuten(k,i)*mass(k,i)
@@ -122,64 +132,55 @@
enddo
enddo
endif
+ write(0,*) 'max rthcuten = ',maxval(rthcuten(:,1:nCellsSolve))
+ write(0,*) 'min rthcuten = ',minval(rthcuten(:,1:nCellsSolve))
!add coupled tendencies due to longwave radiation:
if(config_radt_lw_scheme .ne. 'off') then
do i = 1, nCellsSolve
do k = 1, nVertLevels
- tend_theta(k,i)=tend_theta(k,i)+rthratenlw(k,i)*mass(k,i)
+ tend_th(k,i)=tend_th(k,i)+rthratenlw(k,i)*mass(k,i)
enddo
enddo
endif
+ write(0,*) 'max rthratenlw = ',maxval(rthratenlw(:,1:nCellsSolve))
+ write(0,*) 'min rthratenlw = ',minval(rthratenlw(:,1:nCellsSolve))
!add coupled tendencies due to shortwave radiation:
if(config_radt_sw_scheme .ne. 'off') then
do i = 1, nCellsSolve
do k = 1, nVertLevels
- tend_theta(k,i)=tend_theta(k,i)+rthratensw(k,i)*mass(k,i)
+ tend_th(k,i)=tend_th(k,i)+rthratensw(k,i)*mass(k,i)
enddo
enddo
endif
+ write(0,*) 'max rthratensw = ',maxval(rthratensw(:,1:nCellsSolve))
+ write(0,*) 'min rthratensw = ',minval(rthratensw(:,1:nCellsSolve))
!if non-hydrostatic core, convert the tendency for the potential temperature to a
!tendency for the modified potential temperature:
#ifdef non_hydrostatic_core
do i = 1, nCellsSolve
do k = 1, nVertLevels
-
theta(k,i) = theta_m(k,i) / (1. + R_v/R_d * qv(k,i))
- tend_theta(k,i) = (1. + R_v/R_d * qv(k,i)) * tend_theta(k,i) &
+ tend_th(k,i) = (1. + R_v/R_d * qv(k,i)) * tend_th(k,i) &
+ R_v/R_d * theta(k,i) * tend_scalars(tend%index_qv,k,i)
+ tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i)
enddo
- enddo
+ enddo
+#elif hydrostatic_core
+ do i = 1, nCellsSolve
+ do k = 1, nVertLevels
+ tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i)
+ enddo
+ enddo
#endif
+ deallocate(theta)
+ deallocate(tend_th)
-!write(0,*) 'max PBL tendencies:'
-!write(0,*) 'max rthblten=',maxval(rthblten(:,:))
-!write(0,*) 'max rqvblten=',maxval(rqvblten(:,:))
-!write(0,*) 'max rqcblten=',maxval(rqcblten(:,:))
-!write(0,*) 'max rqiblten=',maxval(rqiblten(:,:))
-!write(0,*) 'max rublten =',maxval(rublten(:,:))
-!write(0,*) 'max rvblten =',maxval(rvblten(:,:))
-!write(0,*)
-!write(0,*) 'max CU tendencies:'
-!write(0,*) 'max rthcuten=',maxval(rthcuten(:,:))
-!write(0,*) 'max rqvcuten=',maxval(rqvcuten(:,:))
-!write(0,*) 'max rqccuten=',maxval(rqccuten(:,:))
-!write(0,*) 'max rqrcuten=',maxval(rqrcuten(:,:))
-!write(0,*) 'max rqicuten=',maxval(rqicuten(:,:))
-!write(0,*) 'max rqscuten=',maxval(rqscuten(:,:))
-!write(0,*)
-!write(0,*) 'max tend_scalars:'
-!write(0,*) 'max tend qv=',maxval(tend_scalars(tend%index_qv,:,:))
-!write(0,*) 'max tend qc=',maxval(tend_scalars(tend%index_qc,:,:))
-!write(0,*) 'max tend qr=',maxval(tend_scalars(tend%index_qr,:,:))
-!write(0,*) 'max tend qi=',maxval(tend_scalars(tend%index_qi,:,:))
-!write(0,*) 'max tend qs=',maxval(tend_scalars(tend%index_qs,:,:))
-!write(0,*)
-
!formats:
- 201 format(2i6,8(1x,e15.8))
+ 201 format(2i6,10(1x,e15.8))
+ 202 format(3i6,10(1x,e15.8))
end subroutine physics_addtend
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_update.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_update.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_update.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -4,10 +4,12 @@
use mpas_grid_types
use mpas_atmphys_driver_convection_deep
+ use mpas_atmphys_vars
implicit none
private
- public:: physics_update
+ public:: physics_update, &
+ update_radiation_diagnostics
contains
@@ -31,7 +33,7 @@
do while(associated(block))
!parameterization of convection: update accumulated precipitation.
- call update_convection_deep(dt,block%mesh,block%diag_physics)
+ !call update_convection_deep(dt,config_bucket_rainc,block%mesh,block%diag_physics)
block => block % next
end do
@@ -40,5 +42,117 @@
end subroutine physics_update
!=============================================================================================
+ subroutine update_radiation_diagnostics(bucket_radt,mesh,diag)
+!=============================================================================================
+
+!input arguments:
+ real(kind=RKIND),intent(in):: bucket_radt
+ type(mesh_type),intent(in):: mesh
+
+!inout arguments:
+ type(diag_physics_type),intent(inout):: diag
+
+!local variables:
+ integer:: iCell
+
+!--------------------------------------------------------------------------------------------
+
+ do iCell = 1, mesh%nCellsSolve
+ !short-wave radiation:
+ diag%acswdnb %array(iCell) = diag%acswdnb %array(iCell) + diag%swdnb %array(iCell)*dt_dyn
+ diag%acswdnbc%array(iCell) = diag%acswdnbc%array(iCell) + diag%swdnbc%array(iCell)*dt_dyn
+ diag%acswdnt %array(iCell) = diag%acswdnt %array(iCell) + diag%swdnt %array(iCell)*dt_dyn
+ diag%acswdntc%array(iCell) = diag%acswdntc%array(iCell) + diag%swdntc%array(iCell)*dt_dyn
+ diag%acswupb %array(iCell) = diag%acswupb %array(iCell) + diag%swupb %array(iCell)*dt_dyn
+ diag%acswupbc%array(iCell) = diag%acswupbc%array(iCell) + diag%swupbc%array(iCell)*dt_dyn
+ diag%acswupt %array(iCell) = diag%acswupt %array(iCell) + diag%swupt %array(iCell)*dt_dyn
+ diag%acswuptc%array(iCell) = diag%acswuptc%array(iCell) + diag%swuptc%array(iCell)*dt_dyn
+ !long-wave radiation:
+ diag%aclwdnb %array(iCell) = diag%aclwdnb %array(iCell) + diag%lwdnb %array(iCell)*dt_dyn
+ diag%aclwdnbc%array(iCell) = diag%aclwdnbc%array(iCell) + diag%lwdnbc%array(iCell)*dt_dyn
+ diag%aclwdnt %array(iCell) = diag%aclwdnt %array(iCell) + diag%lwdnt %array(iCell)*dt_dyn
+ diag%aclwdntc%array(iCell) = diag%aclwdntc%array(iCell) + diag%lwdntc%array(iCell)*dt_dyn
+ diag%aclwupb %array(iCell) = diag%aclwupb %array(iCell) + diag%lwupb %array(iCell)*dt_dyn
+ diag%aclwupbc%array(iCell) = diag%aclwupbc%array(iCell) + diag%lwupbc%array(iCell)*dt_dyn
+ diag%aclwupt %array(iCell) = diag%aclwupt %array(iCell) + diag%lwupt %array(iCell)*dt_dyn
+ diag%aclwuptc%array(iCell) = diag%aclwuptc%array(iCell) + diag%lwuptc%array(iCell)*dt_dyn
+ enddo
+
+ if(l_acradt .and. bucket_radt.gt.0._RKIND) then
+
+ do iCell = 1, mesh%nCellsSolve
+ !short-wave radiation:
+ if(diag%acswdnb%array(iCell) .gt. bucket_radt) then
+ diag%i_acswdnb%array(iCell) = diag%i_acswdnb%array(iCell) + 1
+ diag%acswdnb%array(iCell) = diag%acswdnb%array(iCell) - bucket_radt
+ endif
+ if(diag%acswdnbc%array(iCell) .gt. bucket_radt) then
+ diag%i_acswdnbc%array(iCell) = diag%i_acswdnbc%array(iCell) + 1
+ diag%acswdnbc%array(iCell) = diag%acswdnbc%array(iCell) - bucket_radt
+ endif
+ if(diag%acswdnt%array(iCell) .gt. bucket_radt) then
+ diag%i_acswdnt%array(iCell) = diag%i_acswdnt%array(iCell) + 1
+ diag%acswdnt%array(iCell) = diag%acswdnt%array(iCell) - bucket_radt
+ endif
+ if(diag%acswdntc%array(iCell) .gt. bucket_radt) then
+ diag%i_acswdntc%array(iCell) = diag%i_acswdntc%array(iCell) + 1
+ diag%acswdntc%array(iCell) = diag%acswdntc%array(iCell) - bucket_radt
+ endif
+ if(diag%acswupb%array(iCell) .gt. bucket_radt) then
+ diag%i_acswupb%array(iCell) = diag%i_acswupb%array(iCell) + 1
+ diag%acswupb%array(iCell) = diag%acswupb%array(iCell) - bucket_radt
+ endif
+ if(diag%acswupbc%array(iCell) .gt. bucket_radt) then
+ diag%i_acswupbc%array(iCell) = diag%i_acswupbc%array(iCell) + 1
+ diag%acswupbc%array(iCell) = diag%acswupbc%array(iCell) - bucket_radt
+ endif
+ if(diag%acswupt%array(iCell) .gt. bucket_radt) then
+ diag%i_acswupt%array(iCell) = diag%i_acswupt%array(iCell) + 1
+ diag%acswupt%array(iCell) = diag%acswupt%array(iCell) - bucket_radt
+ endif
+ if(diag%acswuptc%array(iCell) .gt. bucket_radt) then
+ diag%i_acswuptc%array(iCell) = diag%i_acswuptc%array(iCell) + 1
+ diag%acswuptc%array(iCell) = diag%acswuptc%array(iCell) - bucket_radt
+ endif
+ !long-wave radiation:
+ if(diag%aclwdnb%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwdnb%array(iCell) = diag%i_aclwdnb%array(iCell) + 1
+ diag%aclwdnb%array(iCell) = diag%aclwdnb%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwdnbc%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwdnbc%array(iCell) = diag%i_aclwdnbc%array(iCell) + 1
+ diag%aclwdnbc%array(iCell) = diag%aclwdnbc%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwdnt%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwdnt%array(iCell) = diag%i_aclwdnt%array(iCell) + 1
+ diag%aclwdnt%array(iCell) = diag%aclwdnt%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwdntc%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwdntc%array(iCell) = diag%i_aclwdntc%array(iCell) + 1
+ diag%aclwdntc%array(iCell) = diag%aclwdntc%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwupb%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwupb%array(iCell) = diag%i_aclwupb%array(iCell) + 1
+ diag%aclwupb%array(iCell) = diag%aclwupb%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwupbc%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwupbc%array(iCell) = diag%i_aclwupbc%array(iCell) + 1
+ diag%aclwupbc%array(iCell) = diag%aclwupbc%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwupt%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwupt%array(iCell) = diag%i_aclwupt%array(iCell) + 1
+ diag%aclwupt%array(iCell) = diag%aclwupt%array(iCell) - bucket_radt
+ endif
+ if(diag%aclwuptc%array(iCell) .gt. bucket_radt) then
+ diag%i_aclwuptc%array(iCell) = diag%i_aclwuptc%array(iCell) + 1
+ diag%aclwuptc%array(iCell) = diag%aclwuptc%array(iCell) - bucket_radt
+ endif
+ enddo
+
+ endif
+
+ end subroutine update_radiation_diagnostics
+
+!=============================================================================================
end module mpas_atmphys_update
!=============================================================================================
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_update_surface.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_update_surface.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_update_surface.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -128,6 +128,12 @@
sfc_emibck => diag_physics % sfc_emibck % array
xicem => diag_physics % xicem % array
+ write(0,*)
+ write(0,*) 'max sst =',maxval(sst(1:nCellsSolve))
+ write(0,*) 'min sst =',minval(sst(1:nCellsSolve))
+ write(0,*) 'max xice =',maxval(xice(1:nCellsSolve))
+ write(0,*) 'min xice =',minval(xice(1:nCellsSolve))
+
do iCell = 1, nCellsSolve
!update the skin temperature and the temperature in the first soil layer to the updated
@@ -236,8 +242,8 @@
real(kind=RKIND),dimension(:),pointer:: dtw1,emiss,ust
!---------------------------------------------------------------------------------------------
- write(0,*)
- write(0,*) '--- enter subroutine physics_update_sstskin:'
+!write(0,*)
+!write(0,*) '--- enter subroutine physics_update_sstskin:'
nCellsSolve = mesh % nCellsSolve
@@ -349,14 +355,16 @@
!local variables:
integer:: iCell,iLag,n,nCellsSolve,nLags
- integer,dimension(:),pointer:: nsteps_accum,ndays_accum
real(kind=RKIND),parameter:: tconst = 0.6
real(kind=RKIND):: deltat,julian,tprior,yrday
+ real(kind=RKIND),dimension(:),pointer:: nsteps_accum,ndays_accum
real(kind=RKIND),dimension(:),pointer :: tday_accum,tmn,tsk,tyear_accum,tyear_mean
real(kind=RKIND),dimension(:,:),pointer:: tlag
!---------------------------------------------------------------------------------------------
+!write(0,*)
+!write(0,*) '--- enter subroutine physics_update_deepsoiltemp:'
nCellsSolve = mesh % nCellsSolve
nLags = mesh % nLags
@@ -380,26 +388,27 @@
!... accumulate the skin temperature for current day:
do iCell = 1, nCellsSolve
- tday_accum(iCell) = tday_accum(iCell) + tsk(iCell)
+ tday_accum(iCell) = tday_accum(iCell) + tsk(iCell)*dt
+! tday_accum(iCell) = tday_accum(iCell) + tsk(iCell)
nsteps_accum(iCell) = nsteps_accum(iCell) + dt
+! nsteps_accum(iCell) = nsteps_accum(iCell) + 1
enddo
!... update the deep soil temperature at the end of the day:
deltat = (julian_in-nint(julian_in))*24.*3600.
- write(0,*)
- write(0,*) 'yrday = ',yrday
- write(0,*) 'julian_in = ',julian_in
- write(0,*) 'nint(julian_in)= ',nint(julian_in)
- write(0,*) 'deltat = ',deltat
- write(0,*) 'nint(deltat)-dt= ',nint(deltat) .lt. dt
+!write(0,*) '--- yrday = ',yrday
+!write(0,*) '--- julian_in = ',julian_in
+!write(0,*) '--- nint(julian_in)= ',nint(julian_in)
+!write(0,*) '--- deltat = ',deltat
+!write(0,*) '--- nint(deltat)-dt= ',nint(deltat) .lt. dt
if(abs(deltat) .le. dt/2) then
- write(0,*) '--- end of day: update deep soil temperature'
julian = julian_in - 1. + dt/(3600.*24.)
do iCell = 1, nCellsSolve
+!--- update tmn:
tprior = 0.
do iLag = 1, nLags
tprior = tprior + tlag(iLag,iCell)
@@ -407,21 +416,22 @@
tprior = tprior / nLags
tmn(iCell) = tconst*tyear_mean(iCell) + (1-tconst)*tprior
+!--- update tlag:
do iLag = 1, nLags-1
tlag(iLag,iCell) = tlag(iLag+1,iCell)
enddo
tlag(nLags,iCell) = tday_accum(iCell) / nsteps_accum(iCell)
tday_accum(iCell) = 0.0
- nsteps_accum(iCell) = 0.0
+ nsteps_accum(iCell) = 0.0
!... end of year:
if(yrday-julian .le. 1.) then
tyear_mean(iCell) = tyear_accum(iCell) / ndays_accum(iCell)
tyear_accum(iCell) = 0.
- ndays_accum(iCell) = 0
+ ndays_accum(iCell) = 0.0
else
tyear_accum(iCell) = tyear_accum(iCell) + tlag(nLags,iCell)
- ndays_accum(iCell) = ndays_accum(iCell) + 1
+ ndays_accum(iCell) = ndays_accum(iCell) + 1.
endif
enddo
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_vars.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_vars.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/mpas_atmphys_vars.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,7 @@
!=============================================================================================
module mpas_atmphys_vars
+
+ use mpas_kind_types
implicit none
public
@@ -25,14 +27,18 @@
!=============================================================================================
logical:: l_radtlw !controls call to longwave radiation parameterization.
- logical:: l_radtsw !controls call to shortwave parameterization.
+ logical:: l_radtsw !controls call to shortwave radiation parameterization.
+ logical:: l_conv !controls call to convective parameterization.
+ logical:: l_camlw !controls when to save local CAM LW abs and ems arrays.
+ logical:: l_acrain !when .true., limit to accumulated rain is applied.
+ logical:: l_acradt !when .true., limit to lw and sw radiation is applied.
integer,public:: ids,ide,jds,jde,kds,kde
integer,public:: ims,ime,jms,jme,kms,kme
integer,public:: its,ite,jts,jte,kts,kte
integer,public:: n_microp
- integer,public:: num_months !number of months [-]
+ integer,public:: num_months !number of months [-]
real(kind=RKIND),public:: dt_dyn !time-step for dynamics
real(kind=RKIND),public:: dt_microp !time-step for cloud microphysics parameterization.
@@ -41,16 +47,23 @@
real(kind=RKIND),public:: xice_threshold
+ real(kind=RKIND),dimension(:),allocatable:: &
+ znu_p
+
real(kind=RKIND),dimension(:,:),allocatable:: &
- area_p !grid cell area [m2]
+ area_p !grid cell area [m2]
!... arrays related to surface:
real(kind=RKIND),dimension(:,:),allocatable:: &
psfc_p, &!surface pressure [Pa]
ptop_p !model-top pressure [Pa]
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
+ fzm_p, &!weight for interpolation to w points [-]
+ fzp_p !weight for interpolation to w points [-]
+
+ real(kind=RKIND),dimension(:,:,:),allocatable:: &
!... arrays related to u- and v-velocities interpolated to theta points:
- real(kind=RKIND),dimension(:,:,:),allocatable:: &
u_p, &!u-velocity interpolated to theta points [m/s]
v_p !v-velocity interpolated to theta points [m/s]
@@ -60,6 +73,7 @@
pres_p, &!pressure [Pa]
pi_p, &!(p_phy/p0)**(r_d/cp) [-]
z_p, &!height of layer [m]
+ zmid_p, &!height of middle of layer [m]
dz_p, &!layer thickness [m]
t_p, &!temperature [K]
th_p, &!potential temperature [K]
@@ -68,10 +82,6 @@
rh_p !relative humidity [-]
real(kind=RKIND),dimension(:,:,:),allocatable:: &
- pres_hyd_p, &!hydrostatic pressure at theta points [Pa]
- pres2_hyd_p !hydrostatic pressure at w points [Pa]
-
- real(kind=RKIND),dimension(:,:,:),allocatable:: &
qv_p, &!water vapor mixing ratio [kg/kg]
qc_p, &!cloud water mixing ratio [kg/kg]
qr_p, &!rain mixing ratio [kg/kg]
@@ -135,23 +145,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:
!=============================================================================================
@@ -323,6 +347,7 @@
integer,public:: &
num_soils !number of soil layers [-]
+
integer,dimension(:,:),allocatable:: &
isltyp_p, &!dominant soil type category [-]
ivgtyp_p !dominant vegetation category [-]
Modified: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/module_cam_support.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/module_cam_support.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/module_cam_support.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F (from rev 1731, trunk/mpas/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_atmos_physics/physics_wrf/module_cu_tiedtke.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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: branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/Registry
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/Registry 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/Registry 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,10 +1,10 @@
-#
-# namelist type namelist_record name default_value
-#
+%
+% namelist type namelist_record name default_value
+%
namelist integer sw_model config_test_case 5
namelist character sw_model config_time_integration SRK3
namelist real sw_model config_dt 172.8
-namelist integer sw_model config_calendar_type MPAS_360DAY
+namelist character sw_model config_calendar_type 360day
namelist character sw_model config_start_time 0000-01-01_00:00:00
namelist character sw_model config_stop_time none
namelist character sw_model config_run_duration none
@@ -33,9 +33,9 @@
namelist logical restart config_do_restart false
namelist character restart config_restart_interval none
-#
-# dim type name_in_file name_in_code
-#
+%
+% dim type name_in_file name_in_code
+%
dim nCells nCells
dim nEdges nEdges
dim maxEdges maxEdges
@@ -46,14 +46,14 @@
dim FIFTEEN 15
dim TWENTYONE 21
dim R3 3
-#dim nVertLevels nVertLevels
+%dim nVertLevels nVertLevels
dim nVertLevels namelist:config_nvertlevels
-#dim nTracers nTracers
+%dim nTracers nTracers
dim nVertLevelsP1 nVertLevels+1
-#
-# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
-#
+%
+% var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
+%
var persistent text xtime ( Time ) 2 ro xtime state - -
var persistent real latCell ( nCells ) 0 iro latCell mesh - -
@@ -104,7 +104,7 @@
var persistent real fVertex ( nVertices ) 0 iro fVertex mesh - -
var persistent real h_s ( nCells ) 0 iro h_s mesh - -
-# description of the vertical grid structure
+% description of the vertical grid structure
var persistent real rdnu ( nVertLevels ) 0 iro rdnu mesh - -
var persistent real rdnw ( nVertLevels ) 0 iro rdnw mesh - -
var persistent real fnm ( nVertLevels ) 0 iro fnm mesh - -
@@ -113,16 +113,16 @@
var persistent real dnu ( nVertLevels ) 0 iro dnu mesh - -
var persistent real dnw ( nVertLevels ) 0 iro dnw mesh - -
-# Prognostic variables: read from input, saved in restart, and written to output
+% Prognostic variables: read from input, saved in restart, and written to output
var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
var persistent real theta ( nVertLevels nCells Time ) 2 iro theta state - -
var persistent real surface_pressure ( nCells Time ) 2 iro surface_pressure state - -
var persistent real qv ( nVertLevels nCells Time ) 2 iro qv state scalars moist
var persistent real qc ( nVertLevels nCells Time ) 2 iro qc state scalars moist
var persistent real qr ( nVertLevels nCells Time ) 2 iro qr state scalars moist
-#var persistent real tracers ( nTracers nVertLevels nCells Time ) 2 iro state tracers - -
+%var persistent real tracers ( nTracers nVertLevels nCells Time ) 2 iro state tracers - -
-# state variables diagnosed from prognostic state
+% state variables diagnosed from prognostic state
var persistent real h ( nVertLevels nCells Time ) 2 ro h state - -
var persistent real ww ( nVertLevelsP1 nCells Time ) 2 ro ww state - -
var persistent real w ( nVertLevelsP1 nCells Time ) 2 ro w state - -
@@ -130,7 +130,7 @@
var persistent real geopotential ( nVertLevelsP1 nCells Time ) 2 ro geopotential state - -
var persistent real alpha ( nVertLevels nCells Time ) 2 iro alpha state - -
-# Diagnostic fields: only written to output
+% Diagnostic fields: only written to output
var persistent real v ( nVertLevels nEdges Time ) 2 o v state - -
var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
@@ -145,7 +145,7 @@
var persistent real uReconstructZonal ( nVertLevels nCells Time ) 1 o uReconstructZonal diag - -
var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 1 o uReconstructMeridional diag - -
-# Tendency variables
+% Tendency variables
var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
var persistent real tend_vh ( nVertLevels nEdges Time ) 1 - vh tend - -
@@ -154,7 +154,7 @@
var persistent real tend_qc ( nVertLevels nCells Time ) 1 - qc tend scalars moist
var persistent real tend_qr ( nVertLevels nCells Time ) 1 - qr tend scalars moist
-# Other diagnostic variables: neither read nor written to any files
+% Other diagnostic variables: neither read nor written to any files
var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
@@ -176,12 +176,12 @@
var persistent real qv_old ( nVertLevels nCells ) 0 - qv_old mesh scalars_old moist_old
var persistent real qc_old ( nVertLevels nCells ) 0 - qc_old mesh scalars_old moist_old
var persistent real qr_old ( nVertLevels nCells ) 0 - qr_old mesh scalars_old moist_old
-#var persistent real tracers_old ( nTracers nVertLevels nCells ) 0 - tracers_old mesh - -
+%var persistent real tracers_old ( nTracers nVertLevels nCells ) 0 - tracers_old mesh - -
-# Space needed for advection
+% Space needed for advection
var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 o deriv_two mesh - -
var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
-# Arrays required for reconstruction of velocity field
+% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
Modified: branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_advection.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_advection.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_advection.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,6 @@
module atmh_advection
+ use mpas_kind_types
use mpas_grid_types
use mpas_configure
use mpas_constants
@@ -116,7 +117,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -335,7 +336,7 @@
! Computes the angle between arcs AB and AC, given points A, B, and C
! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+ real (kind=RKIND) function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
implicit none
@@ -355,9 +356,9 @@
real (kind=RKIND) :: s ! Semiperimeter of the triangle
real (kind=RKIND) :: sin_angle
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1)
ABx = bx - ax
ABy = by - ay
@@ -373,12 +374,12 @@
s = 0.5*(a + b + c)
! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.0_RKIND,max(0.0_RKIND,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
end if
end function sphere_angle
@@ -390,7 +391,7 @@
! Computes the angle between vectors AB and AC, given points A, B, and C, and
! a vector (u,v,w) normal to the plane.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+ real (kind=RKIND) function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
implicit none
@@ -425,9 +426,9 @@
cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = -acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
end if
end function plane_angle
@@ -440,7 +441,7 @@
! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
! same sphere centered at the origin.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
+ real (kind=RKIND) function arc_length(ax, ay, az, bx, by, bz)
implicit none
@@ -575,7 +576,7 @@
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
-SUBROUTine MIGS (A,N,X,INDX)
+SUBROUTINE MIGS (A,N,X,INDX)
!
! Subroutine to invert matrix A(N,N) with the inverse stored
! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
@@ -617,7 +618,7 @@
X(J,I) = X(J,I)/A(INDX(J),J)
END DO
END DO
-END SUBROUTine MIGS
+END SUBROUTINE MIGS
SUBROUTINE ELGS (A,N,INDX)
@@ -646,7 +647,7 @@
DO I = 1, N
C1= 0.0
DO J = 1, N
- C1 = AMAX1(C1,ABS(A(I,J)))
+ C1 = MAX(C1,ABS(A(I,J)))
END DO
C(I) = C1
END DO
Modified: branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_test_cases.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_test_cases.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_test_cases.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -258,7 +258,7 @@
if (config_test_case == 2) then
r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
- lat_pert, lon_pert, 1.)/(pert_radius)
+ lat_pert, lon_pert, 1.0_RKIND)/(pert_radius)
u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
else if (config_test_case == 3) then
@@ -468,7 +468,7 @@
end subroutine atmh_test_case_1
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
! sphere with given radius.
@@ -487,7 +487,7 @@
end function sphere_distance
- real function AA(theta)
+ real (kind=RKIND) function AA(theta)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! A, used in height field computation for Rossby-Haurwitz wave
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -506,7 +506,7 @@
end function AA
- real function BB(theta)
+ real (kind=RKIND) function BB(theta)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! B, used in height field computation for Rossby-Haurwitz wave
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -524,7 +524,7 @@
end function BB
- real function CC(theta)
+ real (kind=RKIND) function CC(theta)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! C, used in height field computation for Rossby-Haurwitz wave
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Modified: branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_time_integration.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_time_integration.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_hyd_atmos/mpas_atmh_time_integration.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1652,9 +1652,9 @@
! add in vertical flux to get max and min estimate
s_max_update(iScalar) = s_max_update(iScalar) &
- - rdnw(k) * (max(0.,v_flux(iScalar,iCell,km0)) - min(0.,v_flux(iScalar,iCell,km1)))
+ - rdnw(k) * (max(0.0_RKIND,v_flux(iScalar,iCell,km0)) - min(0.0_RKIND,v_flux(iScalar,iCell,km1)))
s_min_update(iScalar) = s_min_update(iScalar) &
- - rdnw(k) * (min(0.,v_flux(iScalar,iCell,km0)) - max(0.,v_flux(iScalar,iCell,km1)))
+ - rdnw(k) * (min(0.0_RKIND,v_flux(iScalar,iCell,km0)) - max(0.0_RKIND,v_flux(iScalar,iCell,km1)))
end do
@@ -1671,8 +1671,8 @@
fdir = -1.0
end if
flux = -fdir * h_flux(iScalar,iEdge)/grid % areaCell % array(iCell)
- s_max_update(iScalar) = s_max_update(iScalar) + max(0.,flux)
- s_min_update(iScalar) = s_min_update(iScalar) + min(0.,flux)
+ s_max_update(iScalar) = s_max_update(iScalar) + max(0.0_RKIND,flux)
+ s_min_update(iScalar) = s_min_update(iScalar) + min(0.0_RKIND,flux)
end do
@@ -1687,9 +1687,9 @@
s_min_update (iScalar) = s_min_update (iScalar) / h_new (k,iCell)
s_upwind = s_update(iScalar,iCell,km0) / h_new(k,iCell)
if ( s_max_update(iScalar) > s_max(iScalar) .and. config_monotonic) &
- scale_in (iScalar,iCell,km0) = max(0.,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
+ scale_in (iScalar,iCell,km0) = max(0.0_RKIND,(s_max(iScalar)-s_upwind)/(s_max_update(iScalar)-s_upwind+eps))
if ( s_min_update(iScalar) < s_min(iScalar) ) &
- scale_out (iScalar,iCell,km0) = max(0.,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
+ scale_out (iScalar,iCell,km0) = max(0.0_RKIND,(s_upwind-s_min(iScalar))/(s_upwind-s_min_update(iScalar)+eps))
end do
end do ! end loop over cells to compute scale factor
Modified: branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/Registry
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/Registry 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/Registry 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,32 +1,32 @@
-#
-# namelist type namelist_record name default_value
-#
-namelist integer nhyd_model config_test_case 5
-namelist integer nhyd_model config_calendar_type MPAS_GREGORIAN
+%
+% namelist type namelist_record name default_value
+%
+namelist integer nhyd_model config_test_case 7
+namelist character nhyd_model config_calendar_type gregorian
namelist character nhyd_model config_start_time none
namelist character nhyd_model config_stop_time none
-namelist integer nhyd_model config_theta_adv_order 2
-namelist real nhyd_model config_coef_3rd_order 1.0
+namelist integer nhyd_model config_theta_adv_order 3
+namelist real nhyd_model config_coef_3rd_order 0.25
namelist integer dimensions config_nvertlevels 26
namelist integer dimensions config_nsoillevels 4
namelist integer dimensions config_nfglevels 27
namelist integer dimensions config_nfgsoillevels 4
-namelist character data_sources config_geog_data_path /data3/mp/wrfhelp/WPS_GEOG/
+namelist integer dimensions config_months 12
+namelist character data_sources config_geog_data_path /mmm/users/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 real vertical_grid config_ztop 28000.0
namelist integer vertical_grid config_nsmterrain 2
-namelist logical vertical_grid config_smooth_surfaces true
+namelist logical vertical_grid config_smooth_surfaces false
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
namelist character io config_sfc_update_name sfc_update.nc
-namelist character io config_output_name output.nc
+namelist character io config_output_name init.nc
namelist character io config_restart_name restart.nc
namelist character io config_decomp_file_prefix graph.info.part.
namelist integer io config_frames_per_outfile 0
@@ -37,9 +37,9 @@
namelist real restart config_restart_time 172800.0
-#
-# dim type name_in_file name_in_code
-#
+%
+% dim type name_in_file name_in_code
+%
dim nCells nCells
dim nEdges nEdges
dim maxEdges maxEdges
@@ -56,15 +56,15 @@
dim nFGLevels namelist:config_nfglevels
dim nFGSoilLevels namelist:config_nfgsoillevels
dim nVertLevelsP1 nVertLevels+1
-dim nMonths 12
+dim nMonths namelist:config_months
dim Scalar 1
-#
-# var type name_in_file ( dims ) iro- name_in_code super-array array_class
-#
+%
+% var type name_in_file ( dims ) iro- name_in_code super-array array_class
+%
var persistent text xtime ( Time ) 2 so xtime state - -
-# horizontal grid structure
+% horizontal grid structure
var persistent real latCell ( nCells ) 0 io latCell mesh - -
var persistent real lonCell ( nCells ) 0 io lonCell mesh - -
@@ -115,14 +115,14 @@
var persistent real meshDensity ( nCells ) 0 iro meshDensity mesh - -
-# some solver scalar coefficients
+% some solver scalar coefficients
-# coefficients for vertical extrapolation to the surface
+% coefficients for vertical extrapolation to the surface
var persistent real cf1 ( Scalar ) 0 io cf1 mesh - -
var persistent real cf2 ( Scalar ) 0 io cf2 mesh - -
var persistent real cf3 ( Scalar ) 0 io cf3 mesh - -
-# static terrestrial fields
+% static terrestrial fields
var persistent real ter ( nCells ) 0 io ter mesh - -
var persistent integer landmask ( nCells ) 0 io landmask mesh - -
var persistent integer ivgtyp ( nCells ) 0 io lu_index mesh - -
@@ -135,7 +135,7 @@
var persistent real shdmax ( nCells ) 0 io shdmax mesh - -
var persistent real albedo12m ( nMonths nCells ) 0 io albedo12m mesh - -
-# description of the vertical grid structure
+% description of the vertical grid structure
var persistent real hx ( nVertLevelsP1 nCells ) 0 io hx mesh - -
var persistent real zgrid ( nVertLevelsP1 nCells ) 0 io zgrid mesh - -
@@ -146,16 +146,14 @@
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 - -
-# W-Rayleigh-damping coefficient
+% W-Rayleigh-damping coefficient
var persistent real dss ( nVertLevels nCells ) 0 io dss mesh - -
-# Horizontally interpolated from first-guess data
+% Horizontally interpolated from first-guess data
var persistent real u_fg ( nFGLevels nEdges Time ) 1 - u fg - -
var persistent real v_fg ( nFGLevels nEdges Time ) 1 - v fg - -
var persistent real t_fg ( nFGLevels nCells Time ) 1 - t fg - -
@@ -166,21 +164,22 @@
var persistent real psfc_fg ( nCells Time ) 1 - psfc fg - -
var persistent real pmsl_fg ( nCells Time ) 1 - pmsl fg - -
-# Horizontally interpolated from first-guess data
+% Horizontally interpolated from first-guess data
var persistent real dz_fg ( nFGSoilLevels nCells Time ) 1 io dz_fg fg - -
var persistent real dzs_fg ( nFGSoilLevels nCells Time ) 1 io dzs_fg fg - -
var persistent real zs_fg ( nFGSoilLevels nCells Time ) 1 io zs_fg fg - -
var persistent real st_fg ( nFGSoilLevels nCells Time ) 1 io st_fg fg - -
var persistent real sm_fg ( nFGSoilLevels nCells Time ) 1 io sm_fg fg - -
-# Horizontally interpolated from first-guess data
-# and should be read in by model
+% Horizontally interpolated from first-guess data
+% and should be read in by model
var persistent real dz ( nSoilLevels nCells Time ) 1 io dz fg - -
var persistent real dzs ( nSoilLevels nCells Time ) 1 io dzs fg - -
var persistent real zs ( nSoilLevels nCells Time ) 1 io zs fg - -
var persistent real sh2o ( nSoilLevels nCells Time ) 1 io sh2o fg - -
var persistent real smois ( nSoilLevels nCells Time ) 1 io smois fg - -
var persistent real tslb ( nSoilLevels nCells Time ) 1 io tslb fg - -
+var persistent real smcrel ( nSoilLevels nCells Time ) 1 io smcrel fg - -
var persistent real tmn ( nCells Time ) 1 io tmn fg - -
var persistent real skintemp ( nCells Time ) 1 io skintemp fg - -
var persistent real sst ( nCells Time ) 1 iso sst fg - -
@@ -194,7 +193,7 @@
var persistent real sfc_albbck ( nCells Time ) 1 io sfc_albbck fg - -
var persistent real xland ( nCells Time ) 1 io xland fg - -
-# Prognostic variables: read from input, saved in restart, and written to output
+% Prognostic variables: read from input, saved in restart, and written to output
var persistent real u ( nVertLevels nEdges Time ) 2 o u state - -
var persistent real w ( nVertLevelsP1 nCells Time ) 2 o w state - -
var persistent real rho_zz ( nVertLevels nCells Time ) 2 o rho_zz state - -
@@ -203,14 +202,14 @@
var persistent real qc ( nVertLevels nCells Time ) 2 o qc state scalars moist
var persistent real qr ( nVertLevels nCells Time ) 2 o qr state scalars moist
-# state variables diagnosed from prognostic state
+% state variables diagnosed from prognostic state
var persistent real pressure_p ( nVertLevels nCells Time ) 1 - pressure_p diag - -
var persistent real u_init ( nVertLevels ) 0 io u_init mesh - -
var persistent real t_init ( nVertLevels nCells ) 0 io t_init mesh - -
var persistent real qv_init ( nVertLevels ) 0 io qv_init mesh - -
-# Diagnostic fields: only written to output
+% Diagnostic fields: only written to output
var persistent real rho ( nVertLevels nCells Time ) 1 o rho diag - -
var persistent real theta ( nVertLevels nCells Time ) 1 o theta diag - -
var persistent real v ( nVertLevels nEdges Time ) 1 o v diag - -
@@ -230,22 +229,22 @@
var persistent real cqw ( nVertLevels nCells Time ) 1 - cqw diag - -
-var persistent real surface_pressure ( nCells Time ) 1 o surface_pressure diag - -
+var persistent real surface_pressure ( nCells Time ) 1 io surface_pressure diag - -
-# coupled variables needed by the solver, but not output...
+% coupled variables needed by the solver, but not output...
var persistent real ru ( nVertLevels nEdges Time ) 1 - ru diag - -
var persistent real rw ( nVertLevelsP1 nCells Time ) 1 - rw diag - -
var persistent real rtheta_p ( nVertLevels nCells Time ) 1 - rtheta_p diag - -
var persistent real rho_p ( nVertLevels nCells Time ) 1 - rho_p diag - -
-# Space needed for advection
+% Space needed for advection
var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 io deriv_two mesh - -
var persistent integer advCells ( TWENTYONE nCells ) 0 io advCells mesh - -
-# Space needed for deformation calculation weights
+% Space needed for deformation calculation weights
var persistent real defc_a ( maxEdges nCells ) 0 io defc_a mesh - -
var persistent real defc_b ( maxEdges nCells ) 0 io defc_b mesh - -
-# Arrays required for reconstruction of velocity field
+% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 io coeffs_reconstruct mesh - -
Modified: branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_hinterp.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_hinterp.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_hinterp.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -545,10 +545,10 @@
ify = floor(yy)
icy = ceiling(yy)
- fxfy = max(0., 1.0 - sqrt((xx-real(ifx))**2+(yy-real(ify))**2))
- fxcy = max(0., 1.0 - sqrt((xx-real(ifx))**2+(yy-real(icy))**2))
- cxfy = max(0., 1.0 - sqrt((xx-real(icx))**2+(yy-real(ify))**2))
- cxcy = max(0., 1.0 - sqrt((xx-real(icx))**2+(yy-real(icy))**2))
+ fxfy = max(0.0_RKIND, 1.0 - sqrt((xx-real(ifx))**2+(yy-real(ify))**2))
+ fxcy = max(0.0_RKIND, 1.0 - sqrt((xx-real(ifx))**2+(yy-real(icy))**2))
+ cxfy = max(0.0_RKIND, 1.0 - sqrt((xx-real(icx))**2+(yy-real(ify))**2))
+ cxcy = max(0.0_RKIND, 1.0 - sqrt((xx-real(icx))**2+(yy-real(icy))**2))
! First, make sure that the point is contained in the source array
if (ifx < start_x .or. icx > end_x .or. &
@@ -744,13 +744,13 @@
if (array(ifx+3-i, ify+3-j, izz) == msgval .or. mask_array(ifx+3-i, ify+3-j) == maskval) then
weights(i,j) = 0.0
else
- weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
+ weights(i,j) = max(0.0_RKIND, 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
end if
else
if (array(ifx+3-i, ify+3-j, izz) == msgval) then
weights(i,j) = 0.0
else
- weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
+ weights(i,j) = max(0.0_RKIND, 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
end if
end if
Modified: branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_llxy.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -130,6 +130,8 @@
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ USE MPAS_KIND_TYPES
+
INTEGER, PARAMETER :: HH=4, VV=5
REAL (KIND=RKIND), PARAMETER :: PI = 3.141592653589793
@@ -1154,10 +1156,10 @@
! intersects the Earth's surface at each of the distinctly different
! latitudes
IF (ABS(truelat1-truelat2) .GT. 0.1) THEN
- cone = ALOG10(COS(truelat1*rad_per_deg)) - &
- ALOG10(COS(truelat2*rad_per_deg))
- cone = cone /(ALOG10(TAN((45.0 - ABS(truelat1)/2.0) * rad_per_deg)) - &
- ALOG10(TAN((45.0 - ABS(truelat2)/2.0) * rad_per_deg)))
+ cone = LOG10(COS(truelat1*rad_per_deg)) - &
+ LOG10(COS(truelat2*rad_per_deg))
+ cone = cone /(LOG10(TAN((45.0 - ABS(truelat1)/2.0) * rad_per_deg)) - &
+ LOG10(TAN((45.0 - ABS(truelat2)/2.0) * rad_per_deg)))
ELSE
cone = SIN(ABS(truelat1)*rad_per_deg )
ENDIF
@@ -1220,9 +1222,9 @@
! Longitude
lon = proj%stdlon + deg_per_rad * ATAN2(proj%hemi*xx,yy)/proj%cone
# if ( defined (G95) && ( DA_CORE == 1 ) )
- lon = DMOD(lon+360., 360.)
+ lon = DMOD(lon+360., 360.0_RKIND)
# else
- lon = AMOD(lon+360., 360.)
+ lon = MOD(lon+360., 360.0_RKIND)
# endif
! Latitude. Latitude determined by solving an equation adapted
@@ -1323,7 +1325,7 @@
proj%rsw = 0.
IF (proj%lat1 .NE. 0.) THEN
- proj%rsw = (ALOG(TAN(0.5*((proj%lat1+90.)*rad_per_deg))))/proj%dlon
+ proj%rsw = (LOG(TAN(0.5*((proj%lat1+90.)*rad_per_deg))))/proj%dlon
ENDIF
RETURN
@@ -1347,7 +1349,7 @@
IF (deltalon .LT. -180.) deltalon = deltalon + 360.
IF (deltalon .GT. 180.) deltalon = deltalon - 360.
i = proj%knowni + (deltalon/(proj%dlon*deg_per_rad))
- j = proj%knownj + (ALOG(TAN(0.5*((lat + 90.) * rad_per_deg)))) / &
+ j = proj%knownj + (LOG(TAN(0.5*((lat + 90.) * rad_per_deg)))) / &
proj%dlon - proj%rsw
RETURN
@@ -1531,7 +1533,7 @@
! Try to determine whether this domain has global coverage
if (abs(proj%lat1 - proj%latinc/2. + 90.) < 0.001 .and. &
- abs(mod(proj%lon1 - proj%loninc/2. - proj%stdlon,360.)) < 0.001) then
+ abs(mod(proj%lon1 - proj%loninc/2. - proj%stdlon,360.0_RKIND)) < 0.001) then
global_domain = .true.
else
global_domain = .false.
Modified: branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_queue.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_queue.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_queue.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -7,6 +7,9 @@
module init_atm_queue
+ use mpas_kind_types
+
+
type q_data ! The user-defined datatype to store in the queue
real (kind=RKIND) :: lat, lon
integer :: x, y
Modified: branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_init_nhyd_atmos/mpas_init_atm_test_cases.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -5,12 +5,16 @@
use mpas_constants
use mpas_dmpar
use atm_advection
- use mpas_sort
- use mpas_timekeeping
-
use mpas_atmphys_initialize_real
+ use mpas_RBF_interpolation
+ use mpas_vector_reconstruction
+ ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping
+ use mpas_timekeeping !, only: MPAS_Time_type, MPAS_TimeInterval_type, MPAS_Clock_type, &
+ ! mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti
+
+
contains
@@ -30,17 +34,31 @@
integer :: i
type (block_type), pointer :: block_ptr
- if (config_test_case == 0) then
- write(0,*) ' Using initial conditions from input file'
- block_ptr => domain % blocklist
- do while (associated(block_ptr))
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
- block_ptr => block_ptr % next
- end do
- else if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
+
+ !
+ ! Do some quick checks to make sure compile options are compatible with the chosen test case
+ !
+ if (config_test_case == 6) then
+#ifndef ROTATED_GRID
+ write(0,*) '*** ERROR ***'
+ write(0,*) 'To initialize and run the mountain wave test case (case 6),'
+ write(0,*) ' you must compile with -DROTATE_GRID added to the specification'
+ write(0,*) ' of MODEL_FORMULATION at the top of the Makefile.'
+ call mpas_dmpar_abort(domain % dminfo)
+#endif
+ else
+#ifdef ROTATED_GRID
+ write(0,*) '*** ERROR ***'
+ write(0,*) 'Only test case 6 should use code compiled with -DROTATE_GRID specified in the Makefile.'
+ call mpas_dmpar_abort(domain % dminfo)
+#endif
+ end if
+
+
+
+ if ((config_test_case == 1) .or. (config_test_case == 2) .or. (config_test_case == 3)) then
+
write(0,*) ' Jablonowski and Williamson baroclinic wave test case '
if (config_test_case == 1) write(0,*) ' no initial perturbation '
if (config_test_case == 2) write(0,*) ' initial perturbation included '
@@ -49,11 +67,8 @@
do while (associated(block_ptr))
write(0,*) ' calling test case setup '
call init_atm_test_case_jw(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ call decouple_variables(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag)
write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
block_ptr => block_ptr % next
end do
@@ -66,11 +81,8 @@
do while (associated(block_ptr))
write(0,*) ' calling test case setup '
call init_atm_test_case_squall_line(domain % dminfo, block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ call decouple_variables(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag)
write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
block_ptr => block_ptr % next
end do
@@ -81,11 +93,8 @@
do while (associated(block_ptr))
write(0,*) ' calling test case setup '
call init_atm_test_case_mtn_wave(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag, config_test_case)
+ call decouple_variables(block_ptr % mesh, block_ptr % state % time_levs(1) % state, block_ptr % diag)
write(0,*) ' returned from test case setup '
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
block_ptr => block_ptr % next
end do
@@ -96,13 +105,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)
-
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
+ if (config_met_interp) call physics_initialize_real(block_ptr % mesh, block_ptr % fg)
block_ptr => block_ptr % next
end do
@@ -111,22 +114,37 @@
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)
- do i=2,nTimeLevs
- call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
- end do
-
block_ptr => block_ptr % next
end do
else
+ write(0,*) ' Only test cases 1, 2, 3, 4, 5, 6, 7, and 8 are currently supported for nonhydrostatic core '
+ stop
- write(0,*) ' Only test case 1, 2, 3, 4, 5, 6, and 7 are currently supported for nonhydrostatic core '
- stop
end if
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ do i=2,nTimeLevs
+ call mpas_copy_state(block_ptr % state % time_levs(i) % state, block_ptr % state % time_levs(1) % state)
+ end do
+ block_ptr => block_ptr % next
+ end do
+
+ !initialization of surface input variables technically not needed to run our current set of
+ !idealized test cases:
+ if (config_test_case < 7) then
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call physics_idealized_init(block_ptr % mesh, block_ptr % fg)
+ block_ptr => block_ptr % next
+ end do
+ endif
+
+
end subroutine init_atm_setup_test_case
!----------------------------------------------------------------------------------------------------------
@@ -141,6 +159,7 @@
type (mesh_type), intent(inout) :: grid
type (state_type), intent(inout) :: state
type (diag_type), intent(inout) :: diag
+ !type (diag_physics_type), intent(inout) :: diag_physics
integer, intent(in) :: test_case
real (kind=RKIND), parameter :: u0 = 35.0
@@ -150,15 +169,22 @@
real (kind=RKIND), parameter :: u_perturbation = 1., pert_radius = 0.1, latitude_pert = 40., longitude_pert = 20.
real (kind=RKIND), parameter :: theta_c = pii/4.0
real (kind=RKIND), parameter :: lambda_c = 3.0*pii/2.0
- real (kind=RKIND), parameter :: rh_max = 0.4 ! Maximum relative humidity
real (kind=RKIND), parameter :: k_x = 9. ! Normal mode wave number
real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp
+ real (kind=RKIND), dimension(:), pointer :: 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 :: scalars
+ real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+
+!.. initialization of moisture:
+ integer:: index_qv
+ real (kind=RKIND),parameter :: rh_max = 0.40 ! Maximum relative humidity
+! real (kind=RKIND),parameter :: rh_max = 0.70 ! Maximum relative humidity
+ real (kind=RKIND),dimension(grid % nVertLevels, grid % nCells) :: qsat, relhum
+ real (kind=RKIND),dimension(:,:,:),pointer:: scalars
+!.. end initialization of moisture.
integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
@@ -166,8 +192,8 @@
integer :: eoe, j
integer, dimension(:), pointer :: nEdgesOnEdge
integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
- real, dimension(:), pointer :: dvEdge, AreaCell
- real, dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
@@ -176,8 +202,7 @@
real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str
- real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rel_hum, temperature, qv
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, znut, ptemp
+ real (kind=RKIND) :: es, qvs, xnutr, znut, ptemp
integer :: iter
real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm
@@ -185,20 +210,23 @@
real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: sh, zw, ah
real (kind=RKIND), dimension(grid % nVertLevels ) :: zu, dzw, rdzwp, rdzwm
- real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt
+ real (kind=RKIND), dimension(grid % nVertLevels ) :: eta, etav, teta, ppi, tt, temperature_1d
real (kind=RKIND) :: d1, d2, d3, cf1, cf2, cf3, cof1, cof2, psurf
! storage for (lat,z) arrays for zonal velocity calculation
- integer, parameter :: nlat=361
- real (kind=RKIND), dimension(grid % nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d
+ logical, parameter :: rebalance = .true.
+ integer, parameter :: nlat=721
real (kind=RKIND), dimension(grid % nVertLevels) :: flux_zonal
- real (kind=RKIND), dimension(nlat, grid % nVertLevels) :: u_2d, etavs_2d
+ real (kind=RKIND), dimension(grid % nVertLevels + 1, nlat) :: zgrid_2d
+ real (kind=RKIND), dimension(grid % nVertLevels, nlat) :: u_2d, pp_2d, rho_2d, qv_2d, etavs_2d, zz_2d
+ real (kind=RKIND), dimension(grid % nVertLevels, nlat-1) :: zx_2d
real (kind=RKIND), dimension(nlat) :: lat_2d
- real (kind=RKIND) :: dlat
+ real (kind=RKIND) :: dlat, hx_1d
real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2
+ logical, parameter :: moisture = .true.
!
! Scale all distances and areas from a unit sphere to one with radius a
!
@@ -225,8 +253,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
@@ -259,13 +285,25 @@
t => state % theta_m % array
rt => diag % rtheta_p % array
+ surface_pressure => diag % surface_pressure % array
+
+!.. initialization of moisture:
scalars => state % scalars % array
+ !qsat => diag_physics % qsat % array
+ !relhum => diag_physics % relhum % array
+ scalars(:,:,:) = 0.0
+ qsat(:,:) = 0.0
+ relhum(:,:) = 0.0
+ qv_2d(:,:) = 0.0
+!.. end initialization of moisture.
- scalars(:,:,:) = 0.
+ surface_pressure(:) = 0.0
call atm_initialize_advection_rk(grid)
call atm_initialize_deformation_weights(grid)
+ index_qv = state % index_qv
+
xnutr = 0.
zd = 12000.
znut = eta_t
@@ -293,7 +331,7 @@
! Metrics for hybrid coordinate and vertical stretching
- str = 1.5
+ str = 1.8
zt = 45000.
dz = zt/float(nz1)
@@ -323,7 +361,7 @@
ah(k) = 1.-cos(.5*pii*(k-1)*dz/zt)**6
! ah(k) = 0.
- write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)
+ write(0,*) ' k, sh, zw, ah ',k,sh(k),zw(k),ah(k)
end do
do k=1,nz1
dzw (k) = zw(k+1)-zw(k)
@@ -388,47 +426,43 @@
end do
enddo
- do k=1,nz1
- write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
- enddo
+ !do k=1,nz1
+ ! write(0,*) ' k, zgrid(k,1),hx(k,1) ',k,zgrid(k,1),hx(k,1)
+ !enddo
- do k=1,nz1
- write(0,*) ' k, zx(k,1) ',k,zx(k,1)
- enddo
+ !do k=1,nz1
+ ! write(0,*) ' k, zx(k,1) ',k,zx(k,1)
+ !enddo
write(0,*) ' grid metrics setup complete '
-!************** section for 2d (lat,z) calc for zonal velocity
+!************** section for 2d (z,lat) calc for zonal velocity
dlat = 0.5*pii/float(nlat-1)
do i = 1,nlat
lat_2d(i) = float(i-1)*dlat
-! write(0,*) ' zonal setup, latitude = ',lat_2d(i)*180./pii
+ phi = lat_2d(i)
+ hx_1d = u0/gravity*cos(etavs)**1.5 &
+ *((-2.*sin(phi)**6 &
+ *(cos(phi)**2+1./3.)+10./63.) &
+ *(u0)*cos(etavs)**1.5 &
+ +(1.6*cos(phi)**3 &
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- do k=1,nz
- phi = lat_2d(i)
- hx_1d(k) = u0/gravity*cos(etavs)**1.5 &
- *((-2.*sin(phi)**6 &
- *(cos(phi)**2+1./3.)+10./63.) &
- *(u0)*cos(etavs)**1.5 &
- +(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
- enddo
-
do k=1,nz
- zgrid_1d(k) = (1.-ah(k))*(sh(k)*(zt-hx_1d(k))+hx_1d(k)) &
+ zgrid_2d(k,i) = (1.-ah(k))*(sh(k)*(zt-hx_1d)+hx_1d) &
+ ah(k) * sh(k)* zt
end do
do k=1,nz1
- zz_1d (k) = (zw(k+1)-zw(k))/(zgrid_1d(k+1)-zgrid_1d(k))
+ zz_2d (k,i) = (zw(k+1)-zw(k))/(zgrid_2d(k+1,i)-zgrid_2d(k,i))
end do
do k=1,nz1
- ztemp = .5*(zgrid_1d(k+1)+zgrid_1d(k))
+ ztemp = .5*(zgrid_2d(k+1,i)+zgrid_2d(k,i))
ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
pb (k,i) = (ppb(k,i)/p0)**(rgas/cp)
- rb (k,i) = ppb(k,i)/(rgas*t0b*zz_1d(k))
+ rb (k,i) = ppb(k,i)/(rgas*t0b*zz_2d(k,i))
tb (k,i) = t0b/pb(k,i)
rtb(k,i) = rb(k,i)*tb(k,i)
p (k,i) = pb(k,i)
@@ -448,40 +482,43 @@
teta(k) = t0*eta(k)**(rgas*dtdz/gravity) + delta_t*(znut-eta(k))**5
end if
end do
- ! phi = grid % latCell % array (i)
+
phi = lat_2d (i)
do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
+ temperature_1d(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
*sqrt(cos(etav(k)))* &
((-2.*sin(phi)**6 &
*(cos(phi)**2+1./3.)+10./63.) &
*2.*u0*cos(etav(k))**1.5 &
+(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)/(1.+0.61*qv_2d(k,i))
- ztemp = .5*(zgrid_1d(k)+zgrid_1d(k+1))
+ ztemp = .5*(zgrid_2d(k,i)+zgrid_2d(k+1,i))
ptemp = ppb(k,i) + pp(k,i)
- qv(k,i) = 0.
+ !get moisture
+ if (moisture) then
+ qv_2d(k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max )
+ end if
+
+ tt(k) = temperature_1d(k)*(1.+1.61*qv_2d(k,i))
end do
-
+
do itrp = 1,25
do k=1,nz1
- rr(k,i) = (pp(k,i)/(rgas*zz_1d(k)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
+ rr(k,i) = (pp(k,i)/(rgas*zz_2d(k,i)) - rb(k,i)*(tt(k)-t0b))/tt(k)
end do
- ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
+ ppi(1) = p0-.5*dzw(1)*gravity &
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+qv_2d(1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+qv_2d(2,i)))
ppi(1) = ppi(1)-ppb(1,i)
do k=1,nz1-1
- ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
+ ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
+ (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv_2d(k ,i) &
+ +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv_2d(k+1,i))
end do
do k=1,nz1
@@ -493,21 +530,28 @@
end do ! end outer iteration loop itr
do k=1,nz1
- etavs_2d(i,k) = (0.5*(ppb(k,i)+ppb(k,i)+pp(k,i)+pp(k,i))/p0 - 0.252)*pii/2.
-! u_2d(i,k) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(i,k))**1.5)
- u_2d(i,k) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(i,k))**1.5)*(rb(k,i)+rr(k,i))
+ rho_2d(k,i) = rr(k,i)+rb(k,i)
+ pp_2d(k,i) = pp(k,i)
+ etavs_2d(k,i) = ((ppb(k,i)+pp(k,i))/p0 - 0.252)*pii/2.
+ u_2d(k,i) = u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(k,i))**1.5)
end do
end do ! end loop over latitudes for 2D zonal wind field calc
-! do i=1,nlat
-! do k=1,nz1
-! u_2d(i,k) = u_2d(i,k) - u0*(sin(2.*lat_2d(i))**2) *(cos(etavs_2d(nlat/2,k))**1.5)
-! end do
-! end do
-!
-! write(22,*) nz1,nlat,u_2d
+ !SHP-balance:: in case of rebalacing for geostrophic wind component
+ if (rebalance) then
+ do i=1,nlat-1
+ do k=1,nz1
+ zx_2d(k,i) = (zgrid_2d(k,i+1)-zgrid_2d(k,i))/(dlat*r_earth)
+ end do
+ end do
+
+ call init_atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
+ cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
+
+ end if
+
!******************************************************************
!
@@ -516,7 +560,6 @@
! reference sounding based on dry isothermal atmosphere
!
do i=1, grid % nCells
- !write(0,*) ' thermodynamic setup, cell ',i
do k=1,nz1
ztemp = .5*(zgrid(k+1,i)+zgrid(k,i))
ppb(k,i) = p0*exp(-gravity*ztemp/(rgas*t0b))
@@ -529,12 +572,17 @@
rr (k,i) = 0.
end do
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
- enddo
- end if
-!
+! if(i == 1) then
+! do k=1,nz1
+! write(0,*) ' k, ppb, pb, rb, tb (k,1) ',k,ppb(k,1),pb(k,1),rb(k,1)*zz(k,1),tb(k,1)
+! enddo
+! end if
+
+ 200 format(4i6,8(1x,e15.8))
+ 201 format(3i6,8(1x,e15.8))
+ 202 format(2i6,10(1x,e15.8))
+ 203 format(i6,10(1x,e15.8))
+
! iterations to converge temperature as a function of pressure
!
do itr = 1,10
@@ -550,42 +598,60 @@
end do
phi = grid % latCell % array (i)
do k=1,nz1
- tt(k) = 0.
- tt(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
+ temperature_1d(k) = teta(k)+.75*eta(k)*pii*u0/rgas*sin(etav(k)) &
*sqrt(cos(etav(k)))* &
((-2.*sin(phi)**6 &
*(cos(phi)**2+1./3.)+10./63.) &
*2.*u0*cos(etav(k))**1.5 &
+(1.6*cos(phi)**3 &
- *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)
+ *(sin(phi)**2+2./3.)-pii/4.)*r_earth*omega_e)/(1.+0.61*scalars(index_qv,k,i))
-
- !write(0,*) ' k, tt(k) ',k,tt(k)
ztemp = .5*(zgrid(k,i)+zgrid(k+1,i))
ptemp = ppb(k,i) + pp(k,i)
-! qv(k,i) = env_qv( ztemp, tt(k), ptemp, 0 )
- qv(k,i) = 0.
+ !get moisture
+ if (moisture) then
+
+ !scalars(index_qv,k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max )
+
+ if(ptemp < 50000.) then
+ relhum(k,i) = 0.0
+ elseif(ptemp > p0) then
+ relhum(k,i) = 1.0
+ else
+ relhum(k,i) = (1.-((p0-ptemp)/50000.)**1.25)
+ endif
+ relhum(k,i) = min(rh_max,relhum(k,i))
+
+ !.. calculation of water vapor mixing ratio:
+ if (temperature_1d(k) > 273.15) then
+ es = 1000.*0.6112*exp(17.67*(temperature_1d(k)-273.15)/(temperature_1d(k)-29.65))
+ else
+ es = 1000.*0.6112*exp(21.8745584*(temperature_1d(k)-273.15)/(temperature_1d(k)-7.66))
+ end if
+ qsat(k,i) = (287.04/461.6)*es/(ptemp-es)
+ if(relhum(k,i) .eq. 0.0) qsat(k,i) = 0.0
+ scalars(index_qv,k,i) = relhum(k,i)*qsat(k,i)
+ end if
+
+ tt(k) = temperature_1d(k)*(1.+1.61*scalars(index_qv,k,i))
+
end do
-! do k=2,nz1
-! cqw(k,i) = 1./(1.+.5*(qv(k,i)+qv(k-1,i)))
-! end do
do itrp = 1,25
do k=1,nz1
- rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) &
- -rb(k,i)*(tt(k)-t0b))/tt(k)
+ rr(k,i) = (pp(k,i)/(rgas*zz(k,i)) - rb(k,i)*(tt(k)-t0b))/tt(k)
end do
ppi(1) = p0-.5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+scalars(index_qv,1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+scalars(index_qv,2,i)))
ppi(1) = ppi(1)-ppb(1,i)
do k=1,nz1-1
ppi(k+1) = ppi(k)-.5*dzu(k+1)*gravity* &
- (rr(k ,i)+(rr(k ,i)+rb(k ,i))*qv(k ,i) &
- +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*qv(k+1,i))
+ (rr(k ,i)+(rr(k ,i)+rb(k ,i))*scalars(index_qv,k ,i) &
+ +rr(k+1,i)+(rr(k+1,i)+rb(k+1,i))*scalars(index_qv,k+1,i))
end do
do k=1,nz1
@@ -603,14 +669,25 @@
rho_zz (k,i) = rb(k,i) + rr(k,i)
end do
- if(i == 1) then
- do k=1,nz1
- write(0,*) ' k, p, t, rt ',k,p(k,1),t(k,1),rt(k,1)
- enddo
- end if
+ !calculation of surface pressure:
+ surface_pressure(i) = 0.5*dzw(1)*gravity &
+ * (1.25*(rr(1,i) + rb(1,i)) * (1. + scalars(index_qv,1,i)) &
+ - 0.25*(rr(2,i) + rb(2,i)) * (1. + scalars(index_qv,2,i)))
+ surface_pressure(i) = surface_pressure(i) + pp(1,i) + ppb(1,i)
end do ! end loop over cells
+ !write(0,*)
+ !write(0,*) '--- initialization of water vapor:'
+ !do iCell = 1, grid % nCells
+ ! if(iCell == 1 .or. iCell == grid % nCells) then
+ ! do k = nz1, 1, -1
+ ! write(0,202) iCell,k,t(k,iCell),relhum(k,iCell),qsat(k,iCell),scalars(index_qv,k,iCell)
+ ! enddo
+ ! write(0,*)
+ ! endif
+ !enddo
+
lat_pert = latitude_pert*pii/180.
lon_pert = longitude_pert*pii/180.
@@ -626,7 +703,7 @@
if (config_test_case == 2) then
r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
- lat_pert, lon_pert, 1.)/(pert_radius)
+ lat_pert, lon_pert, 1.0_RKIND)/(pert_radius)
u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
else if (config_test_case == 3) then
@@ -637,34 +714,30 @@
u_pert = 0.0
end if
- call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
+ if (rebalance) then
- do k=1,grid % nVertLevels
-!! etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
-! etavs = (0.5*(ppb(k,1)+ppb(k,1)+pp(k,1)+pp(k,1))/p0 - 0.252)*pii/2.
- etavs = (0.5*(ppb(k,440)+ppb(k,440)+pp(k,440)+pp(k,440))/p0 - 0.252)*pii/2. ! 10262 mesh
-! etavs = (0.5*(ppb(k,505)+ppb(k,505)+pp(k,505)+pp(k,505))/p0 - 0.252)*pii/2. ! 40962 mesh
-
-! fluxk = u0*flux*(cos(etavs)**1.5)
+ call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,grid % dvEdge % array(iEdge),a,u0,nz1,nlat)
+ do k=1,grid % nVertLevels
+ fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
- fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2)))
+ else
-! if(k.eq.18) then
-! write(21,*) ' iEdge, u1, u2 ',iEdge,fluxk,u0*flux_zonal(k)
-! end if
-!! fluxk = u0*flux*(cos(znuv(k))**(1.5))
-!! fluxk = u0 * cos(grid % angleEdge % array(iEdge)) * (sin(lat1+lat2)**2) *(cos(etavs)**1.5)
- state % u % array(k,iEdge) = fluxk + u_pert
- end do
+ do k=1,grid % nVertLevels
+ etavs = (0.5*(ppb(k,iCell1)+ppb(k,iCell2)+pp(k,iCell1)+pp(k,iCell2))/p0 - 0.252)*pii/2.
+ fluxk = u0*flux*(cos(etavs)**1.5)
+ state % u % array(k,iEdge) = fluxk + u_pert
+ end do
- cell1 = grid % CellsOnEdge % array(1,i)
- cell2 = grid % CellsOnEdge % array(2,i)
- if(cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then
- do k=1,nz1
- diag % ru % array (k,iEdge) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*state % u % array (k,iEdge)
- end do
end if
+ cell1 = grid % CellsOnEdge % array(1,iEdge)
+ cell2 = grid % CellsOnEdge % array(2,iEdge)
+ do k=1,nz1
+ diag % ru % array (k,iEdge) = 0.5*(rho_zz(k,cell1)+rho_zz(k,cell2))*state % u % array (k,iEdge)
+ end do
+
!
! Generate rotated Coriolis field
!
@@ -692,54 +765,41 @@
do iEdge = 1,grid % nEdges
cell1 = CellsOnEdge(1,iEdge)
cell2 = CellsOnEdge(2,iEdge)
- if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then
- do k = 1, grid%nVertLevels
+ do k = 1, grid%nVertLevels
- if (config_theta_adv_order == 2) then
+ if (config_theta_adv_order == 2) then
- z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
+ z_edge = (zgrid(k,cell1)+zgrid(k,cell2))/2.
- else if (config_theta_adv_order == 3 .or. config_theta_adv_order ==4) then !theta_adv_order == 3 or 4
+ else if (config_theta_adv_order == 3 .or. config_theta_adv_order ==4) then !theta_adv_order == 3 or 4
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
- do i=1, grid % nEdgesOnCell % array (cell1)
- if ( grid % CellsOnCell % array (i,cell1) > 0) &
- d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
- end do
- do i=1, grid % nEdgesOnCell % array (cell2)
- if ( grid % CellsOnCell % array (i,cell2) > 0) &
- d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
- end do
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1)
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2)
+ do i=1, grid % nEdgesOnCell % array (cell1)
+ d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell1))
+ d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,grid % CellsOnCell % array (i,cell2))
+ end do
- z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
- - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
+ z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) &
+ - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
- if (config_theta_adv_order == 3) then
- z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
- else
- z_edge3 = 0.
- end if
-
+ if (config_theta_adv_order == 3) then
+ z_edge3 = - (grid % dcEdge % array(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.
+ else
+ z_edge3 = 0.
end if
- zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
- zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
- zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
- zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
+ end if
- 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
+ zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/AreaCell(cell1)
+ zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/AreaCell(cell2)
+ zb3(k,1,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell1)
+ zb3(k,2,iEdge)= z_edge3*dvEdge(iEdge)/AreaCell(cell2)
- end do
+ end do
- end if
- end do
+ end do
! for including terrain
diag % rw % array = 0.
@@ -749,21 +809,21 @@
cell1 = CellsOnEdge(1,iEdge)
cell2 = CellsOnEdge(2,iEdge)
- 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.,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.,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
- end if
end do
@@ -783,11 +843,9 @@
do iEdge = 1, grid%nEdges
do i=1,nEdgesOnEdge(iEdge)
eoe = edgesOnEdge(i,iEdge)
- if (eoe > 0) then
- do k = 1, grid%nVertLevels
- diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
- end do
- end if
+ do k = 1, grid%nVertLevels
+ diag % v % array(k,iEdge) = diag % v %array(k,iEdge) + weightsOnEdge(i,iEdge) * state % u % array(k, eoe)
+ end do
end do
end do
@@ -795,8 +853,8 @@
psurf = (cf1*(ppb(1,i)+pp(1,i)) + cf2*(ppb(2,i)+pp(2,i)) + cf3*(ppb(3,i)+pp(3,i)))/100.
psurf = (ppb(1,i)+pp(1,i)) + .5*dzw(1)*gravity &
- *(1.25*(rr(1,i)+rb(1,i))*(1.+qv(1,i)) &
- -.25*(rr(2,i)+rb(2,i))*(1.+qv(2,i)))
+ *(1.25*(rr(1,i)+rb(1,i))*(1.+scalars(index_qv,1,i)) &
+ -.25*(rr(2,i)+rb(2,i))*(1.+scalars(index_qv,2,i)))
write(0,*) ' i, psurf, lat ',i,psurf,grid%latCell%array(i)*180./3.1415828
enddo
@@ -805,7 +863,7 @@
do iCell=1,grid%nCells
do k=1,grid%nVertLevels
diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(state % index_qv,k,iCell))
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
end do
end do
@@ -815,7 +873,7 @@
implicit none
integer, intent(in) :: nz1,nlat
- real (kind=RKIND), dimension(nlat,nz1), intent(in) :: u_2d,etavs_2d
+ real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_2d,etavs_2d
real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
real (kind=RKIND), dimension(nz1), intent(out) :: flux_zonal
real (kind=RKIND), intent(in) :: lat1_in, lat2_in, dvEdge, a, u0
@@ -845,7 +903,7 @@
w2 = 0.5*(db-da)**2
do k=1,nz1
- flux_zonal(k) = flux_zonal(k) + w1*u_2d(i,k) + w2*u_2d(i+1,k)
+ flux_zonal(k) = flux_zonal(k) + w1*u_2d(k,i) + w2*u_2d(k,i+1)
end do
end if
@@ -855,12 +913,105 @@
! renormalize for setting cell-face fluxes
do k=1,nz1
- flux_zonal(k) = sign(1.,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
+ flux_zonal(k) = sign(1.0_RKIND,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
end do
end subroutine init_atm_calc_flux_zonal
+ !SHP-balance
+ subroutine init_atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz_2d,zx_2d, &
+ cf1,cf2,cf3,fzm,fzp,rdzw,nz1,nlat,dlat)
+ implicit none
+ integer, intent(in) :: nz1,nlat
+ real (kind=RKIND), dimension(nz1,nlat), intent(inout) :: u_2d
+ real (kind=RKIND), dimension(nz1,nlat), intent(in) :: rho_2d, pp_2d, qv_2d, zz_2d
+ real (kind=RKIND), dimension(nz1,nlat-1), intent(in) :: zx_2d
+ real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d
+ real (kind=RKIND), dimension(nz1), intent(in) :: fzm, fzp, rdzw
+ real (kind=RKIND), intent(in) :: cf1, cf2, cf3, dlat
+
+ !local variable
+ real (kind=RKIND), dimension(nz1,nlat-1) :: pgrad, ru, u
+ real (kind=RKIND), dimension(nlat-1) :: f
+ real (kind=RKIND), dimension(nz1+1) :: dpzx
+
+ real (kind=RKIND), parameter :: omega_e = 7.29212e-05
+ real (kind=RKIND) :: rdx, qtot, r_earth, phi
+ integer :: k,i, itr
+
+ r_earth = a
+ rdx = 1./(dlat*r_earth)
+
+ do i=1,nlat-1
+ do k=1,nz1
+ pgrad(k,i) = rdx*(pp_2d(k,i+1)/zz_2d(k,i+1)-pp_2d(k,i)/zz_2d(k,i))
+ end do
+
+ dpzx(:) = 0.
+
+ k=1
+ dpzx(k) = .5*zx_2d(k,i)*(cf1*(pp_2d(k ,i+1)+pp_2d(k ,i)) &
+ +cf2*(pp_2d(k+1,i+1)+pp_2d(k+1,i)) &
+ +cf3*(pp_2d(k+2,i+1)+pp_2d(k+2,i)))
+ do k=2,nz1
+ dpzx(k) = .5*zx_2d(k,i)*(fzm(k)*(pp_2d(k ,i+1)+pp_2d(k ,i)) &
+ +fzp(k)*(pp_2d(k-1,i+1)+pp_2d(k-1,i)))
+ end do
+
+ do k=1,nz1
+ pgrad(k,i) = pgrad(k,i) - rdzw(k)*(dpzx(k+1)-dpzx(k))
+ end do
+ end do
+
+
+ !initial value of v and rv -> that is from analytic sln.
+ do i=1,nlat-1
+ do k=1,nz1
+ u(k,i) = .5*(u_2d(k,i)+u_2d(k,i+1))
+ ru(k,i) = u(k,i)*(rho_2d(k,i)+rho_2d(k,i+1))*.5
+ end do
+ end do
+
+ write(0,*) "MAX U wind before REBALANCING ---->", maxval(abs(u))
+
+ !re-calculate geostrophic wind using iteration
+ do itr=1,50
+ do i=1,nlat-1
+ phi = (lat_2d(i)+lat_2d(i+1))/2.
+ f(i) = 2.*omega_e*sin(phi)
+ do k=1,nz1
+ if (f(i).eq.0.) then
+ ru(k,i) = 0.
+ else
+ qtot = .5*(qv_2d(k,i)+qv_2d(k,i+1))
+ ru(k,i) = - ( 1./(1.+qtot)*pgrad(k,i) + tan(phi)/r_earth*u(k,i)*ru(k,i) )/f(i)
+ end if
+ u(k,i) = ru(k,i)*2./(rho_2d(k,i)+rho_2d(k,i+1))
+ end do
+ end do
+ end do
+
+ write(0,*) "MAX U wind after REBALANCING ---->", maxval(abs(u))
+
+ !update 2d ru
+ do i=2,nlat-1
+ do k=1,nz1
+ u_2d(k,i) = (ru(k,i-1)+ru(k,i))*.5
+ end do
+ end do
+
+ i=1
+ do k=1,nz1
+ u_2d(k,i) = (3.*u_2d(k,i+1)-u_2d(k,i+2))*.5
+ end do
+ i=nlat
+ do k=1,nz1
+ u_2d(k,i) = (3.*u_2d(k,i-1)-u_2d(k,i-2))*.5
+ end do
+
+
+ end subroutine init_atm_recompute_geostrophic_wind
!----------------------------------------------------------------------------------------------------------
subroutine init_atm_test_case_squall_line(dminfo, grid, state, diag, test_case)
@@ -885,7 +1036,7 @@
integer :: eoe, j
integer, dimension(:), pointer :: nEdgesOnEdge
integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2, nCellsSolve
integer :: index_qv
@@ -1174,7 +1325,7 @@
call mpas_dmpar_bcast_real(dminfo, pibtop)
ptopb = p0*pibtop**(1./rcp)
- write(0,*) 'ptopb = ',.01*ptopb
+ write(6,*) 'ptopb = ',.01*ptopb
do i=1, grid % nCells
pb(nz1,i) = pibtop+.5*dzw(nz1)*gravity*(1.+qvb(nz1))/(cp*tb(nz1,i)*zz(nz1,i))
@@ -1189,6 +1340,7 @@
rb (k,i) = pb(k,i)**(1./rcv)/((rgas/p0)*tb(k,i)*zz(k,i))
rtb(k,i) = rb(k,i)*tb(k,i)
rr (k,i) = p (k,i)**(1./rcv)/((rgas/p0)*t (k,i)*zz(k,i))-rb(k,i)
+ ppb(k,i) = p0*(zz(k,i)*rgas*rtb(k,i)/p0)**(cp/cv)
end do
end do
@@ -1200,7 +1352,7 @@
temp = p(k,i)*thi(k,i)
pres = p0*p(k,i)**(1./rcp)
qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
+ scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
end do
end do
@@ -1283,7 +1435,7 @@
ptop = p0*pitop**(1./rcp)
write(0,*) 'ptop = ',.01*ptop, .01*ptopb
- call mpas_dmpar_bcast_real(dminfo, pitop)
+ call mpas_dmpar_bcast_real(dminfo, ptop)
do i = 1, grid % nCells
@@ -1301,7 +1453,7 @@
end do
if (itr==1.and.i==1) then
do k=1,nz1
- print *, "pp-check", pp(k,i)
+ write(0,*) "pp-check", pp(k,i)
end do
end if
do k=1,nz1
@@ -1349,8 +1501,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.
@@ -1389,7 +1539,7 @@
do iCell=1,grid%nCells
do k=1,grid%nVertLevels
diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(state % index_qv,k,iCell))
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
end do
end do
@@ -1416,14 +1566,14 @@
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
integer, dimension(:), pointer :: nEdgesOnEdge
integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
- real, dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell
- real, dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
integer :: index_qv
@@ -1433,7 +1583,7 @@
real (kind=RKIND) :: ztemp, zd, zt, dz, str
real (kind=RKIND), dimension(grid % nVertLevels, grid % nCells) :: rh
- real (kind=RKIND) :: ptmp, es, qvs, xnutr, ptemp
+ real (kind=RKIND) :: es, qvs, xnutr, ptemp
integer :: iter
real (kind=RKIND), dimension(grid % nVertLevels + 1 ) :: zc, zw, ah
@@ -1483,8 +1633,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
@@ -1649,7 +1797,7 @@
! smoothing grid for the upper level >> but not propoer for parallel programing
dzmin=.7
do k=2,nz1
- sm = .25*min((zc(k)-zc(k-1))/dz,1.)
+ sm = .25*min((zc(k)-zc(k-1))/dz,1.0_RKIND)
do i=1,grid % nCells
hx(k,i) = hx(k-1,i)
end do
@@ -1674,7 +1822,7 @@
end if
end do !end of iteration for smoothing
-99 print *,"PASS-SHP"
+99 write(0,*) "PASS-SHP"
end do
do iCell=1,grid % nCells
@@ -1751,7 +1899,11 @@
+zgrid(k,cell2)+zgrid(k+1,cell2))
u(k,i) = um
if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
- u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
+#ifdef ROTATED_GRID
+ u(k,i) = sin(grid % angleEdge % array(i)) * (u(k,i) - us)
+#else
+ u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
+#endif
end do
end if
end do
@@ -1826,7 +1978,7 @@
temp = p(k,i)*t(k,i)
pres = p0*p(k,i)**(1./rcp)
qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
+ scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
end do
do k=1,nz1
@@ -1845,7 +1997,7 @@
write(0,*) ' *** sounding for the simulation ***'
write(0,*) ' z theta pres qv rho_m u rr'
do k=1,nz1
- write(0,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
+ write(6,'(8(f14.9,2x))') .5*(zgrid(k,1)+zgrid(k+1,1))/1000., &
t(k,1)/(1.+1.61*scalars(index_qv,k,1)), &
.01*p0*p(k,1)**(1./rcp), &
1000.*scalars(index_qv,k,1), &
@@ -1916,13 +2068,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
@@ -1944,14 +2089,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.,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.,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
@@ -1999,7 +2146,7 @@
do iCell=1,grid%nCells
do k=1,grid%nVertLevels
diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
- diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(state % index_qv,k,iCell))
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell))
end do
end do
@@ -2045,7 +2192,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
@@ -2138,8 +2285,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
@@ -2520,12 +2665,12 @@
grid % soiltemp % array(:) = 0.0
call map_set(PROJ_LATLON, proj, &
- latinc = 1.0, &
- loninc = 1.0, &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = -89.5, &
- lon1 = -179.5)
+ latinc = 1.0_RKIND, &
+ loninc = 1.0_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.5_RKIND, &
+ lon1 = -179.5_RKIND)
write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'soiltemp_1deg/',1,'-',180,'.',1,'-',180
write(0,*) trim(fname)
@@ -2568,8 +2713,8 @@
end if
if (y < 1.0) y = 1.0
if (y > 179.0) y = 179.0
-! grid % soiltemp % array(iCell) = interp_sequence(x, y, 1, soiltemp_1deg, 1, 360, 1, 180, 1, 1, -1.e30, interp_list, 1)
- grid % soiltemp % array(iCell) = interp_sequence(x, y, 1, soiltemp_1deg, 1, 360, 1, 180, 1, 1, 0., interp_list, 1)
+! grid % soiltemp % array(iCell) = interp_sequence(x, y, 1, soiltemp_1deg, 1, 360, 1, 180, 1, 1, -1.e30_RKIND, interp_list, 1)
+ grid % soiltemp % array(iCell) = interp_sequence(x, y, 1, soiltemp_1deg, 1, 360, 1, 180, 1, 1, 0.0_RKIND, interp_list, 1)
else
grid % soiltemp % array(iCell) = 0.0
end if
@@ -2595,12 +2740,12 @@
grid % snoalb % array(:) = 0.0
call map_set(PROJ_LATLON, proj, &
- latinc = 1.0, &
- loninc = 1.0, &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = -89.5, &
- lon1 = -179.5)
+ latinc = 1.0_RKIND, &
+ loninc = 1.0_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.5_RKIND, &
+ lon1 = -179.5_RKIND)
write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'maxsnowalb/',1,'-',180,'.',1,'-',180
write(0,*) trim(fname)
@@ -2643,8 +2788,8 @@
end if
if (y < 1.0) y = 1.0
if (y > 179.0) y = 179.0
-! grid % snoalb % array(iCell) = interp_sequence(x, y, 1, maxsnowalb, 1, 360, 1, 180, 1, 1, -1.e30, interp_list, 1)
- grid % snoalb % array(iCell) = interp_sequence(x, y, 1, maxsnowalb, 1, 360, 1, 180, 1, 1, 0., interp_list, 1)
+! grid % snoalb % array(iCell) = interp_sequence(x, y, 1, maxsnowalb, 1, 360, 1, 180, 1, 1, -1.e30_RKIND, interp_list, 1)
+ grid % snoalb % array(iCell) = interp_sequence(x, y, 1, maxsnowalb, 1, 360, 1, 180, 1, 1, 0.0_RKIND, interp_list, 1)
else
grid % snoalb % array(iCell) = 0.0
end if
@@ -2673,12 +2818,12 @@
grid % greenfrac % array(:,:) = 0.0
call map_set(PROJ_LATLON, proj, &
- latinc = 0.144, &
- loninc = 0.144, &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = -89.928, &
- lon1 = -179.928)
+ latinc = 0.144_RKIND, &
+ loninc = 0.144_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.928_RKIND, &
+ lon1 = -179.928_RKIND)
write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'greenfrac/',1,'-',1250,'.',1,'-',1250
write(0,*) trim(fname)
@@ -2715,7 +2860,7 @@
if (y < 1.0) y = 1.0
if (y > 1249.0) y = 1249.0
do k=1,12
- grid % greenfrac % array(k,iCell) = interp_sequence(x, y, k, vegfra, 1, 2500, 1, 1250, 1, 12, -1.e30, interp_list, 1)
+ grid % greenfrac % array(k,iCell) = interp_sequence(x, y, k, vegfra, 1, 2500, 1, 1250, 1, 12, -1.e30_RKIND, interp_list, 1)
end do
else
grid % greenfrac % array(:,iCell) = 0.0
@@ -2744,12 +2889,12 @@
grid % albedo12m % array(:,:) = 0.0
call map_set(PROJ_LATLON, proj, &
- latinc = 0.144, &
- loninc = 0.144, &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = -89.928, &
- lon1 = -179.928)
+ latinc = 0.144_RKIND, &
+ loninc = 0.144_RKIND, &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = -89.928_RKIND, &
+ lon1 = -179.928_RKIND)
write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(config_geog_data_path)//'albedo_ncep/',1,'-',1250,'.',1,'-',1250
write(0,*) trim(fname)
@@ -2786,7 +2931,7 @@
if (y < 1.0) y = 1.0
if (y > 1249.0) y = 1249.0
do k=1,12
- grid % albedo12m % array(k,iCell) = interp_sequence(x, y, k, vegfra, 1, 2500, 1, 1250, 1, 12, 0.0, interp_list, 1)
+ grid % albedo12m % array(k,iCell) = interp_sequence(x, y, k, vegfra, 1, 2500, 1, 1250, 1, 12, 0.0_RKIND, interp_list, 1)
end do
else
grid % albedo12m % array(:,iCell) = 8.0
@@ -2822,12 +2967,12 @@
if (field % iproj == PROJ_LATLON) then
call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat), &
- loninc = real(field % deltalon), &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ latinc = real(field % deltalat,RKIND), &
+ loninc = real(field % deltalon,RKIND), &
+ knowni = 1.0_RKIND, &
+ knownj = 1.0_RKIND, &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
end if
@@ -2848,9 +2993,9 @@
call latlon_to_ij(proj, lat, lon, x, y)
end if
if (ndims == 1) then
- destField1d(i) = interp_sequence(x, y, 1, field % slab, 1, field % nx, 1, field % ny, 1, 1, -1.e30, interp_list, 1)
+ destField1d(i) = interp_sequence(x, y, 1, field % slab, 1, field % nx, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1)
else if (ndims == 2) then
- destField2d(k,i) = interp_sequence(x, y, 1, field % slab, 1, field % nx, 1, field % ny, 1, 1, -1.e30, interp_list, 1)
+ destField2d(k,i) = interp_sequence(x, y, 1, field % slab, 1, field % nx, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1)
end if
end do
end if
@@ -3014,9 +3159,9 @@
hx(k,:) = hx(k-1,:)
dzminf = zw(k)-zw(k-1)
-! dzmin = max(.5,1.-.5*zw(k)/hm)
+! dzmin = max(0.5_RKIND,1.-.5*zw(k)/hm)
- sm = .05*min(.5*zw(k)/hm,1.)
+ sm = .05*min(0.5_RKIND*zw(k)/hm,1.0_RKIND)
do i=1,50
do iCell=1,grid %nCells
@@ -3044,8 +3189,9 @@
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)
+ 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
hx(k,:)=hs(:)
@@ -3151,13 +3297,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
@@ -3170,6 +3309,13 @@
if (config_met_interp) then
+ !ldf (2011-11-19): added initialization of the sea-surface temperature, seaice fraction, and
+ !seaice flag:
+ fg % sst % array = 0.
+ fg % xice % array = 0.
+ fg % seaice % array = 0.
+ !ldf end.
+
!
! First, try to locate the LANDSEA field for use as an interpolation mask
!
@@ -3290,18 +3436,18 @@
if (field % iproj == PROJ_LATLON) then
call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat), &
- loninc = real(field % deltalon), &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ latinc = real(field % deltalat,RKIND), &
+ loninc = real(field % deltalon,RKIND), &
+ knowni = 1.0_RKIND, &
+ 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), &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ loninc = real(field % deltalon,RKIND), &
+ lat1 = real(field % startlat,RKIND), &
+ lon1 = real(field % startlon,RKIND))
! nxmax = nint(360.0 / field % deltalon), &
end if
@@ -3687,7 +3833,8 @@
! Set SST based on SKINTEMP field if it wasn't found in input data
if (minval(fg % sst % array) == 0.0 .and. maxval(fg % sst % array) == 0.0) then
write(0,*) 'Setting SST from SKINTEMP'
- where (grid % landmask % array == 0) fg % sst % array = fg % skintemp % array
+ !where (grid % landmask % array == 0) fg % sst % array = fg % skintemp % array
+ fg % sst % array = fg % skintemp % array
end if
! Set SNOWC (snow-cover flag) based on SNOW
@@ -3737,13 +3884,13 @@
if (field % iproj == PROJ_PS) then
call map_set(PROJ_PS, proj, &
- dx = real(field % dx * 1000.0), &
- truelat1 = real(field % truelat1), &
- stdlon = real(field % xlonc), &
- knowni = real(field % nx / 2.0), &
- knownj = real(field % ny / 2.0), &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ 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
if (index(field % field, 'SEAICE') /= 0) then
@@ -3949,6 +4096,20 @@
!
+ ! Reconstruct zonal and meridional winds for diagnostic puposes:
+ !
+ call mpas_rbf_interp_initialize(grid)
+ call mpas_init_reconstruct(grid)
+ call mpas_reconstruct(grid, state % u % array, &
+ diag % uReconstructX % array, &
+ diag % uReconstructY % array, &
+ diag % uReconstructZ % array, &
+ diag % uReconstructZonal % array, &
+ diag % uReconstructMeridional % array &
+ )
+
+
+ !
! Adjust surface pressure for difference in topography
!
do sfc_k=1,config_nfglevels
@@ -4079,14 +4240,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.,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.,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
@@ -4107,7 +4270,8 @@
end if ! config_met_interp
- ! Calculate surface pressure
+ ! Calculate surface pressure (This is an ad-hoc calculation. The actual surface pressure is actually re-calculated at
+ !the top of the subroutine MPAS_to_physics in ../core_atmos_physics/mpas_atmphys_interface_nhyd.F
do iCell=1,grid%nCells
diag % surface_pressure % array(iCell) = 0.5*gravity/rdzw(1) &
* (1.25* rho_zz(1,iCell) * (1. + scalars(state % index_qv, 1, iCell)) &
@@ -4125,7 +4289,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
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -4185,12 +4349,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
@@ -4198,6 +4362,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
@@ -4215,19 +4384,28 @@
if (field % iproj == PROJ_LATLON) then
call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat), &
- loninc = real(field % deltalon), &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ latinc = real(field % deltalat,RKIND), &
+ loninc = real(field % deltalon,RKIND), &
+ knowni = 1.0_RKIND, &
+ 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), &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ 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 SST/SKINTEMP field to each MPAS grid cell
@@ -4247,15 +4425,13 @@
lon = lon - 360.0
call latlon_to_ij(proj, lat, lon, x, y)
end if
- fg % sst % array(iCell) = interp_sequence(x, y, 1, slab_r8, 1, field % nx, 1, field % ny, 1, 1, -1.e30, interp_list, 1)
+ fg % sst % array(iCell) = interp_sequence(x, y, 1, slab_r8, 1, field % nx, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1)
end do
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))
@@ -4272,19 +4448,28 @@
if (field % iproj == PROJ_LATLON) then
call map_set(PROJ_LATLON, proj, &
- latinc = real(field % deltalat), &
- loninc = real(field % deltalon), &
- knowni = 1.0, &
- knownj = 1.0, &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ latinc = real(field % deltalat,RKIND), &
+ loninc = real(field % deltalon,RKIND), &
+ knowni = 1.0_RKIND, &
+ 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), &
- lat1 = real(field % startlat), &
- lon1 = real(field % startlon))
+ 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 SEAICE/SKINTEMP field to each MPAS grid cell
@@ -4304,16 +4489,19 @@
lon = lon - 360.0
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, interp_list, 1)
+ 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
@@ -4334,81 +4522,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
-
-
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
- ! sphere with given radius.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
-
- real (kind=RKIND) :: arg1
-
- arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
- cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
- sphere_distance = 2.*radius*asin(arg1)
-
- end function sphere_distance
-
-
integer function nearest_cell(target_lat, target_lon, &
start_cell, &
nCells, maxEdges, nEdgesOnCell, cellsOnCell, latCell, lonCell)
@@ -4433,12 +4549,12 @@
do while (nearest_cell /= current_cell)
current_cell = nearest_cell
- current_distance = sphere_distance(latCell(current_cell), lonCell(current_cell), target_lat, target_lon, 1.0)
+ current_distance = sphere_distance(latCell(current_cell), lonCell(current_cell), target_lat, target_lon, 1.0_RKIND)
nearest_cell = current_cell
nearest_distance = current_distance
do i = 1, nEdgesOnCell(current_cell)
iCell = cellsOnCell(i,current_cell)
- d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0)
+ d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0_RKIND)
if (d < nearest_distance) then
nearest_cell = iCell
nearest_distance = d
@@ -4476,13 +4592,13 @@
do while (nearest_edge /= current_edge)
current_edge = nearest_edge
- current_distance = sphere_distance(latEdge(current_edge), lonEdge(current_edge), target_lat, target_lon, 1.0)
+ current_distance = sphere_distance(latEdge(current_edge), lonEdge(current_edge), target_lat, target_lon, 1.0_RKIND)
nearest_edge = current_edge
nearest_distance = current_distance
cell1 = cellsOnEdge(1,current_edge)
cell2 = cellsOnEdge(2,current_edge)
- cell1_dist = sphere_distance(latCell(cell1), lonCell(cell1), target_lat, target_lon, 1.0)
- cell2_dist = sphere_distance(latCell(cell2), lonCell(cell2), target_lat, target_lon, 1.0)
+ cell1_dist = sphere_distance(latCell(cell1), lonCell(cell1), target_lat, target_lon, 1.0_RKIND)
+ cell2_dist = sphere_distance(latCell(cell2), lonCell(cell2), target_lat, target_lon, 1.0_RKIND)
if (cell1_dist < cell2_dist) then
iCell = cell1
else
@@ -4490,7 +4606,7 @@
end if
do i = 1, nEdgesOnCell(iCell)
iEdge = edgesOnCell(i,iCell)
- d = sphere_distance(latEdge(iEdge), lonEdge(iEdge), target_lat, target_lon, 1.0)
+ d = sphere_distance(latEdge(iEdge), lonEdge(iEdge), target_lat, target_lon, 1.0_RKIND)
if (d < nearest_distance) then
nearest_edge = iEdge
nearest_distance = d
@@ -4501,7 +4617,7 @@
end function nearest_edge
- real function vertical_interp(target_z, nz, zf, order, extrap, surface_val, sealev_val)
+ real (kind=RKIND) function vertical_interp(target_z, nz, zf, order, extrap, surface_val, sealev_val)
implicit none
@@ -4603,4 +4719,179 @@
end subroutine init_atm_check_read_error
+
+!----------------------------------------------------------------------------------------------------------
+
+ real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
+ ! sphere with given radius.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ implicit none
+
+ real (kind=RKIND), intent(in) :: lat1, lon1, lat2, lon2, radius
+
+ real (kind=RKIND) :: arg1
+
+ arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + &
+ cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 )
+ sphere_distance = 2.*radius*asin(arg1)
+
+ end function sphere_distance
+
+!--------------------------------------------------------------------
+
+ real (kind=RKIND) function env_qv( z, temperature, pressure, rh_max )
+
+ implicit none
+ real (kind=RKIND) :: z, temperature, pressure, ztr, es, qvs, p0, rh_max
+
+ p0 = 100000.
+
+! ztr = 5000.
+!
+! if(z .gt. ztr) then
+! env_qv = 0.
+! else
+! if(z.lt.2000.) then
+! env_qv = .5
+! else
+! env_qv = .5*(1.-(z-2000.)/(ztr-2000.))
+! end if
+! end if
+
+ if (pressure .lt. 50000. ) then
+ env_qv = 0.0
+ else
+ env_qv = (1.-((p0-pressure)/50000.)**1.25)
+ end if
+
+ env_qv = min(rh_max,env_qv)
+
+! env_qv is the relative humidity, turn it into mixing ratio
+ if (temperature .gt. 273.15) then
+ es = 1000.*0.6112*exp(17.67*(temperature-273.15)/(temperature-29.65))
+ else
+ es = 1000.*0.6112*exp(21.8745584*(temperature-273.16)/(temperature-7.66))
+ end if
+ qvs = (287.04/461.6)*es/(pressure-es)
+
+ ! qvs = 380.*exp(17.27*(temperature-273.)/(temperature-36.))/pressure
+
+ env_qv = env_qv*qvs
+
+ end function env_qv
+
+
+ subroutine physics_idealized_init(mesh, fg)
+
+ implicit none
+
+ !input and output arguments:
+ type(mesh_type),intent(inout):: mesh
+ type (fg_type), intent(inout) :: fg
+
+ !local variables:
+ integer:: iCell,iMonth,iSoil
+
+ !---------------------------------------------------------------------------------------------
+
+ !initialization of surface input variables that are not needed if we run the current set of
+ !idealized test cases:
+
+
+ do iCell = 1, mesh % nCells
+
+ !terrain,soil type, and vegetation:
+ mesh % ter % array(iCell) = 0.
+ fg % xice % array(iCell) = 0.
+ mesh % landmask % array(iCell) = 0
+ mesh % lu_index % array(iCell) = 0
+ mesh % soilcat_top % array(iCell) = 0
+ mesh % shdmin % array(iCell) = 0.
+ mesh % shdmax % array(iCell) = 0.
+ fg % vegfra % array(iCell) = 0.
+ fg % sfc_albbck % array(iCell) = 0.
+ fg % xland % array(iCell) = 0.
+ fg % seaice % array(iCell) = 0.
+
+ !snow coverage:
+ fg % snow % array(iCell) = 0.
+ fg % snowc % array(iCell) = 0.
+ mesh % snoalb % array(iCell) = 0.08
+ fg % snowh % array(iCell) = 0.
+
+ !surface and sea-surface temperatures:
+ fg % skintemp % array(iCell) = 288.0
+ fg % sst % array(iCell) = 288.0
+
+ !soil layers:
+ fg % tmn % array(iCell) = 288.0
+ do iSoil = 1, mesh % nSoilLevels
+ fg % tslb % array(iSoil,iCell) = 288.0
+ fg % smcrel % array(iSoil,iCell) = 0.0
+ fg % sh2o % array(iSoil,iCell) = 0.0
+ fg % smois % array(iSoil,iCell) = 0.0
+ fg % dzs % array(iSoil,iCell) = 0.0
+ enddo
+
+ !monthly climatological surface albedo and greeness fraction:
+ do iMonth = 1, mesh % nMonths
+ mesh % albedo12m % array(iMonth,iCell) = 0.08
+ mesh % greenfrac % array(iMonth,iCell) = 0.
+ enddo
+
+ enddo
+
+ end subroutine physics_idealized_init
+
+
+ subroutine decouple_variables(grid, state, diag)
+
+ implicit none
+
+ type (mesh_type), intent(in) :: grid
+ type (state_type), intent(inout) :: state
+ type (diag_type), intent(inout) :: diag
+
+ integer :: iCell, iEdge, k
+
+ integer, dimension(:,:), pointer :: cellsOnEdge
+ real (kind=RKIND), dimension(:), pointer :: fzm, fzp, rdzw
+ real (kind=RKIND), dimension(:,:), pointer :: zz, pp, ppb
+ real (kind=RKIND), dimension(:,:,:), pointer :: scalars
+
+ cellsOnEdge => grid % CellsOnEdge % array
+ fzp => grid % fzm % array
+ fzp => grid % fzp % array
+ rdzw => grid % rdzw % array
+ zz => grid % zz % array
+
+ pp => diag % pressure_p % array
+ ppb => diag % pressure_base % array
+
+ scalars => state % scalars % array
+
+
+ ! Compute surface pressure
+ do iCell=1,grid%nCells
+ diag % surface_pressure % array(iCell) = 0.5*gravity/rdzw(1) &
+ * (1.25* state % rho_zz % array(1,iCell) * (1. + scalars(state % index_qv, 1, iCell)) &
+ - 0.25* state % rho_zz % array(2,iCell) * (1. + scalars(state % index_qv, 2, iCell)))
+ diag % surface_pressure % array(iCell) = diag % surface_pressure % array(iCell) + pp(1,iCell) + ppb(1,iCell)
+ end do
+
+
+ ! Compute rho and theta from rho_zz and theta_m
+ do iCell=1,grid%nCells
+ do k=1,grid%nVertLevels
+ diag % rho % array(k,iCell) = state % rho_zz % array(k,iCell) * zz(k,iCell)
+ diag % theta % array(k,iCell) = state % theta_m % array(k,iCell) / (1.0 + 1.61 * scalars(state % index_qv,k,iCell))
+ end do
+ end do
+
+ end subroutine decouple_variables
+
+
end module init_atm_test_cases
Modified: branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/Registry
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/Registry 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/Registry 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,10 +1,10 @@
-#
-# namelist type namelist_record name default_value
-#
-namelist integer nhyd_model config_test_case 5
+%
+% namelist type namelist_record name default_value
+%
+namelist integer nhyd_model config_test_case 0
namelist character nhyd_model config_time_integration SRK3
-namelist real nhyd_model config_dt 172.8
-namelist integer nhyd_model config_calendar_type MPAS_GREGORIAN
+namelist real nhyd_model config_dt 600.0
+namelist character nhyd_model config_calendar_type gregorian
namelist character nhyd_model config_start_time 0000-01-01_00:00:00
namelist character nhyd_model config_stop_time none
namelist character nhyd_model config_run_duration none
@@ -17,20 +17,19 @@
namelist real nhyd_model config_h_theta_eddy_visc4 0.0
namelist real nhyd_model config_v_theta_eddy_visc2 0.0
namelist integer nhyd_model config_number_of_sub_steps 4
-namelist integer nhyd_model config_w_adv_order 2
-namelist integer nhyd_model config_theta_adv_order 2
-namelist integer nhyd_model config_scalar_adv_order 2
-namelist integer nhyd_model config_u_vadv_order 2
-namelist integer nhyd_model config_w_vadv_order 2
-namelist integer nhyd_model config_theta_vadv_order 2
-namelist integer nhyd_model config_scalar_vadv_order 2
-namelist real nhyd_model config_coef_3rd_order 1.0
+namelist integer nhyd_model config_w_adv_order 3
+namelist integer nhyd_model config_theta_adv_order 3
+namelist integer nhyd_model config_scalar_adv_order 3
+namelist integer nhyd_model config_u_vadv_order 3
+namelist integer nhyd_model config_w_vadv_order 3
+namelist integer nhyd_model config_theta_vadv_order 3
+namelist integer nhyd_model config_scalar_vadv_order 3
+namelist real nhyd_model config_coef_3rd_order 0.25
namelist logical nhyd_model config_scalar_advection true
namelist logical nhyd_model config_positive_definite false
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_len_disp 120000.0
namelist real nhyd_model config_epssm 0.1
namelist real nhyd_model config_smdiv 0.1
namelist logical nhyd_model config_newpx false
@@ -39,7 +38,7 @@
namelist real damping config_zd 22000.0
namelist real damping config_xnutr 0.0
namelist integer dimensions config_nvertlevels 26
-namelist character io config_input_name grid.nc
+namelist character io config_input_name init.nc
namelist character io config_sfc_update_name sfc_update.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
@@ -52,9 +51,9 @@
namelist logical restart config_do_DAcycling false
namelist character restart config_restart_interval none
-#
-# dim type name_in_file name_in_code
-#
+%
+% dim type name_in_file name_in_code
+%
dim nCells nCells
dim nEdges nEdges
dim maxEdges maxEdges
@@ -70,12 +69,12 @@
dim nVertLevelsP1 nVertLevels+1
dim Scalar 1
-#
-# var type name_in_file ( dims ) iro- name_in_code super-array array_class
-#
+%
+% var type name_in_file ( dims ) iro- name_in_code super-array array_class
+%
var persistent text xtime ( Time ) 2 iro xtime state - -
-# horizontal grid structure
+% horizontal grid structure
var persistent real latCell ( nCells ) 0 iro latCell mesh - -
var persistent real lonCell ( nCells ) 0 iro lonCell mesh - -
@@ -128,9 +127,9 @@
var persistent real meshScalingDel2 ( nEdges ) 0 ro meshScalingDel2 mesh - -
var persistent real meshScalingDel4 ( nEdges ) 0 ro meshScalingDel4 mesh - -
-# some solver scalar coefficients
+% some solver scalar coefficients
-# coefficients for vertical extrapolation to the surface
+% coefficients for vertical extrapolation to the surface
var persistent real cf1 ( Scalar ) 0 iro cf1 mesh - -
var persistent real cf2 ( Scalar ) 0 iro cf2 mesh - -
var persistent real cf3 ( Scalar ) 0 iro cf3 mesh - -
@@ -138,7 +137,7 @@
var persistent real cpr ( THREE nEdges ) 0 ro cpr mesh - -
var persistent real cpl ( THREE nEdges ) 0 ro cpl mesh - -
-# description of the vertical grid structure
+% description of the vertical grid structure
var persistent real hx ( nVertLevelsP1 nCells ) 0 iro hx mesh - -
var persistent real zgrid ( nVertLevelsP1 nCells ) 0 iro zgrid mesh - -
@@ -149,13 +148,13 @@
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...
+% coefficients for the vertical tridiagonal solve
+% Note: these could be local but...
var persistent real cofrz ( nVertLevels Time ) 1 - cofrz diag - -
var persistent real cofwr ( nVertLevels nCells Time ) 1 - cofwr diag - -
@@ -166,11 +165,11 @@
var persistent real alpha_tri ( nVertLevels nCells Time ) 1 - alpha_tri diag - -
var persistent real gamma_tri ( nVertLevels nCells Time ) 1 - gamma_tri diag - -
-# W-Rayleigh-damping coefficient
+% W-Rayleigh-damping coefficient
var persistent real dss ( nVertLevels nCells ) 0 iro dss mesh - -
-# Prognostic variables: read from input, saved in restart, and written to output
+% Prognostic variables: read from input, saved in restart, and written to output
var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
var persistent real w ( nVertLevelsP1 nCells Time ) 2 iro w state - -
var persistent real rho_zz ( nVertLevels nCells Time ) 2 r rho_zz state - -
@@ -184,7 +183,7 @@
var persistent real qnr ( nVertLevels nCells Time ) 2 iro qnr state scalars number
var persistent real qni ( nVertLevels nCells Time ) 2 iro qni state scalars number
-# Tendency variables
+% Tendency variables
var persistent real tend_u ( nVertLevels nEdges Time ) 1 o u tend - -
var persistent real tend_w ( nVertLevelsP1 nCells Time ) 1 o w tend - -
var persistent real tend_rho ( nVertLevels nCells Time ) 1 o rho_zz tend - -
@@ -203,17 +202,17 @@
var persistent real euler_tend_w ( nVertLevelsP1 nCells Time ) 1 - w_euler tend - -
var persistent real euler_tend_theta ( nVertLevels nCells Time ) 1 - theta_euler tend - -
-# state variables diagnosed from prognostic state
+% state variables diagnosed from prognostic state
var persistent real pressure_p ( nVertLevels nCells Time ) 1 ro pressure_p diag - -
var persistent real u_init ( nVertLevels ) 0 iro u_init mesh - -
var persistent real t_init ( nVertLevels nCells ) 0 iro t_init mesh - -
var persistent real qv_init ( nVertLevels ) 0 iro qv_init mesh - -
-# Diagnostic fields: only written to output
-# NOTE: added the "r" option to rho,theta,uReconstructZonal,and uReconstructMeridional for use of the
-# non-hydrostatic dynamical core in a data assimilation framework. NOTE that the "r" option is not
-# needed for those 4 variables to get bit for bit restart capabilities, otherwise.
+% Diagnostic fields: only written to output
+% NOTE: added the "r" option to rho,theta,uReconstructZonal,and uReconstructMeridional for use of the
+% non-hydrostatic dynamical core in a data assimilation framework. NOTE that the "r" option is not
+% needed for those 4 variables to get bit for bit restart capabilities, otherwise.
var persistent real rho ( nVertLevels nCells Time ) 1 iro rho diag - -
var persistent real theta ( nVertLevels nCells Time ) 1 iro theta diag - -
var persistent real rh ( nVertLevels nCells Time ) 1 iro rh diag - -
@@ -231,7 +230,7 @@
var persistent real uReconstructZonal ( nVertLevels nCells Time ) 1 ro uReconstructZonal diag - -
var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 1 ro uReconstructMeridional diag - -
-# Other diagnostic variables: neither read nor written to any files
+% Other diagnostic variables: neither read nor written to any files
var persistent real rv ( nVertLevels nEdges Time ) 1 r rv diag - -
var persistent real circulation ( nVertLevels nVertices Time ) 1 r circulation diag - -
var persistent real gradPVt ( nVertLevels nEdges Time ) 1 - gradPVt diag - -
@@ -251,7 +250,7 @@
var persistent real cqu ( nVertLevels nEdges Time ) 1 - cqu diag - -
var persistent real cqw ( nVertLevels nCells Time ) 1 - cqw diag - -
-# coupled variables needed by the solver, but not output...
+% coupled variables needed by the solver, but not output...
var persistent real ru ( nVertLevels nEdges Time ) 1 r ru diag - -
var persistent real ru_p ( nVertLevels nEdges Time ) 1 r ru_p diag - -
@@ -271,7 +270,7 @@
var persistent real rho_pp ( nVertLevels nCells Time ) 1 - rho_pp diag - -
var persistent real rho_p_save ( nVertLevels nCells Time ) 1 - rho_p_save diag - -
-# Space needed for advection
+% Space needed for advection
var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 ir deriv_two mesh - -
var persistent integer advCells ( TWENTYONE nCells ) 0 ir advCells mesh - -
var persistent real adv_coefs ( FIFTEEN nEdges ) 0 - adv_coefs mesh - -
@@ -280,43 +279,43 @@
var persistent integer nAdvCellsForEdge ( nEdges ) 0 - nAdvCellsForEdge mesh - -
-# Space needed for deformation calculation weights
+% Space needed for deformation calculation weights
var persistent real defc_a ( maxEdges nCells ) 0 iro defc_a mesh - -
var persistent real defc_b ( maxEdges nCells ) 0 iro defc_b mesh - -
-var persistent real kdiff ( nVertLevels nCells Time ) 2 - kdiff diag - -
+var persistent real kdiff ( nVertLevels nCells Time ) 1 - kdiff diag - -
-# Arrays required for reconstruction of velocity field
+% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 iro coeffs_reconstruct mesh - -
-# ADDED DECLARATIONS MADE BY LDF:
+% ADDED DECLARATIONS MADE BY LDF:
var persistent real surface_pressure ( nCells Time ) 1 iro surface_pressure diag - -
var persistent real surface_temperature ( nCells Time ) 1 o surface_temperature diag - -
-#==================================================================================================
-# DECLARATIONS OF ALL PHYSICS VARIABLES (will need to be moved to a Physics Registry shared by the
-# hydrostatic and non-hydrostatic dynamical cores):
-#==================================================================================================
+%==================================================================================================
+% DECLARATIONS OF ALL PHYSICS VARIABLES (will need to be moved to a Physics Registry shared by the
+% hydrostatic and non-hydrostatic dynamical cores):
+%==================================================================================================
-#... NAMELIST VARIABLES ADDED FOR INITIALIZATION OF SURFACE CHARACTERISTICS:
+%... NAMELIST VARIABLES ADDED FOR INITIALIZATION OF SURFACE CHARACTERISTICS:
namelist character physics input_landuse_data USGS
namelist character physics input_soil_data STAS
namelist integer physics input_soil_temperature_lag 140
namelist integer physics num_soil_layers 4
namelist integer physics months 12
-#... NAMELIST VARIABLE NEEDED FOR THE TIME MANAGER:
+%... NAMELIST VARIABLE NEEDED FOR THE TIME MANAGER:
dim nMonths namelist:months
-#... DIMENSION NEEDED FOR NUMBER OF SOIL LAYERS:
+%... DIMENSION NEEDED FOR NUMBER OF SOIL LAYERS:
dim nSoilLevels namelist:num_soil_layers
-#... DIMENSION NEEDED FOR UPDATING THE DEEP SOIL TEMPERATURE:
+%... DIMENSION NEEDED FOR UPDATING THE DEEP SOIL TEMPERATURE:
dim nLags namelist:input_soil_temperature_lag
-#... DIMENSION NEEDED FOR OZONE AND AEROSOLS CONCENTRATIONS IN THE CAM LONGWAVE AND SHORTWAVE
-#... RADIATION PARAMETERIZATIONS.
-# noznlev : number of CAM radiation input ozone levels.
-# naerlev : number of CAM radiation input aerosol levels.
+%... DIMENSION NEEDED FOR OZONE AND AEROSOLS CONCENTRATIONS IN THE CAM LONGWAVE AND SHORTWAVE
+%... RADIATION PARAMETERIZATIONS.
+% noznlev : number of CAM radiation input ozone levels.
+% naerlev : number of CAM radiation input aerosol levels.
namelist integer physics noznlev 59
namelist integer physics naerlev 29
@@ -325,25 +324,26 @@
dim nAerLevels namelist:naerlev
dim cam_dim1 namelist:cam_dim1
-#... DIMENSION NEEDED FOR LONGWAVE AND SHORTWAVE RADIATION FLUXES TO INCLUDE AN ADDITIONAL LAYER
-#... BETWEEN THE TOP OF THE MODEL AND THE TOP OF THE ATMOSPHERE
+%... DIMENSION NEEDED FOR LONGWAVE AND SHORTWAVE RADIATION FLUXES TO INCLUDE AN ADDITIONAL LAYER
+%... BETWEEN THE TOP OF THE MODEL AND THE TOP OF THE ATMOSPHERE
dim nVertLevelsP2 nVertLevels+2
-#... NAMELIST VARIABLES ADDED FOR PHYSICS CONFIGURATION:
+%... NAMELIST VARIABLES ADDED FOR PHYSICS CONFIGURATION:
namelist logical physics config_frac_seaice false
namelist logical physics config_sfc_albedo false
+namelist logical physics config_sfc_snowalbedo false
namelist logical physics config_sst_update false
namelist logical physics config_sstdiurn_update false
namelist logical physics config_deepsoiltemp_update false
-namelist integer physics config_n_physics 01
-namelist integer physics config_n_microp 01
-namelist integer physics config_n_conv 01
-namelist integer physics config_n_pbl 01
-namelist integer physics config_n_lsm 01
-namelist integer physics config_n_eddy 01
-namelist integer physics config_n_radt_lw 01
-namelist integer physics config_n_radt_sw 01
+namelist integer physics config_n_physics 1
+namelist integer physics config_n_microp 1
+namelist integer physics config_n_conv 1
+namelist integer physics config_n_pbl 1
+namelist integer physics config_n_lsm 1
+namelist integer physics config_n_eddy 1
+namelist integer physics config_n_radt_lw 1
+namelist integer physics config_n_radt_sw 1
namelist character physics config_radtlw_interval none
namelist character physics config_radtsw_interval none
@@ -351,6 +351,7 @@
namelist character physics config_pbl_interval none
namelist character physics config_camrad_abs_update 06:00:00
namelist character physics config_greeness_update 24:00:00
+namelist character physics config_bucket_update none
namelist character physics config_microp_scheme off
namelist character physics config_conv_shallow_scheme off
@@ -363,40 +364,45 @@
namelist character physics config_radt_sw_scheme off
namelist character physics config_sfclayer_scheme off
+namelist real physics config_bucket_radt 0.0_RKIND
+namelist real physics config_bucket_rainc 0.0_RKIND
+namelist real physics config_bucket_rainnc 0.0_RKIND
+
var persistent real east ( R3 nCells ) 0 r east mesh - -
var persistent real north ( R3 nCells ) 0 r north mesh - -
-#--------------------------------------------------------------------------------------------------
-#... ARRAYS AND VARIABLES FOR UPDATING THE DEEP SOIL TEMPERATURE:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... ARRAYS AND VARIABLES FOR UPDATING THE DEEP SOIL TEMPERATURE:
+%--------------------------------------------------------------------------------------------------
-# nsteps_accum: number of accumulated time-step in a day.
-# ndays_accum : number of accumulated days in a year.
-# tlag : daily mean surface temperature of prior days [K]
-# tday_accum : accumulated daily surface temperature for current day [K]
-# tyear_mean : annual mean surface temperature [K]
-# tyear_accum : accumulated yearly surface temperature for current year [K]
+% nsteps_accum: number of accumulated time-step in a day.
+% ndays_accum : number of accumulated days in a year.
+% tlag : daily mean surface temperature of prior days [K]
+% tday_accum : accumulated daily surface temperature for current day [K]
+% tyear_mean : annual mean surface temperature [K]
+% tyear_accum : accumulated yearly surface temperature for current year [K]
-var persistent integer nsteps_accum ( nCells Time ) 1 r nsteps_accum diag_physics - -
-var persistent integer ndays_accum ( nCells Time ) 1 r ndays_accum diag_physics - -
+var persistent real nsteps_accum ( nCells Time ) 1 r nsteps_accum diag_physics - -
+var persistent real ndays_accum ( nCells Time ) 1 r ndays_accum diag_physics - -
var persistent real tlag ( nLags nCells Time ) 1 r tlag diag_physics - -
var persistent real tday_accum ( nCells Time ) 1 r tday_accum diag_physics - -
var persistent real tyear_mean ( nCells Time ) 1 r tyear_mean diag_physics - -
var persistent real tyear_accum ( nCells Time ) 1 r tyear_accum diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF CLOUD MICROPHYSICS:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF CLOUD MICROPHYSICS:
+%--------------------------------------------------------------------------------------------------
+% i_rainnc : counter related to how often rainnc is being reset relative to its bucket value (-)
+% rainnc : accumulated total time-step grid-scale precipitation (mm)
+% rainncv : time-step total grid-scale precipitation (mm)
+% snownc : accumulated grid-scale precipitation of snow (mm)
+% snowncv : time-step grid-scale precipitation of snow (mm)
+% graupelnc : accumulated grid-scale precipitation of graupel (mm)
+% graupelncv: time-step grid-scale precipitation of graupel (mm)
+% sr : time-step ratio of frozen versus total grid-scale precipitation (-)
-# rainnc : accumulated total time-step grid-scale precipitation (mm)
-# rainncv : time-step total grid-scale precipitation (mm)
-# snownc : accumulated grid-scale precipitation of snow (mm)
-# snowncv : time-step grid-scale precipitation of snow (mm)
-# graupelnc : accumulated grid-scale precipitation of graupel (mm)
-# graupelncv: time-step grid-scale precipitation of graupel (mm)
-# sr : time-step ratio of frozen versus total grid-scale precipitation (-)
-
+var persistent integer i_rainnc ( nCells Time ) 1 ro i_rainnc diag_physics - -
var persistent real sr ( nCells Time ) 1 ro sr diag_physics - -
var persistent real rainncv ( nCells Time ) 1 ro rainncv diag_physics - -
var persistent real snowncv ( nCells Time ) 1 o snowncv diag_physics - -
@@ -409,61 +415,71 @@
var persistent real qsat ( nVertLevels nCells Time ) 1 o qsat diag_physics - -
var persistent real relhum ( nVertLevels nCells Time ) 1 o relhum diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF CONVECTION:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF CONVECTION:
+%--------------------------------------------------------------------------------------------------
+% i_rainc : counter related to how often rainc is begin reset relative to its bucket value (-)
+% 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)
+% rqicuten : tendency of cloud ice mixing ratio due to cumulus convection (kg/kg s-1)
-# 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 integer i_rainc ( nCells Time ) 1 ro i_rainc 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:
-# nca : relaxation time for KF parameterization of convection (s)
-# wavg0 : average vertical velocity (KF scheme only) (m s-1)
+%... 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 - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF PLANETARY BOUNDARY LAYER PROCESSES:
-#--------------------------------------------------------------------------------------------------
+%... 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)
-# kpbl : index of PBL top (-)
-# hpbl : PBL height (m)
-# exch_h : exchange coefficient (-)
-# rublten : tendency of zonal wind due to pbl processes (m s-1)
-# rvblten : tendency of meridional wind due to pbl processes (m s-1)
-# rthblten : tendency of potential temperature due to pbl processes (K s-1)
-# rqvblten : tendency of water vapor mixing ratio due to pbl processes (kg/kg s-1)
-# rqcblten : tendency of cloud water mixing ratio due to pbl processes (kg/kg s-1)
-# rqiblten : tendency of cloud ice mixing ratio due to pbl processes (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:
+%--------------------------------------------------------------------------------------------------
+
+% kpbl : index of PBL top (-)
+% hpbl : PBL height (m)
+% exch_h : exchange coefficient (-)
+% rublten : tendency of zonal wind due to pbl processes (m s-1)
+% rvblten : tendency of meridional wind due to pbl processes (m s-1)
+% rthblten : tendency of potential temperature due to pbl processes (K s-1)
+% rqvblten : tendency of water vapor mixing ratio due to pbl processes (kg/kg s-1)
+% rqcblten : tendency of cloud water mixing ratio due to pbl processes (kg/kg s-1)
+% rqiblten : tendency of cloud ice mixing ratio due to pbl processes (kg/kg s-1)
+
var persistent integer kpbl ( nCells Time ) 1 ro kpbl diag_physics - -
var persistent real hpbl ( nCells Time ) 1 ro hpbl diag_physics - -
var persistent real exch_h ( nVertLevels nCells Time ) 1 o exch_h diag_physics - -
-# TENDENCIES:
+% TENDENCIES:
var persistent real rublten ( nVertLevels nCells Time ) 1 ro rublten tend_physics - -
var persistent real rvblten ( nVertLevels nCells Time ) 1 ro rvblten tend_physics - -
var persistent real rthblten ( nVertLevels nCells Time ) 1 ro rthblten tend_physics - -
@@ -471,44 +487,44 @@
var persistent real rqcblten ( nVertLevels nCells Time ) 1 ro rqcblten tend_physics - -
var persistent real rqiblten ( nVertLevels nCells Time ) 1 ro rqiblten tend_physics - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF SURFACE LAYER PROCESSES:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF SURFACE LAYER PROCESSES:
+%--------------------------------------------------------------------------------------------------
-# br :bulk richardson number [-]
-# cd :drag coefficient at 10m [-]
-# cda :drag coefficient at lowest model level [-]
-# chs :???
-# chs2 :???
-# cqs2 :???
-# ck :enthalpy exchange coefficient at 10 m [-]
-# cka :enthalpy exchange coefficient at lowest model level [-]
-# cpm :???
-# flhc :exchange coefficient for heat [-]
-# flqc :exchange coefficient for moisture [-]
-# gz1oz0 :log of z1 over z0 [-]
-# hfx :upward heat flux at the surface [W/m2/s]
-# lh :latent heat flux at the surface [W/m2]
-# mavail :surface moisture availability [-]
-# mol :T* in similarity theory [K]
-# psih :similarity theory for heat [-]
-# psim :similarity theory for momentum [-]
-# qfx :upward moisture flux at the surface [kg/m2/s]
-# qgh :???
-# qsfc :specific humidity at lower boundary [kg/kg]
-# regime :flag indicating PBL regime (stable_p,unstable_p,etc...) [-]
-# rmol :1 / Monin Ob length [-]
-# ust :u* in similarity theory [m/s]
-# ustm :u* in similarity theory without vconv [m/s]
-# zol :z/L height over Monin-Obukhov length [-]
-# znt :time-varying roughness length [m]
-# wspd :wind speed [m/s]
-# DIAGNOSTICS:
-# q2 :specific humidity at 2m [kg/kg]
-# u10 :u at 10 m [m/s]
-# v10 :v at 10 m [m/s]
-# t2m :temperature at 2m [K]
-# th2m :potential temperature at 2m [K]
+% br :bulk richardson number [-]
+% cd :drag coefficient at 10m [-]
+% cda :drag coefficient at lowest model level [-]
+% chs :???
+% chs2 :???
+% cqs2 :???
+% ck :enthalpy exchange coefficient at 10 m [-]
+% cka :enthalpy exchange coefficient at lowest model level [-]
+% cpm :???
+% flhc :exchange coefficient for heat [-]
+% flqc :exchange coefficient for moisture [-]
+% gz1oz0 :log of z1 over z0 [-]
+% hfx :upward heat flux at the surface [W/m2/s]
+% lh :latent heat flux at the surface [W/m2]
+% mavail :surface moisture availability [-]
+% mol :T* in similarity theory [K]
+% psih :similarity theory for heat [-]
+% psim :similarity theory for momentum [-]
+% qfx :upward moisture flux at the surface [kg/m2/s]
+% qgh :???
+% qsfc :specific humidity at lower boundary [kg/kg]
+% regime :flag indicating PBL regime (stable_p,unstable_p,etc...) [-]
+% rmol :1 / Monin Ob length [-]
+% ust :u* in similarity theory [m/s]
+% ustm :u* in similarity theory without vconv [m/s]
+% zol :z/L height over Monin-Obukhov length [-]
+% znt :time-varying roughness length [m]
+% wspd :wind speed [m/s]
+% DIAGNOSTICS:
+% q2 :specific humidity at 2m [kg/kg]
+% u10 :u at 10 m [m/s]
+% v10 :v at 10 m [m/s]
+% t2m :temperature at 2m [K]
+% th2m :potential temperature at 2m [K]
var persistent real hfx ( nCells Time ) 1 ro hfx diag_physics - -
var persistent real mavail ( nCells Time ) 1 ro mavail diag_physics - -
@@ -539,34 +555,58 @@
var persistent real regime ( nCells Time ) 1 ro regime diag_physics - -
var persistent real rmol ( nCells Time ) 1 ro rmol diag_physics - -
var persistent real wspd ( nCells Time ) 1 ro wspd diag_physics - -
-# DIAGNOSTICS:
+% DIAGNOSTICS:
var persistent real u10 ( nCells Time ) 1 ro u10 diag_physics - -
var persistent real v10 ( nCells Time ) 1 ro v10 diag_physics - -
var persistent real q2 ( nCells Time ) 1 ro q2 diag_physics - -
var persistent real t2m ( nCells Time ) 1 ro t2m diag_physics - -
var persistent real th2m ( nCells Time ) 1 ro th2m diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF SHORTWAVE RADIATION:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF SHORTWAVE RADIATION:
+%--------------------------------------------------------------------------------------------------
+% coszr :cosine of the solar zenith angle [-]
+% gsw :net shortwave flux at surface [W m-2]
+% swcf :shortwave cloud forcing at top-of-atmosphere [W m-2]
+% swdnb :all-sky downwelling shortwave flux at bottom-of-atmosphere [W m-2]
+% swdnbc :clear-sky downwelling shortwave flux at bottom-of-atmosphere [W m-2]
+% swdnt :all-sky downwelling shortwave flux at top-of-atmosphere [W m-2]
+% swdntc :clear-sky downwelling shortwave flux at top-of-atmosphere [W m-2]
+% swupb :all-sky upwelling shortwave flux at bottom-of-atmosphere [W m-2]
+% swupbc :clear-sky upwelling shortwave flux at bottom-of-atmosphere [W m-2]
+% swupt :all-sky upwelling shortwave flux at top-of-atmosphere [W m-2]
+% swuptc :clear-sky upwelling shortwave flux at top-of-atmosphere [W m-2]
+% acswdnb :accumulated all-sky downwelling shortwave flux at bottom-of-atmosphere [J m-2]
+% acswdnbc :accumulated clear-sky downwelling shortwave flux at bottom-of-atmosphere [J m-2]
+% acswdnt :accumulated all-sky downwelling shortwave flux at top-of-atmosphere [J m-2]
+% acswdntc :accumulated clear-sky downwelling shortwave flux at top-of-atmosphere [J m-2]
+% acswupb :accumulated all-sky upwelling shortwave flux at bottom-of-atmosphere [J m-2]
+% acswupbc :accumulated clear-sky upwelling shortwave flux at bottom-of-atmosphere [J m-2]
+% acswupt :accumulated all-sky upwelling shortwave flux at top-of-atmosphere [J m-2]
+% acswuptc :accumulated clear-sky upwelling shortwave flux at top-of-atmosphere [J m-2]
+% swdnflx :
+% swdnflxc :
+% swupflx :
+% swupflxc :
+% rthratensw:uncoupled theta tendency due to shortwave radiation [K s-1]
-# coszr :cosine of the solar zenith angle [-]
+% i_acswdnb : counter related to how often swdnb is begin reset relative to its bucket value (-)
+% i_acswdnbc: counter related to how often swdnbc is begin reset relative to its bucket value (-)
+% i_acswdnt : counter related to how often swdnt is begin reset relative to its bucket value (-)
+% i_acswdntc: counter related to how often swdntc is begin reset relative to its bucket value (-)
+% i_acswupb : counter related to how often swupb is begin reset relative to its bucket value (-)
+% i_acswupbc: counter related to how often swupbc is begin reset relative to its bucket value (-)
+% i_acswupt : counter related to how often swupt is begin reset relative to its bucket value (-)
+% i_acswuptc: counter related to how often swuptc is begin reset relative to its bucket value (-)
-# gsw :net shortwave flux at surface [W m-2]
-# swcf :shortwave cloud forcing at top-of-atmosphere [W m-2]
-# swdnb :all-sky downwelling shortwave flux at bottom-of-atmosphere [J m-2]
-# swdnbc :clear-sky downwelling shortwave flux at bottom-of-atmosphere [J m-2]
-# swdnt :all-sky downwelling shortwave flux at top-of-atmosphere [J m-2]
-# swdntc :clear-sky downwelling shortwave flux at top-of-atmosphere [J m-2]
-# swupb :all-sky upwelling shortwave flux at bottom-of-atmosphere [J m-2]
-# swupbc :clear-sky upwelling shortwave flux at bottom-of-atmosphere [J m-2]
-# swupt :all-sky upwelling shortwave flux at top-of-atmosphere [J m-2]
-# swuptc :clear-sky upwelling shortwave flux at top-of-atmosphere [J m-2]
-# swdnflx :
-# swdnflxc :
-# swupflx :
-# swupflxc :
-# rthratensw:uncoupled theta tendency due to shortwave radiation [K s-1]
+var persistent integer i_acswdnb ( nCells Time ) 1 ro i_acswdnb diag_physics - -
+var persistent integer i_acswdnbc ( nCells Time ) 1 ro i_acswdnbc diag_physics - -
+var persistent integer i_acswdnt ( nCells Time ) 1 ro i_acswdnt diag_physics - -
+var persistent integer i_acswdntc ( nCells Time ) 1 ro i_acswdntc diag_physics - -
+var persistent integer i_acswupb ( nCells Time ) 1 ro i_acswupb diag_physics - -
+var persistent integer i_acswupbc ( nCells Time ) 1 ro i_acswupbc diag_physics - -
+var persistent integer i_acswupt ( nCells Time ) 1 ro i_acswupt diag_physics - -
+var persistent integer i_acswuptc ( nCells Time ) 1 ro i_acswuptc diag_physics - -
var persistent real coszr ( nCells Time ) 1 o coszr diag_physics - -
var persistent real swcf ( nCells Time ) 1 o swcf diag_physics - -
@@ -578,42 +618,76 @@
var persistent real swupbc ( nCells Time ) 1 o swupbc diag_physics - -
var persistent real swupt ( nCells Time ) 1 o swupt diag_physics - -
var persistent real swuptc ( nCells Time ) 1 o swuptc diag_physics - -
+var persistent real acswdnb ( nCells Time ) 1 ro acswdnb diag_physics - -
+var persistent real acswdnbc ( nCells Time ) 1 ro acswdnbc diag_physics - -
+var persistent real acswdnt ( nCells Time ) 1 ro acswdnt diag_physics - -
+var persistent real acswdntc ( nCells Time ) 1 ro acswdntc diag_physics - -
+var persistent real acswupb ( nCells Time ) 1 ro acswupb diag_physics - -
+var persistent real acswupbc ( nCells Time ) 1 ro acswupbc diag_physics - -
+var persistent real acswupt ( nCells Time ) 1 ro acswupt diag_physics - -
+var persistent real acswuptc ( nCells Time ) 1 ro acswuptc diag_physics - -
var persistent real gsw ( nCells Time ) 1 ro gsw diag_physics - -
var persistent real rthratensw ( nVertLevels nCells Time ) 1 ro rthratensw tend_physics - -
-#... RRTMG SW ONLY:
+%... RRTMG SW ONLY:
var persistent real swdnflx ( nVertLevelsP2 nCells Time ) 1 o swdnflx diag_physics - -
var persistent real swdnflxc ( nVertLevelsP2 nCells Time ) 1 o swdnflxc diag_physics - -
var persistent real swupflx ( nVertLevelsP2 nCells Time ) 1 o swupflx diag_physics - -
var persistent real swupflxc ( nVertLevelsP2 nCells Time ) 1 o swupflxc diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF LONGWAVE RADIATION:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF LONGWAVE RADIATION:
+%--------------------------------------------------------------------------------------------------
-# note: glw is the same diagnostic as lwdnb and is used in the land-surface scheme for the calcula-
-# tion of the surface budget. glw is always an output argument to the subroutine rrtmg_lwrad.
-# in contrast,lwdnb is an optional ouput argument to the subroutine rrtmg_lwrad depending on
-# the presence of lwupt (or not).
+% note: glw is the same diagnostic as lwdnb and is used in the land-surface scheme for the calcula-
+% tion of the surface budget. glw is always an output argument to the subroutine rrtmg_lwrad.
+% in contrast,lwdnb is an optional ouput argument to the subroutine rrtmg_lwrad depending on
+% the presence of lwupt (or not).
-# glw :all-sky downwelling longwave flux at bottom-of-atmosphere [W m-2]
-# lwcf :longwave cloud forcing at top-of-atmosphere [W m-2]
-# lwdnb :all-sky downwelling longwave flux at bottom-of-atmosphere [W m-2]
-# lwdnbc :clear-sky downwelling longwave flux at bottom-of-atmosphere [W m-2]
-# lwdnt :all-sky downwelling longwave flux at top-of-atmosphere [W m-2]
-# lwdntc :clear-sky downwelling longwave flux at top-of-atmosphere [W m-2]
-# lwupb :all-sky upwelling longwave flux at bottom-of-atmosphere [W m-2]
-# lwupbc :clear-sky upwelling longwave flux at bottom-of-atmosphere [W m-2]
-# lwupt :all-sky upwelling longwave flux at top-of-atmosphere [W m-2]
-# lwuptc :clear-sky upwelling longwave flux at top-of-atmosphere [W m-2]
-# lwdnflx :
-# lwdnflxc :
-# lwupflx :
-# lwupflxc :
-# olrtoa :outgoing longwave radiation at top-of-the-atmosphere [W m-2]
-# rthratenlw:uncoupled theta tendency due to longwave radiation [K s-1]
+% glw :all-sky downwelling longwave flux at bottom-of-atmosphere [W m-2]
+% lwcf :longwave cloud forcing at top-of-atmosphere [W m-2]
+% lwdnb :all-sky downwelling longwave flux at bottom-of-atmosphere [W m-2]
+% lwdnbc :clear-sky downwelling longwave flux at bottom-of-atmosphere [W m-2]
+% lwdnt :all-sky downwelling longwave flux at top-of-atmosphere [W m-2]
+% lwdntc :clear-sky downwelling longwave flux at top-of-atmosphere [W m-2]
+% lwupb :all-sky upwelling longwave flux at bottom-of-atmosphere [W m-2]
+% lwupbc :clear-sky upwelling longwave flux at bottom-of-atmosphere [W m-2]
+% lwupt :all-sky upwelling longwave flux at top-of-atmosphere [W m-2]
+% lwuptc :clear-sky upwelling longwave flux at top-of-atmosphere [W m-2]
+% aclwdnb :accumulated all-sky downwelling longwave flux at bottom-of-atmosphere [J m-2]
+% aclwdnbc :accumulated clear-sky downwelling longwave flux at bottom-of-atmosphere [J m-2]
+% aclwdnt :accumulated all-sky downwelling longwave flux at top-of-atmosphere [J m-2]
+% aclwdntc :accumulated clear-sky downwelling longwave flux at top-of-atmosphere [J m-2]
+% aclwupb :accumulated all-sky upwelling longwave flux at bottom-of-atmosphere [J m-2]
+% aclwupbc :accumulated clear-sky upwelling longwave flux at bottom-of-atmosphere [J m-2]
+% aclwupt :accumulated all-sky upwelling longwave flux at top-of-atmosphere [J m-2]
+% aclwuptc :accumulated clear-sky upwelling longwave flux at top-of-atmosphere [J m-2]
+% lwdnflx :
+% lwdnflxc :
+% lwupflx :
+% lwupflxc :
+% olrtoa :outgoing longwave radiation at top-of-the-atmosphere [W m-2]
+% rthratenlw:uncoupled theta tendency due to longwave radiation [K s-1]
+% i_aclwdnb : counter related to how often lwdnb is begin reset relative to its bucket value (-)
+% i_aclwdnbc: counter related to how often lwdnbc is begin reset relative to its bucket value (-)
+% i_aclwdnt : counter related to how often lwdnt is begin reset relative to its bucket value (-)
+% i_aclwdntc: counter related to how often lwdntc is begin reset relative to its bucket value (-)
+% i_aclwupb : counter related to how often lwupb is begin reset relative to its bucket value (-)
+% i_aclwupbc: counter related to how often lwupbc is begin reset relative to its bucket value (-)
+% i_aclwupt : counter related to how often lwupt is begin reset relative to its bucket value (-)
+% i_aclwuptc: counter related to how often lwuptc is begin reset relative to its bucket value (-)
+
+var persistent integer i_aclwdnb ( nCells Time ) 1 ro i_aclwdnb diag_physics - -
+var persistent integer i_aclwdnbc ( nCells Time ) 1 ro i_aclwdnbc diag_physics - -
+var persistent integer i_aclwdnt ( nCells Time ) 1 ro i_aclwdnt diag_physics - -
+var persistent integer i_aclwdntc ( nCells Time ) 1 ro i_aclwdntc diag_physics - -
+var persistent integer i_aclwupb ( nCells Time ) 1 ro i_aclwupb diag_physics - -
+var persistent integer i_aclwupbc ( nCells Time ) 1 ro i_aclwupbc diag_physics - -
+var persistent integer i_aclwupt ( nCells Time ) 1 ro i_aclwupt diag_physics - -
+var persistent integer i_aclwuptc ( nCells Time ) 1 ro i_aclwuptc diag_physics - -
+
var persistent real lwcf ( nCells Time ) 1 o lwcf diag_physics - -
var persistent real lwdnb ( nCells Time ) 1 o lwdnb diag_physics - -
var persistent real lwdnbc ( nCells Time ) 1 o lwdnbc diag_physics - -
@@ -623,35 +697,43 @@
var persistent real lwupbc ( nCells Time ) 1 o lwupbc diag_physics - -
var persistent real lwupt ( nCells Time ) 1 o lwupt diag_physics - -
var persistent real lwuptc ( nCells Time ) 1 o lwuptc diag_physics - -
+var persistent real aclwdnb ( nCells Time ) 1 ro aclwdnb diag_physics - -
+var persistent real aclwdnbc ( nCells Time ) 1 ro aclwdnbc diag_physics - -
+var persistent real aclwdnt ( nCells Time ) 1 ro aclwdnt diag_physics - -
+var persistent real aclwdntc ( nCells Time ) 1 ro aclwdntc diag_physics - -
+var persistent real aclwupb ( nCells Time ) 1 ro aclwupb diag_physics - -
+var persistent real aclwupbc ( nCells Time ) 1 ro aclwupbc diag_physics - -
+var persistent real aclwupt ( nCells Time ) 1 ro aclwupt diag_physics - -
+var persistent real aclwuptc ( nCells Time ) 1 ro aclwuptc diag_physics - -
var persistent real olrtoa ( nCells Time ) 1 o olrtoa diag_physics - -
var persistent real glw ( nCells Time ) 1 ro glw diag_physics - -
var persistent real rthratenlw ( nVertLevels nCells Time ) 1 ro rthratenlw tend_physics - -
-#... RRTMG LW ONLY:
-#var persistent real lwdnflx ( nVertLevelsP2 nCells Time ) 1 o lwdnflx diag_physics - -
-#var persistent real lwdnflxc ( nVertLevelsP2 nCells Time ) 1 o lwdnflxc diag_physics - -
-#var persistent real lwupflx ( nVertLevelsP2 nCells Time ) 1 o lwupflx diag_physics - -
-#var persistent real lwupflxc ( nVertLevelsP2 nCells Time ) 1 o lwupflxc diag_physics - -
+%... RRTMG LW ONLY:
+%var persistent real lwdnflx ( nVertLevelsP2 nCells Time ) 1 o lwdnflx diag_physics - -
+%var persistent real lwdnflxc ( nVertLevelsP2 nCells Time ) 1 o lwdnflxc diag_physics - -
+%var persistent real lwupflx ( nVertLevelsP2 nCells Time ) 1 o lwupflx diag_physics - -
+%var persistent real lwupflxc ( nVertLevelsP2 nCells Time ) 1 o lwupflxc diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... ADDITIONAL "RADIATION" ARRAYS NEEDED ONLY IN THE "CAM" LW AND SW RADIATION CODES:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... ADDITIONAL "RADIATION" ARRAYS NEEDED ONLY IN THE "CAM" LW AND SW RADIATION CODES:
+%--------------------------------------------------------------------------------------------------
-#INFRARED ABSORPTION:
-var persistent real absnxt ( nVertLevels cam_dim1 nCells Time ) 1 - absnxt diag_physics - -
-var persistent real abstot ( nVertLevelsP1 nVertLevelsP1 nCells Time ) 1 - abstot diag_physics - -
-var persistent real emstot ( nVertLevelsP1 nCells Time ) 1 - emstot diag_physics - -
+%INFRARED ABSORPTION:
+var persistent real absnxt ( nVertLevels cam_dim1 nCells Time ) 1 r absnxt diag_physics - -
+var persistent real abstot ( nVertLevelsP1 nVertLevelsP1 nCells Time ) 1 r abstot diag_physics - -
+var persistent real emstot ( nVertLevelsP1 nCells Time ) 1 r emstot diag_physics - -
-# OZONE:
+% OZONE:
var persistent real pin ( nOznLevels nCells ) 0 - pin mesh - -
var persistent real ozmixm ( nMonths nOznLevels nCells ) 0 - ozmixm mesh - -
-# AEROSOLS:
+% AEROSOLS:
var persistent real m_hybi ( nAerLevels nCells ) 0 - m_hybi mesh - -
var persistent real m_ps ( nCells Time ) 2 - m_ps state - -
-#var persistent real dummy ( nAerLevels nCells Time ) 2 - dummy state aerosols aer_cam
+%var persistent real dummy ( nAerLevels nCells Time ) 2 - dummy state aerosols aer_cam
var persistent real sul ( nAerLevels nCells Time ) 2 - sul state aerosols aer_cam
var persistent real sslt ( nAerLevels nCells Time ) 2 - sslt state aerosols aer_cam
var persistent real dust1 ( nAerLevels nCells Time ) 2 - dust1 state aerosols aer_cam
@@ -665,43 +747,43 @@
var persistent real bg ( nAerLevels nCells Time ) 2 - bg state aerosols aer_cam
var persistent real volc ( nAerLevels nCells Time ) 2 - volc state aerosols aer_cam
-#--------------------------------------------------------------------------------------------------
-#... PARAMERIZATION OF CLOUDINESS:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMERIZATION OF CLOUDINESS:
+%--------------------------------------------------------------------------------------------------
-# cldfrac :cloud fraction [-]
+% cldfrac :cloud fraction [-]
var persistent real cldfrac ( nVertLevels nCells Time ) 1 o cldfrac diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... PARAMETERIZATION OF LAND-SURFACE SCHEME:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... PARAMETERIZATION OF LAND-SURFACE SCHEME:
+%--------------------------------------------------------------------------------------------------
-# acsnom :accumulated melted snow [kg m-2]
-# acsnow :accumulated snow [kg m-2]
-# canwat :canopy water [kg m-2]
-# chklowq :surface saturation flag [-]
-# grdflx :ground heat flux [W m-2]
-# lai :leaf area index [-]
-# noahres :residual of the noah land-surface scheme energy budget [W m-2]
-# potevp :potential evaporation [W m-2]
-# qz0 :specific humidity at znt [kg kg-1]
-# rib :??
-# sfc_albedo :surface albedo [-]
-# sfc_embck :background emissivity [-]
-# sfc_emiss :surface emissivity [-]
-# sfcrunoff :surface runoff [m s-1]
-# smstav :moisture availability [-]
-# smstot :total moisture [m3 m-3]
-# snopcx :snow phase change heat flux [W m-2]
-# snotime :??
-# sstsk : skin sea-surface temperature [K]
-# sstsk_diur : skin sea-surface temperature difference [K]
-# thc :thermal inertia [Cal cm-1 K-1 s-0.5]
-# udrunoff :sub-surface runoff [m s-1]
-# xicem :ice mask from previous time-step [-]
-# z0 :background roughness length [m]
-# zs :depth of centers of soil layers [m]
+% acsnom :accumulated melted snow [kg m-2]
+% acsnow :accumulated snow [kg m-2]
+% canwat :canopy water [kg m-2]
+% chklowq :surface saturation flag [-]
+% grdflx :ground heat flux [W m-2]
+% lai :leaf area index [-]
+% noahres :residual of the noah land-surface scheme energy budget [W m-2]
+% potevp :potential evaporation [W m-2]
+% qz0 :specific humidity at znt [kg kg-1]
+% rib :??
+% sfc_albedo :surface albedo [-]
+% sfc_embck :background emissivity [-]
+% sfc_emiss :surface emissivity [-]
+% sfcrunoff :surface runoff [m s-1]
+% smstav :moisture availability [-]
+% smstot :total moisture [m3 m-3]
+% snopcx :snow phase change heat flux [W m-2]
+% snotime :??
+% sstsk : skin sea-surface temperature [K]
+% sstsk_diur : skin sea-surface temperature difference [K]
+% thc :thermal inertia [Cal cm-1 K-1 s-0.5]
+% udrunoff :sub-surface runoff [m s-1]
+% xicem :ice mask from previous time-step [-]
+% z0 :background roughness length [m]
+% zs :depth of centers of soil layers [m]
var persistent real acsnom ( nCells Time ) 1 ro acsnom diag_physics - -
var persistent real acsnow ( nCells Time ) 1 ro acsnow diag_physics - -
@@ -729,36 +811,36 @@
var persistent real z0 ( nCells Time ) 1 ro z0 diag_physics - -
var persistent real zs ( nCells Time ) 1 ro zs diag_physics - -
-#--------------------------------------------------------------------------------------------------
-#... SURFACE CHARACTERISTICS THAT NEED TO BE READ FROM GRID.NC:
-#--------------------------------------------------------------------------------------------------
+%--------------------------------------------------------------------------------------------------
+%... SURFACE CHARACTERISTICS THAT NEED TO BE READ FROM GRID.NC:
+%--------------------------------------------------------------------------------------------------
-# albedo12m :monthly climatological albedo [-]
-# greenfrac :monthly climatological greeness fraction [-]
-# isltyp :dominant soil category [-]
-# ivgtyp :dominant vegetation category [-]
-# landmask :=0 for ocean;=1 for land [-]
-# sfc_albbck :background albedo [-]
-# shdmin :minimum areal fractional coverage of annual green vegetation [-]
-# shdmax :maximum areal fractional coverage of annual green vegetation [-]
-# skintemp :skin temperature [K]
-# snoalb :annual max snow albedo [-]
-# snow :snow water equivalent [kg m-2]
-# sst :sea-surface temperature [K]
-# snowc :flag indicating snow coverage (1 for snow cover) [-]
-# snowh :physical snow depth [m]
-# ter :terrain height [-]
-# tmn :soil temperature at lower boundary [K]
-# vegfra :vegetation fraction [-]
-# seaice :sea-ice mask (=1 when xice is greater than 0; =0 otherwise) [-]
-# xice :fractional sea-ice coverage [-]
-# xland :land mask (1 for land; 2 for water) [-]
+% albedo12m :monthly climatological albedo [-]
+% greenfrac :monthly climatological greeness fraction [-]
+% isltyp :dominant soil category [-]
+% ivgtyp :dominant vegetation category [-]
+% landmask :=0 for ocean;=1 for land [-]
+% sfc_albbck :background albedo [-]
+% shdmin :minimum areal fractional coverage of annual green vegetation [-]
+% shdmax :maximum areal fractional coverage of annual green vegetation [-]
+% skintemp :skin temperature [K]
+% snoalb :annual max snow albedo [-]
+% snow :snow water equivalent [kg m-2]
+% sst :sea-surface temperature [K]
+% snowc :flag indicating snow coverage (1 for snow cover) [-]
+% snowh :physical snow depth [m]
+% ter :terrain height [-]
+% tmn :soil temperature at lower boundary [K]
+% vegfra :vegetation fraction [-]
+% seaice :sea-ice mask (=1 when xice is greater than 0; =0 otherwise) [-]
+% xice :fractional sea-ice coverage [-]
+% xland :land mask (1 for land; 2 for water) [-]
-# dzs :thickness of soil layers [m]
-# smcrel :soil moisture threshold below which transpiration begins to stress [-]
-# sh2o :soil liquid water [m3 m-3]
-# smois :soil moisture [m3 m-3]
-# tslb :soil temperature [K]
+% dzs :thickness of soil layers [m]
+% smcrel :soil moisture threshold below which transpiration begins to stress [-]
+% sh2o :soil liquid water [m3 m-3]
+% smois :soil moisture [m3 m-3]
+% tslb :soil temperature [K]
var persistent integer isltyp ( nCells ) 0 iro isltyp sfc_input - -
var persistent integer ivgtyp ( nCells ) 0 iro ivgtyp sfc_input - -
@@ -788,4 +870,4 @@
var persistent real smois ( nSoilLevels nCells Time ) 1 iro smois sfc_input - -
var persistent real tslb ( nSoilLevels nCells Time ) 1 iro tslb sfc_input - -
-#==================================================================================================
+%==================================================================================================
Modified: branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_advection.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_advection.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_advection.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,6 @@
module atm_advection
+ use mpas_kind_types
use mpas_grid_types
use mpas_configure
use mpas_constants
@@ -117,7 +118,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -390,7 +391,7 @@
! Computes the angle between arcs AB and AC, given points A, B, and C
! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+ real (kind=RKIND) function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
implicit none
@@ -410,9 +411,9 @@
real (kind=RKIND) :: s ! Semiperimeter of the triangle
real (kind=RKIND) :: sin_angle
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1)
ABx = bx - ax
ABy = by - ay
@@ -428,12 +429,12 @@
s = 0.5*(a + b + c)
! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.0_RKIND,max(0.0_RKIND,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
end if
end function sphere_angle
@@ -445,7 +446,7 @@
! Computes the angle between vectors AB and AC, given points A, B, and C, and
! a vector (u,v,w) normal to the plane.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+ real (kind=RKIND) function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
implicit none
@@ -480,9 +481,9 @@
cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = -acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
end if
end function plane_angle
@@ -495,7 +496,7 @@
! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
! same sphere centered at the origin.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
+ real (kind=RKIND) function arc_length(ax, ay, az, bx, by, bz)
implicit none
@@ -701,7 +702,7 @@
DO I = 1, N
C1= 0.0
DO J = 1, N
- C1 = AMAX1(C1,ABS(A(I,J)))
+ C1 = MAX(C1,ABS(A(I,J)))
END DO
C(I) = C1
END DO
@@ -838,7 +839,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -890,10 +891,10 @@
do i=2,n-1
ip1 = i+1
if (ip1 == n) ip1 = 1
- thetat(i) = plane_angle( 0.,0.,0., &
- xp(i)-xp(i-1), yp(i)-yp(i-1), 0., &
- xp(ip1)-xp(i), yp(ip1)-yp(i), 0., &
- 0., 0., 1.)
+ thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, &
+ xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, &
+ xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, &
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND)
thetat(i) = thetat(i) + thetat(i-1)
end do
Modified: branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_mpas_core.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_mpas_core.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -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
@@ -462,11 +499,6 @@
call atm_timestep(domain, dt, timeStamp, itimestep)
-#ifdef DO_PHYSICS
- !update physics diagnostics at the end of dynamic time-step:
- if(moist_physics) call physics_update(domain,dt)
-#endif
-
end subroutine atm_do_timestep
@@ -560,12 +592,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 +609,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: branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_test_cases.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_test_cases.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_test_cases.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -5,7 +5,9 @@
use mpas_constants
use mpas_dmpar
use atm_advection
+#ifdef DO_PHYSICS
use mpas_atmphys_control
+#endif
contains
@@ -94,6 +96,8 @@
stop
end if
+
+#ifdef DO_PHYSICS
!initialization of surface input variables technically not needed to run our current set of
!idealized test cases:
if (config_test_case > 0) then
@@ -105,6 +109,7 @@
end do
endif
+#endif
end subroutine atm_setup_test_case
@@ -136,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:
@@ -153,8 +158,8 @@
integer :: eoe, j
integer, dimension(:), pointer :: nEdgesOnEdge
integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
- real, dimension(:), pointer :: dvEdge, AreaCell
- real, dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
real (kind=RKIND) :: u, v, flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r
@@ -214,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
@@ -666,7 +669,7 @@
if (config_test_case == 2) then
r_pert = sphere_distance( grid % latEdge % array (iEdge), grid % lonEdge % array (iEdge), &
- lat_pert, lon_pert, 1.)/(pert_radius)
+ lat_pert, lon_pert, 1.0_RKIND)/(pert_radius)
u_pert = u_perturbation*exp(-r_pert**2)*(lat2-lat1)*a/grid % dvEdge % array(iEdge)
else if (config_test_case == 3) then
@@ -760,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
@@ -781,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.,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.,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
@@ -881,7 +879,7 @@
! renormalize for setting cell-face fluxes
do k=1,nz1
- flux_zonal(k) = sign(1.,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
+ flux_zonal(k) = sign(1.0_RKIND,lat2_in-lat1_in)*flux_zonal(k)*dlat*a/dvEdge/u0
end do
end subroutine atm_calc_flux_zonal
@@ -1004,7 +1002,7 @@
integer :: eoe, j
integer, dimension(:), pointer :: nEdgesOnEdge
integer, dimension(:,:), pointer :: edgesOnEdge
- real, dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2, nCellsSolve
integer :: index_qv
@@ -1320,7 +1318,7 @@
temp = p(k,i)*thi(k,i)
pres = p0*p(k,i)**(1./rcp)
qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
+ scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
end do
end do
@@ -1469,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.
@@ -1536,14 +1532,14 @@
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
integer, dimension(:), pointer :: nEdgesOnEdge
integer, dimension(:,:), pointer :: edgesOnEdge, CellsOnEdge
- real, dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell
- real, dimension(:,:), pointer :: weightsOnEdge
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, AreaCell, xCell, yCell
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, itrp, cell1, cell2, nCellsSolve
integer :: index_qv
@@ -1603,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
@@ -1769,7 +1763,7 @@
! smoothing grid for the upper level >> but not propoer for parallel programing
dzmin=.7
do k=2,nz1
- sm = .25*min((zc(k)-zc(k-1))/dz,1.)
+ sm = .25*min((zc(k)-zc(k-1))/dz,1.0_RKIND)
do i=1,grid % nCells
hx(k,i) = hx(k-1,i)
end do
@@ -1871,7 +1865,11 @@
+zgrid(k,cell2)+zgrid(k+1,cell2))
u(k,i) = um
if(i == 1 ) grid % u_init % array(k) = u(k,i) - us
+#ifdef ROTATED_GRID
+ u(k,i) = sin(grid % angleEdge % array(i)) * (u(k,i) - us)
+#else
u(k,i) = cos(grid % angleEdge % array(i)) * (u(k,i) - us)
+#endif
end do
end if
end do
@@ -1946,7 +1944,7 @@
temp = p(k,i)*t(k,i)
pres = p0*p(k,i)**(1./rcp)
qvs = 380.*exp(17.27*(temp-273.)/(temp-36.))/pres
- scalars(index_qv,k,i) = amin1(0.014,rh(k,i)*qvs)
+ scalars(index_qv,k,i) = min(0.014_RKIND,rh(k,i)*qvs)
end do
do k=1,nz1
@@ -2036,13 +2034,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
@@ -2064,14 +2055,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.,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.,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
@@ -2128,7 +2121,7 @@
!----------------------------------------------------------------------------------------------------------
- real function sphere_distance(lat1, lon1, lat2, lon2, radius)
+ real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a
! sphere with given radius.
@@ -2147,10 +2140,10 @@
end function sphere_distance
!--------------------------------------------------------------------
- real function env_qv( z, temperature, pressure, rh_max )
+ real (kind=RKIND) function env_qv( z, temperature, pressure, rh_max )
implicit none
- real z, temperature, pressure, ztr, es, qvs, p0, rh_max
+ real (kind=RKIND) :: z, temperature, pressure, ztr, es, qvs, p0, rh_max
p0 = 100000.
Modified: branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_time_integration.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_time_integration.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_nhyd_atmos/mpas_atm_time_integration.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -93,8 +93,6 @@
logical, parameter :: debug = .false.
! logical, parameter :: debug = .true.
logical, parameter :: debug_mass_conservation = .true.
-! logical, parameter :: do_microphysics = .true.
- logical, parameter :: do_microphysics = .false.
integer :: index_qc
real (kind=RKIND) :: domain_mass, scalar_mass, scalar_min, scalar_max
@@ -145,10 +143,6 @@
call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % diag % rtheta_p % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-!surface_pressure
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, block % diag % surface_pressure % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
block => block % next
end do
@@ -192,7 +186,7 @@
block => domain % blocklist
do while (associated(block))
call physics_addtend( domain % dminfo , block % parinfo % cellsToSend, block % parinfo % cellsToRecv, &
- block % mesh , block % state % time_levs(2) % state, block % diag, block % tend, &
+ block % mesh , block % state % time_levs(1) % state, block % diag, block % tend, &
block % tend_physics , block % state % time_levs(2) % state % rho_zz % array(:,:), &
block % diag % rho_edge % array(:,:) )
block => block % next
@@ -401,11 +395,24 @@
block => block % next
end do
-!... call to parameterizations of cloud microphysics:
+!... call to parameterizations of cloud microphysics. calculation of the tendency of water vapor to horizontal and
+!... vertical advection needed for the Tiedtke parameterization of convection.
#ifdef DO_PHYSICS
block => domain % blocklist
do while(associated(block))
+ !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio
+ !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo
+ !update for the scalars at time_levs(1) is applied. A halo update for the scalars at time_levs(2) is done above.
+ if(config_monotonic) then
+ block % tend_physics % rqvdynten % array(:,:) = &
+ ( block % state % time_levs(2) % state % scalars % array(block % state % time_levs(2) % state % index_qv,:,:) &
+ - block % state % time_levs(1) % state % scalars % array(block % state % time_levs(1) % state % index_qv,:,:) ) &
+ / config_dt
+ else
+ block % tend_physics % rqvdynten % array(:,:) = 0._RKIND
+ endif
+
!simply set to zero negative mixing ratios of different water species (for now):
where ( block % state % time_levs(2) % state % scalars % array(:,:,:) .lt. 0.) &
block % state % time_levs(2) % state % scalars % array(:,:,:) = 0.
@@ -419,13 +426,6 @@
end do
#endif
-! if(do_microphysics) then
-! block => domain % blocklist
-! do while (associated(block))
-! call atm_qd_kessler( block % state % time_levs(1) % state, block % state % time_levs(2) % state, block % mesh, dt )
-! block => block % next
-! end do
-! end if
! if(debug) then
101 format(' local min, max scalar',i4,2(1x,e17.10))
@@ -678,14 +678,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, 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
@@ -712,18 +714,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.,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.,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
@@ -753,7 +752,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
@@ -801,6 +800,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
@@ -869,7 +871,7 @@
do k=2,nVertLevels
- kr = min(nVertLevels,k+ nint(.5-sign(.5,zx(k,iEdge)+zx(k+1,iEdge))))
+ 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 = zz(k,cell2)*rtheta_pp_old(k ,cell2)+.5*(zgrid(k ,cell1) +zgrid(k +1,cell1) &
-zgrid(k ,cell2) -zgrid(k +1,cell2)) &
@@ -887,23 +889,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))
@@ -991,11 +1024,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
@@ -1010,7 +1043,7 @@
rho_pp, rho_zz, rho_base, ruAvg, ru_save, ru_p, u, ru, &
exner, exner_base, rtheta_base, pressure_p, &
zz, theta_m, pressure_b, qvapor
- real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, AreaCell, rdzw, surface_pressure
+ real (kind=RKIND), dimension(:), pointer :: fzm, fzp, dvEdge, AreaCell
real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3
integer, dimension(:,:), pointer :: cellsOnEdge
@@ -1053,9 +1086,7 @@
pressure_p => diag % pressure_p % array
pressure_b => diag % pressure_base % array
- surface_pressure => diag % surface_pressure % array
- rdzw => grid % rdzw % array
zz => grid % zz % array
zb => grid % zb % array
zb3 => grid % zb3 % array
@@ -1130,13 +1161,6 @@
* (exner(k,iCell)-exner_base(k,iCell)))
end do
- !calculation of the surface pressure:
- surface_pressure(iCell) = 0.5*gravity/rdzw(1) &
- * (1.25* rho_zz(1,iCell) * (1. + qvapor(1,iCell)) &
- - 0.25* rho_zz(2,iCell) * (1. + qvapor(2,iCell)))
- surface_pressure(iCell) = surface_pressure(iCell) + pressure_p(1,iCell) + pressure_b(1,iCell)
-
-
end do
! recover time-averaged ruAvg on all edges of owned cells (for upcoming scalar transport).
@@ -1167,16 +1191,16 @@
!SHP-mtn
flux = cf1*ru(1,iEdge) + cf2*ru(2,iEdge) + cf3*ru(3,iEdge)
- w(1,cell2) = w(1,cell2) - (zb(1,2,iEdge) + sign(1.,flux)*coef_3rd_order*zb3(1,2,iEdge)) &
+ w(1,cell2) = w(1,cell2) - (zb(1,2,iEdge) + sign(1.0_RKIND,flux)*coef_3rd_order*zb3(1,2,iEdge)) &
*flux/(cf1*rho_zz(1,cell2)+cf2*rho_zz(2,cell2)+cf3*rho_zz(3,cell2))
- w(1,cell1) = w(1,cell1) + (zb(1,1,iEdge) + sign(1.,flux)*coef_3rd_order*zb3(1,1,iEdge)) &
+ w(1,cell1) = w(1,cell1) + (zb(1,1,iEdge) + sign(1.0_RKIND,flux)*coef_3rd_order*zb3(1,1,iEdge)) &
*flux/(cf1*rho_zz(1,cell1)+cf2*rho_zz(2,cell1)+cf3*rho_zz(3,cell1))
do k = 2, nVertLevels
flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge))
- w(k,cell2) = w(k,cell2) - (zb(k,2,iEdge)+sign(1.,flux)*coef_3rd_order*zb3(k,2,iEdge)) &
+ w(k,cell2) = w(k,cell2) - (zb(k,2,iEdge)+sign(1.0_RKIND,flux)*coef_3rd_order*zb3(k,2,iEdge)) &
*flux/(fzm(k)*rho_zz(k,cell2)+fzp(k)*rho_zz(k-1,cell2))
- w(k,cell1) = w(k,cell1) + (zb(k,1,iEdge)+sign(1.,flux)*coef_3rd_order*zb3(k,1,iEdge)) &
+ w(k,cell1) = w(k,cell1) + (zb(k,1,iEdge)+sign(1.0_RKIND,flux)*coef_3rd_order*zb3(k,1,iEdge)) &
*flux/(fzm(k)*rho_zz(k,cell1)+fzp(k)*rho_zz(k-1,cell1))
enddo
@@ -1184,7 +1208,7 @@
enddo
- end subroutine atm_recover_large_step_variables
+ end subroutine atm_recover_large_step_variables
!---------------------------------------------------------------------------------------
@@ -1298,7 +1322,7 @@
do i=1,nAdvCellsForEdge(iEdge)
iCell = advCellsForEdge(i,iEdge)
do k=1,grid % nVertLevels
- scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge)
+ scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge)
do iScalar=1,s_old % num_scalars
flux_arr(iScalar,k) = flux_arr(iScalar,k) + scalar_weight* scalar_new(iScalar,k,iCell)
end do
@@ -1633,7 +1657,7 @@
do i=1,nAdvCellsForEdge(iEdge)
iCell = advCellsForEdge(i,iEdge)
do k=1,grid % nVertLevels
- scalar_weight = uhAvg(k,iEdge)*(adv_coefs(i,iEdge) + coef_3rd_order*sign(1.,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge))
+ scalar_weight = uhAvg(k,iEdge)*(adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge))
flux_arr(k,iEdge) = flux_arr(k,iEdge) + scalar_weight* scalar_new(k,iCell)
end do
end do
@@ -1651,7 +1675,7 @@
do k = 2, nVertLevels
scalar_new(k,iCell) = scalar_old(k,iCell)*h_old(k,iCell)
- flux_upwind = dt*(max(0.,wwAvg(k,iCell))*scalar_old(k-1,iCell) + min(0.,wwAvg(k,iCell))*scalar_old(k,iCell))
+ flux_upwind = dt*(max(0.0_RKIND,wwAvg(k,iCell))*scalar_old(k-1,iCell) + min(0.0_RKIND,wwAvg(k,iCell))*scalar_old(k,iCell))
scalar_new(k-1,iCell) = scalar_new(k-1,iCell) - flux_upwind*rdnw(k-1)
scalar_new(k ,iCell) = scalar_new(k ,iCell) + flux_upwind*rdnw(k)
wdtn(k,iCell) = dt*wdtn(k,iCell) - flux_upwind
@@ -1661,8 +1685,8 @@
! contributions to the update: first the vertical flux component, then the horizontal
do k=1,nVertLevels
- scale_in (k,iCell) = - rdnw(k)*(min(0.,wdtn(k+1,iCell))-max(0.,wdtn(k,iCell)))
- scale_out(k,iCell) = - rdnw(k)*(max(0.,wdtn(k+1,iCell))-min(0.,wdtn(k,iCell)))
+ scale_in (k,iCell) = - rdnw(k)*(min(0.0_RKIND,wdtn(k+1,iCell))-max(0.0_RKIND,wdtn(k,iCell)))
+ scale_out(k,iCell) = - rdnw(k)*(max(0.0_RKIND,wdtn(k+1,iCell))-min(0.0_RKIND,wdtn(k,iCell)))
end do
end do
@@ -1677,15 +1701,15 @@
if (cell1 <= grid%nCellsSolve .or. cell2 <= grid%nCellsSolve) then ! only for owned cells
do k=1,grid % nVertLevels
flux_upwind = grid % dvEdge % array(iEdge) * dt * &
- (max(0.,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.,uhAvg(k,iEdge))*scalar_old(k,cell2))
+ (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2))
flux_arr(k,iEdge) = dt*flux_arr(k,iEdge) - flux_upwind
scalar_new(k,cell1) = scalar_new(k,cell1) - flux_upwind / areaCell(cell1)
scalar_new(k,cell2) = scalar_new(k,cell2) + flux_upwind / areaCell(cell2)
- scale_out(k,cell1) = scale_out(k,cell1) - max(0.,flux_arr(k,iEdge)) / areaCell(cell1)
- scale_in (k,cell1) = scale_in (k,cell1) - min(0.,flux_arr(k,iEdge)) / areaCell(cell1)
- scale_out(k,cell2) = scale_out(k,cell2) + min(0.,flux_arr(k,iEdge)) / areaCell(cell2)
- scale_in (k,cell2) = scale_in (k,cell2) + max(0.,flux_arr(k,iEdge)) / areaCell(cell2)
+ scale_out(k,cell1) = scale_out(k,cell1) - max(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell1)
+ scale_in (k,cell1) = scale_in (k,cell1) - min(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell1)
+ scale_out(k,cell2) = scale_out(k,cell2) + min(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell2)
+ scale_in (k,cell2) = scale_in (k,cell2) + max(0.0_RKIND,flux_arr(k,iEdge)) / areaCell(cell2)
end do
end if
@@ -1700,10 +1724,10 @@
s_upwind = scalar_new(k,iCell)/h_new(k,iCell)
scale_factor = (s_max(k,iCell)-s_upwind)/(s_max_update-s_upwind+eps)
- scale_in(k,iCell) = min( 1.0, max( 0.0, scale_factor) )
+ scale_in(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) )
scale_factor = (s_upwind-s_min(k,iCell))/(s_upwind-s_min_update+eps)
- scale_out(k,iCell) = min( 1.0, max( 0.0, scale_factor) )
+ scale_out(k,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) )
end do
end do
@@ -1729,8 +1753,8 @@
if (cell1 <= grid%nCellsSolve .or. cell2 <= grid%nCellsSolve) then
do k = 1, nVertLevels
flux = flux_arr(k,iEdge)
- flux = max(0.,flux) * min(scale_out(k,cell1), scale_in(k,cell2)) &
- + min(0.,flux) * min(scale_in(k,cell1), scale_out(k,cell2))
+ flux = max(0.0_RKIND,flux) * min(scale_out(k,cell1), scale_in(k,cell2)) &
+ + min(0.0_RKIND,flux) * min(scale_in(k,cell1), scale_out(k,cell2))
flux_arr(k,iEdge) = flux
end do
end if
@@ -1741,8 +1765,8 @@
do iCell=1,grid % nCells
do k = 2, nVertLevels
flux = wdtn(k,iCell)
- flux = max(0.,flux) * min(scale_out(k-1,iCell), scale_in(k ,iCell)) &
- + min(0.,flux) * min(scale_out(k ,iCell), scale_in(k-1,iCell))
+ flux = max(0.0_RKIND,flux) * min(scale_out(k-1,iCell), scale_in(k ,iCell)) &
+ + min(0.0_RKIND,flux) * min(scale_out(k ,iCell), scale_in(k-1,iCell))
wdtn(k,iCell) = flux
end do
end do
@@ -1790,7 +1814,7 @@
do iCell = 1, grid%nCells
do k=1, grid%nVertLevels
- scalar_new_in(iScalar,k,iCell) = max(0.,scalar_new(k,iCell))
+ scalar_new_in(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell))
end do
end do
@@ -1854,7 +1878,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
@@ -1872,7 +1896,8 @@
real (kind=RKIND) :: r_earth
real (kind=RKIND), dimension(:,:), pointer :: ur_cell, vr_cell
- real (kind=RKIND), parameter :: c_s = 0.25
+ real (kind=RKIND), parameter :: c_s = 0.125
+! real (kind=RKIND), parameter :: c_s = 0.25
real (kind=RKIND), dimension( grid % nVertLevels ) :: d_diag, d_off_diag, flux_arr
real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b
logical :: delsq_horiz_mixing, newpx
@@ -1919,7 +1944,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
@@ -2058,21 +2086,74 @@
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))
do k=3,nVertLevels-1
- wduz(k) = flux3( u(k-2,iEdge),u(k-1,iEdge),u(k,iEdge),u(k+1,iEdge),0.5*(rw(k,cell1)+rw(k,cell2)), 1. )
+ wduz(k) = flux3( u(k-2,iEdge),u(k-1,iEdge),u(k,iEdge),u(k+1,iEdge),0.5*(rw(k,cell1)+rw(k,cell2)), 1.0_RKIND )
end do
k = nVertLevels
wduz(k) = 0.5*( rw(k,cell1)+rw(k,cell2) )*(fzm(k)*u(k,iEdge)+fzp(k)*u(k-1,iEdge))
@@ -2080,8 +2161,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
@@ -2293,7 +2374,11 @@
cell2 = cellsOnEdge(2,iEdge)
do k=1,nVertLevels
+#ifdef ROTATED_GRID
+ u_mix(k) = u(k,iEdge) - grid % u_init % array(k) * sin( grid % angleEdge % array(iEdge) )
+#else
u_mix(k) = u(k,iEdge) - grid % u_init % array(k) * cos( grid % angleEdge % array(iEdge) )
+#endif
end do
do k=2,nVertLevels-1
@@ -2368,7 +2453,7 @@
do i=1,nAdvCellsForEdge(iEdge)
iCell = advCellsForEdge(i,iEdge)
do k=2,grid % nVertLevels
- scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.,ru_edge_w(k))*adv_coefs_3rd(i,iEdge)
+ scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,ru_edge_w(k))*adv_coefs_3rd(i,iEdge)
flux_arr(k) = flux_arr(k) + scalar_weight* w(k,iCell)
end do
end do
@@ -2582,7 +2667,7 @@
k = 2
wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell))
do k=3,nVertLevels-1
- wdwz(k) = flux3( w(k-2,iCell),w(k-1,iCell),w(k,iCell),w(k+1,iCell),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1. )
+ wdwz(k) = flux3( w(k-2,iCell),w(k-1,iCell),w(k,iCell),w(k+1,iCell),0.5*(rw(k,iCell)+rw(k-1,iCell)), 1.0_RKIND )
end do
k = nVertLevels
wdwz(k) = 0.25*(rw(k,icell)+rw(k-1,iCell))*(w(k,iCell)+w(k-1,iCell))
@@ -2604,7 +2689,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)) + &
@@ -2678,7 +2763,7 @@
do i=1,nAdvCellsForEdge(iEdge)
iCell = advCellsForEdge(i,iEdge)
do k=1,grid % nVertLevels
- scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.,ru(k,iEdge))*adv_coefs_3rd(i,iEdge)
+ scalar_weight = adv_coefs(i,iEdge) + coef_3rd_order*sign(1.0_RKIND,ru(k,iEdge))*adv_coefs_3rd(i,iEdge)
flux_arr(k) = flux_arr(k) + scalar_weight* theta_m(k,iCell)
end do
end do
@@ -3266,9 +3351,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...
@@ -3312,27 +3402,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.,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.,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
@@ -3372,161 +3457,5 @@
end subroutine atm_init_coupled_diagnostics
-! ------------------------
- subroutine atm_qd_kessler( state_old, state_new, diag, tend, grid, dt )
-
- implicit none
-
- type (state_type), intent(inout) :: state_old, state_new
- type (diag_type), intent(inout) :: diag
- type (tend_type), intent(inout) :: tend
- type (mesh_type), intent(inout) :: grid
- real (kind=RKIND), intent(in) :: dt
-
- real (kind=RKIND), dimension( grid % nVertLevels ) :: t, rho, p, dzu, qv, qc, qr, qc1, qr1
-
- integer :: k,iEdge,i,iCell,nz1
- real (kind=RKIND) :: p0,rcv
-
-
- write(0,*) ' in qd_kessler '
-
- p0 = 1.e+05
- rcv = rgas/(cp-rgas)
- nz1 = grid % nVertLevels
-
- do iCell = 1, grid % nCellsSolve
-
- do k = 1, grid % nVertLevels
-
- tend % rt_diabatic_tend % array(k,iCell) = state_new % theta_m % array(k,iCell)
-
- t(k) = state_new % theta_m % array(k,iCell)/(1. + 1.61*state_new % scalars % array(state_new % index_qv,k,iCell))
- rho(k) = grid % zz % array(k,iCell)*state_new % rho_zz % array(k,iCell)
- p(k) = diag % exner % array(k,iCell)
- qv(k) = max(0.,state_new % scalars % array(state_new % index_qv,k,iCell))
- qc(k) = max(0.,state_new % scalars % array(state_new % index_qc,k,iCell))
- qr(k) = max(0.,state_new % scalars % array(state_new % index_qr,k,iCell))
- qc1(k) = max(0.,state_old % scalars % array(state_old % index_qc,k,iCell))
- qr1(k) = max(0.,state_old % scalars % array(state_old % index_qr,k,iCell))
- dzu(k) = grid % dzu % array(k)
-
- end do
-
- call atm_kessler( t,qv,qc,qc1,qr,qr1,rho,p,dt,dzu,nz1, 1)
-
- do k = 1, grid % nVertLevels
-
- state_new % theta_m % array(k,iCell) = t(k)*(1.+1.61*qv(k))
- tend % rt_diabatic_tend % array(k,iCell) = state_new % rho_zz % array(k,iCell) * &
- (state_new % theta_m % array(k,iCell) - tend % rt_diabatic_tend % array(k,iCell))/dt
- diag % rtheta_p % array(k,iCell) = state_new % rho_zz % array(k,iCell) * state_new % theta_m % array(k,iCell) &
- - diag % rtheta_base % array(k,iCell)
- state_new % scalars % array(state_new % index_qv,k,iCell) = qv(k)
- state_new % scalars % array(state_new % index_qc,k,iCell) = qc(k)
- state_new % scalars % array(state_new % index_qr,k,iCell) = qr(k)
-
- diag % exner % array(k,iCell) = &
- ( grid % zz % array(k,iCell)*(rgas/p0) * ( &
- diag % rtheta_p % array(k,iCell) &
- + diag % rtheta_base % array(k,iCell) ) )**rcv
-
- diag % pressure_p % array(k,iCell) = &
- grid % zz % array(k,iCell) * rgas * ( &
- diag % exner % array(k,iCell)*diag % rtheta_p % array(k,iCell) &
- +diag % rtheta_base % array(k,iCell) * &
- (diag % exner % array(k,iCell) - diag % exner_base % array(k,iCell)) )
- end do
-
- end do
-
- write(0,*) ' exiting qd_kessler '
-
- end subroutine atm_qd_kessler
-
-!-----------------------------------------------------------------------
- subroutine atm_kessler( t1t, qv1t, qc1t, qc1, qr1t, qr1, &
- rho, pii, dt, dzu, nz1, nx )
-!-----------------------------------------------------------------------
-!
- implicit none
- integer :: nx, nz1
- real (kind=RKIND) :: t1t (nz1,nx), qv1t(nz1,nx), qc1t(nz1,nx), &
- qr1t(nz1,nx), qc1 (nz1,nx), qr1 (nz1,nx), &
- rho (nz1,nx), pii (nz1,nx), dzu(nz1)
- integer, parameter :: mz=200
- real (kind=RKIND) :: qrprod(mz), prod (mz), rcgs( mz), rcgsi (mz) &
- ,ern (mz), vt (mz), vtden(mz), gam (mz) &
- ,r (mz), rhalf(mz), velqr(mz), buoycy(mz) &
- ,pk (mz), pc (mz), f0 (mz), qvs (mz)
-
- real (kind=RKIND) :: c1, c2, c3, c4, f5, mxfall, dtfall, fudge, dt, velu, veld, artemp, artot
- real (kind=RKIND) :: cp, product, ackess, ckess, fvel, f2x, xk, xki, psl
- integer :: nfall
- integer :: i,k,n
-
- ackess = 0.001
- ckess = 2.2
- fvel = 36.34
- f2x = 17.27
- f5 = 237.3*f2x*2.5e6/1003.
- xk = .2875
- xki = 1./xk
- psl = 1000.
-
- do k=1,nz1
- r(k) = 0.001*rho(k,1)
- rhalf(k) = sqrt(rho(1,1)/rho(k,1))
- pk(k) = pii(k,1)
- pc(k) = 3.8/(pk(k)**xki*psl)
- f0(k) = 2.5e6/(1003.*pk(k))
- end do
-!
- do i=1,nx
- do k=1,nz1
- qrprod(k) = qc1t(k,i) &
- -(qc1t(k,i)-dt*amax1(ackess*(qc1(k,i)-.001), &
- 0.))/(1.+dt*ckess*qr1(k,i)**.875)
- velqr(k) = (qr1(k,i)*r(k))**1.1364*rhalf(k)
- qvs(k) = pc(k)*exp(f2x*(pk(k)*t1t(k,i)-273.) &
- /(pk(k)*t1t(k,i)- 36.))
- end do
- velu = (qr1(2,i)*r(2))**1.1364*rhalf(2)
- veld = (qr1(1,i)*r(1))**1.1364*rhalf(1)
- qr1t(1,i) = qr1t(1,i)+dt*(velu-veld)*fvel/(r(1)*dzu(2))
- do k=2,nz1-1
- qr1t(k,i) = qr1t(k,i)+dt*fvel/r(k) &
- *.5*((velqr(k+1)-velqr(k ))/dzu(k+1) &
- +(velqr(k )-velqr(k-1))/dzu(k ))
- end do
- qr1t(nz1,i) = qr1t(nz1,i)-dt*fvel*velqr(nz1-1) &
- /(r(nz1)*dzu(nz1)*(1.+1.))
- artemp = 36340.*(.5*(velqr(2)+velqr(1))+veld-velu)
- artot = artot+dt*artemp
- do k=1,nz1
- qc1t(k,i) = amax1(qc1t(k,i)-qrprod(k),0.)
- qr1t(k,i) = amax1(qr1t(k,i)+qrprod(k),0.)
- prod(k) = (qv1t(k,i)-qvs(k))/(1.+qvs(k)*f5 &
- /(pk(k)*t1t(k,i)-36.)**2)
- end do
- do k=1,nz1
- ern(k) = amin1(dt*(((1.6+124.9*(r(k)*qr1t(k,i))**.2046) &
- *(r(k)*qr1t(k,i))**.525)/(2.55e6*pc(k) &
- /(3.8 *qvs(k))+5.4e5))*(dim(qvs(k),qv1t(k,i)) &
- /(r(k)*qvs(k))), &
- amax1(-prod(k)-qc1t(k,i),0.),qr1t(k,i))
- end do
- do k=1,nz1
- buoycy(k) = f0(k)*(amax1(prod(k),-qc1t(k,i))-ern(k))
- qv1t(k,i) = amax1(qv1t(k,i) &
- -amax1(prod(k),-qc1t(k,i))+ern(k),0.)
- qc1t(k,i) = qc1t(k,i)+amax1(prod(k),-qc1t(k,i))
- qr1t(k,i) = qr1t(k,i)-ern(k)
- t1t (k,i) = t1t (k,i)+buoycy(k)
- end do
- end do
-
- end subroutine atm_kessler
-
end module atm_time_integration
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -13,6 +13,7 @@
mpas_ocn_vel_forcing.o \
mpas_ocn_vel_forcing_windstress.o \
mpas_ocn_vel_forcing_bottomdrag.o \
+ mpas_ocn_vel_forcing_rayleigh.o \
mpas_ocn_vel_pressure_grad.o \
mpas_ocn_tracer_vadv.o \
mpas_ocn_tracer_vadv_spline.o \
@@ -35,15 +36,24 @@
mpas_ocn_vmix_coefs_tanh.o \
mpas_ocn_restoring.o \
mpas_ocn_tendency.o \
+ mpas_ocn_tracer_advection.o \
+ mpas_ocn_tracer_advection_std.o \
+ mpas_ocn_tracer_advection_std_hadv.o \
+ mpas_ocn_tracer_advection_std_vadv.o \
+ mpas_ocn_tracer_advection_std_vadv2.o \
+ mpas_ocn_tracer_advection_std_vadv3.o \
+ mpas_ocn_tracer_advection_std_vadv4.o \
+ mpas_ocn_tracer_advection_mono.o \
+ mpas_ocn_tracer_advection_helpers.o \
mpas_ocn_time_integration.o \
mpas_ocn_time_integration_rk4.o \
mpas_ocn_time_integration_split.o \
mpas_ocn_equation_of_state.o \
mpas_ocn_equation_of_state_jm.o \
mpas_ocn_equation_of_state_linear.o \
- mpas_ocn_global_diagnostics.o
+ mpas_ocn_global_diagnostics.o \
+ mpas_ocn_time_average.o
-
all: core_hyd
core_hyd: $(OBJS)
@@ -59,10 +69,12 @@
mpas_ocn_time_integration_split.o:
-mpas_ocn_tendency.o:
+mpas_ocn_tendency.o: mpas_ocn_time_average.o
mpas_ocn_global_diagnostics.o:
+mpas_ocn_time_average.o:
+
mpas_ocn_thick_hadv.o:
mpas_ocn_thick_vadv.o:
@@ -77,12 +89,14 @@
mpas_ocn_vel_hmix_del4.o:
-mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_bottomdrag.o
+mpas_ocn_vel_forcing.o: mpas_ocn_vel_forcing_windstress.o mpas_ocn_vel_forcing_bottomdrag.o mpas_ocn_vel_forcing_rayleigh.o
mpas_ocn_vel_forcing_windstress.o:
-mpas_ocn_velforcing_bottomdrag.o:
+mpas_ocn_vel_forcing_bottomdrag.o:
+mpas_ocn_vel_forcing_rayleigh.o:
+
mpas_ocn_vel_coriolis.o:
mpas_ocn_tracer_hadv.o: mpas_ocn_tracer_hadv2.o mpas_ocn_tracer_hadv3.o mpas_ocn_tracer_hadv4.o
@@ -115,6 +129,24 @@
mpas_ocn_tracer_hmix_del4.o:
+mpas_ocn_tracer_advection.o: mpas_ocn_tracer_advection_std.o mpas_ocn_tracer_advection_mono.o
+
+mpas_ocn_tracer_advection_std.o: mpas_ocn_tracer_advection_std_hadv.o mpas_ocn_tracer_advection_std_vadv.o
+
+mpas_ocn_tracer_advection_std_hadv.o: mpas_ocn_tracer_advection_helpers.o
+
+mpas_ocn_tracer_advection_std_vadv.o: mpas_ocn_tracer_advection_std_vadv2.o mpas_ocn_tracer_advection_std_vadv3.o mpas_ocn_tracer_advection_std_vadv4.o
+
+mpas_ocn_tracer_advection_std_vadv2.o: mpas_ocn_tracer_advection_helpers.o
+
+mpas_ocn_tracer_advection_std_vadv3.o: mpas_ocn_tracer_advection_helpers.o
+
+mpas_ocn_tracer_advection_std_vadv4.o: mpas_ocn_tracer_advection_helpers.o
+
+mpas_ocn_tracer_advection_mono.o: mpas_ocn_tracer_advection_helpers.o
+
+mpas_ocn_tracer_advection_helpers.o:
+
mpas_ocn_restoring.o:
mpas_ocn_vmix.o: mpas_ocn_vmix_coefs_const.o mpas_ocn_vmix_coefs_rich.o mpas_ocn_vmix_coefs_tanh.o
@@ -165,6 +197,15 @@
mpas_ocn_vmix_coefs_rich.o \
mpas_ocn_vmix_coefs_tanh.o \
mpas_ocn_restoring.o \
+ mpas_ocn_tracer_advection.o \
+ mpas_ocn_tracer_advection_std.o \
+ mpas_ocn_tracer_advection_std_hadv.o \
+ mpas_ocn_tracer_advection_std_vadv.o \
+ mpas_ocn_tracer_advection_std_vadv2.o \
+ mpas_ocn_tracer_advection_std_vadv3.o \
+ mpas_ocn_tracer_advection_std_vadv4.o \
+ mpas_ocn_tracer_advection_mono.o \
+ mpas_ocn_tracer_advection_helpers.o \
mpas_ocn_tendency.o \
mpas_ocn_time_integration.o \
mpas_ocn_time_integration_rk4.o \
@@ -172,7 +213,8 @@
mpas_ocn_equation_of_state.o \
mpas_ocn_equation_of_state_jm.o \
mpas_ocn_equation_of_state_linear.o \
- mpas_ocn_global_diagnostics.o
+ mpas_ocn_global_diagnostics.o \
+ mpas_ocn_time_average.o
clean:
$(RM) *.o *.mod *.f90 libdycore.a
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/Registry
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/Registry 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/Registry 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,15 +1,18 @@
-#
-# namelist type namelist_record name default_value
-#
+%
+% namelist type namelist_record name default_value
+%
namelist integer sw_model config_test_case 5
namelist character sw_model config_time_integration RK4
namelist logical sw_model config_rk_filter_btr_mode false
namelist real sw_model config_dt 172.8
-namelist integer sw_model config_calendar_type MPAS_360DAY
+namelist character sw_model config_calendar_type 360day
namelist character sw_model config_start_time 0000-01-01_00:00:00
namelist character sw_model config_stop_time none
namelist character sw_model config_run_duration none
namelist integer sw_model config_stats_interval 100
+namelist logical sw_model config_initial_stats false
+namelist logical sw_model config_prescribe_velocity false
+namelist logical sw_model config_prescribe_thickness false
namelist character io config_input_name grid.nc
namelist character io config_output_name output.nc
namelist character io config_restart_name restart.nc
@@ -21,26 +24,22 @@
namelist logical restart config_do_restart false
namelist character restart config_restart_interval none
namelist character grid config_vert_grid_type isopycnal
+namelist character grid config_pressure_type pressure
namelist real grid config_rho0 1028
namelist integer split_explicit_ts config_n_ts_iter 2
-namelist integer split_explicit_ts config_n_bcl_iter_beg 4
-namelist integer split_explicit_ts config_n_bcl_iter_mid 4
-namelist integer split_explicit_ts config_n_bcl_iter_end 4
-namelist integer split_explicit_ts config_n_btr_subcycles 10
-namelist integer split_explicit_ts config_n_btr_cor_iter 1
+namelist integer split_explicit_ts config_n_bcl_iter_beg 2
+namelist integer split_explicit_ts config_n_bcl_iter_mid 2
+namelist integer split_explicit_ts config_n_bcl_iter_end 2
+namelist integer split_explicit_ts config_n_btr_subcycles 20
+namelist integer split_explicit_ts config_n_btr_cor_iter 2
namelist logical split_explicit_ts config_u_correction true
namelist logical split_explicit_ts config_filter_btr_mode false
-namelist logical split_explicit_ts config_btr_mom_decay false
-namelist real split_explicit_ts config_btr_mom_decay_time 3600.0
-namelist real split_explicit_ts config_btr_mom_eddy_visc2 0.0
namelist integer split_explicit_ts config_btr_subcycle_loop_factor 2
-namelist character split_explicit_ts config_SSH_from avg_flux
-namelist character split_explicit_ts config_new_btr_variables_from btr_avg
namelist real split_explicit_ts config_btr_gam1_uWt1 0.5
namelist real split_explicit_ts config_btr_gam2_SSHWt1 1.0
namelist real split_explicit_ts config_btr_gam3_uWt2 1.0
namelist logical split_explicit_ts config_btr_solve_SSH2 false
-namelist logical sw_model config_h_ScaleWithMesh false
+namelist logical hmix config_h_ScaleWithMesh false
namelist real hmix config_h_mom_eddy_visc2 0.0
namelist real hmix config_h_mom_eddy_visc4 0.0
namelist logical hmix config_visc_vorticity_term true
@@ -49,9 +48,9 @@
namelist logical hmix config_include_KE_vertex false
namelist real hmix config_h_tracer_eddy_diff2 0.0
namelist real hmix config_h_tracer_eddy_diff4 0.0
-namelist real hmix config_apvm_upwinding 0.5
-namelist logical hmix config_mom_decay false
-namelist real hmix config_mom_decay_time 3600.0
+namelist logical hmix config_rayleigh_friction false
+namelist real hmix config_rayleigh_damping_coeff 0.0
+namelist real hmix config_apvm_scale_factor 0.0
namelist character vmix config_vert_visc_type const
namelist character vmix config_vert_diff_type const
namelist logical vmix config_implicit_vertical_mix .true.
@@ -71,22 +70,24 @@
namelist real vmix_tanh config_zWidth_tanh 100
namelist character eos config_eos_type linear
namelist character advection config_vert_tracer_adv stencil
-namelist integer advection config_vert_tracer_adv_order 4
-namelist integer advection config_tracer_adv_order 2
+namelist integer advection config_vert_tracer_adv_order 4
+namelist integer advection config_horiz_tracer_adv_order 2
namelist integer advection config_thickness_adv_order 2
-namelist logical advection config_positive_definite false
+namelist real advection config_coef_3rd_order 0.25
namelist logical advection config_monotonic false
+namelist logical advection config_check_monotonicity false
namelist logical restore config_restoreTS false
namelist real restore config_restoreT_timescale 90.0
namelist real restore config_restoreS_timescale 90.0
-#
-# dim type name_in_file name_in_code
-#
+%
+% dim type name_in_file name_in_code
+%
dim nCells nCells
dim nEdges nEdges
dim maxEdges maxEdges
dim maxEdges2 maxEdges2
+dim nAdvectionCells maxEdges2+0
dim nVertices nVertices
dim TWO 2
dim R3 3
@@ -96,9 +97,9 @@
dim nVertLevels nVertLevels
dim nVertLevelsP1 nVertLevels+1
-#
-# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
-#
+%
+% var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
+%
var persistent text xtime ( Time ) 2 ro xtime state - -
var persistent real latCell ( nCells ) 0 iro latCell mesh - -
@@ -153,85 +154,88 @@
var persistent real fVertex ( nVertices ) 0 iro fVertex mesh - -
var persistent real h_s ( nCells ) 0 iro h_s mesh - -
-# Space needed for advection
-var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 - deriv_two mesh - -
-var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
+% Space needed for advection
+var persistent real deriv_two ( maxEdges2 TWO nEdges ) 0 - deriv_two mesh - -
-# !! NOTE: the following arrays are needed to allow the use
-# !! of the module_advection.F w/o alteration
-# Space needed for deformation calculation weights
+% Added for monotonic advection scheme
+var persistent real adv_coefs ( nAdvectionCells nEdges ) 0 - adv_coefs mesh - -
+var persistent real adv_coefs_2nd ( nAdvectionCells nEdges ) 0 - adv_coefs_2nd mesh - -
+var persistent real adv_coefs_3rd ( nAdvectionCells nEdges ) 0 - adv_coefs_3rd mesh - -
+var persistent integer advCellsForEdge ( nAdvectionCells nEdges ) 0 - advCellsForEdge mesh - -
+var persistent integer nAdvCellsForEdge ( nEdges ) 0 - nAdvCellsForEdge mesh - -
+var persistent integer highOrderAdvectionMask ( nVertLevels nEdges ) 0 - highOrderAdvectionMask mesh - -
+var persistent integer lowOrderAdvectionMask ( nVertLevels nEdges ) 0 - lowOrderAdvectionMask mesh - -
+
+% !! NOTE: the following arrays are needed to allow the use
+% !! of the module_advection.F w/o alteration
+% Space needed for deformation calculation weights
var persistent real defc_a ( maxEdges nCells ) 0 - defc_a mesh - -
var persistent real defc_b ( maxEdges nCells ) 0 - defc_b mesh - -
var persistent real kdiff ( nVertLevels nCells Time ) 0 - kdiff mesh - -
-# Arrays required for reconstruction of velocity field
+% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
-# Arrays for z-level version of mpas-ocean
+% Arrays for z-level version of mpas-ocean
var persistent integer maxLevelCell ( nCells ) 0 iro maxLevelCell mesh - -
var persistent integer maxLevelEdgeTop ( nEdges ) 0 - maxLevelEdgeTop mesh - -
var persistent integer maxLevelEdgeBot ( nEdges ) 0 - maxLevelEdgeBot mesh - -
var persistent integer maxLevelVertexTop ( nVertices ) 0 - maxLevelVertexTop mesh - -
var persistent integer maxLevelVertexBot ( nVertices ) 0 - maxLevelVertexBot mesh - -
+var persistent real referenceBottomDepth ( nVertLevels ) 0 iro referenceBottomDepth mesh - -
+var persistent real referenceBottomDepthTopOfCell ( nVertLevelsP1 ) 0 - referenceBottomDepthTopOfCell mesh - -
var persistent real hZLevel ( nVertLevels ) 0 iro hZLevel mesh - -
-var persistent real zMidZLevel ( nVertLevels ) 0 - zMidZLevel mesh - -
-var persistent real zTopZLevel ( nVertLevelsP1 ) 0 - zTopZLevel mesh - -
-var persistent real hMeanTopZLevel ( nVertLevels ) 0 - hMeanTopZLevel mesh - -
-var persistent real hRatioZLevelK ( nVertLevels ) 0 - hRatioZLevelK mesh - -
-var persistent real hRatioZLevelKm1 ( nVertLevels ) 0 - hRatioZLevelKm1 mesh - -
-# Boundary conditions: read from input, saved in restart and written to output
+% Boundary conditions: read from input, saved in restart and written to output
var persistent integer boundaryEdge ( nVertLevels nEdges ) 0 iro boundaryEdge mesh - -
var persistent integer boundaryVertex ( nVertLevels nVertices ) 0 iro boundaryVertex mesh - -
var persistent integer boundaryCell ( nVertLevels nCells ) 0 iro boundaryCell mesh - -
+var persistent integer edgeMask ( nVertLevels nEdges ) 0 o edgeMask mesh - -
+var persistent integer vertexMask ( nVertLevels nVertices ) 0 o vertexMask mesh - -
+var persistent integer cellMask ( nVertLevels nCells ) 0 o cellMask mesh - -
var persistent real u_src ( nVertLevels nEdges ) 0 ir u_src mesh - -
var persistent real temperatureRestore ( nCells ) 0 ir temperatureRestore mesh - -
var persistent real salinityRestore ( nCells ) 0 ir salinityRestore mesh - -
-# Prognostic variables: read from input, saved in restart, and written to output
+% Prognostic variables: read from input, saved in restart, and written to output
var persistent real u ( nVertLevels nEdges Time ) 2 ir u state - -
-var persistent real h ( nVertLevels nCells Time ) 2 ir h state - -
+var persistent real h ( nVertLevels nCells Time ) 2 iro h state - -
var persistent real rho ( nVertLevels nCells Time ) 2 iro rho state - -
var persistent real temperature ( nVertLevels nCells Time ) 2 iro temperature state tracers dynamics
var persistent real salinity ( nVertLevels nCells Time ) 2 iro salinity state tracers dynamics
var persistent real tracer1 ( nVertLevels nCells Time ) 2 iro tracer1 state tracers testing
-var persistent real tracer2 ( nVertLevels nCells Time ) 2 iro tracer2 state tracers testing
-# Tendency variables: neither read nor written to any files
+% Tendency variables: neither read nor written to any files
var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
var persistent real tend_ssh ( nCells Time ) 1 - ssh tend - -
var persistent real tend_temperature ( nVertLevels nCells Time ) 1 - temperature tend tracers dynamics
var persistent real tend_salinity ( nVertLevels nCells Time ) 1 - salinity tend tracers dynamics
var persistent real tend_tracer1 ( nVertLevels nCells Time ) 1 - tracer1 tend tracers testing
-var persistent real tend_tracer2 ( nVertLevels nCells Time ) 1 - tracer2 tend tracers testing
-# state variables for Split Explicit timesplitting
+% state variables for Split Explicit timesplitting
var persistent real uBtr ( nEdges Time ) 2 - uBtr state - -
var persistent real ssh ( nCells Time ) 2 o ssh state - -
var persistent real uBtrSubcycle ( nEdges Time ) 2 - uBtrSubcycle state - -
var persistent real sshSubcycle ( nCells Time ) 2 - sshSubcycle state - -
-var persistent real FBtr ( nEdges Time ) 1 - FBtr state - -
-var persistent real GBtrForcing ( nEdges Time ) 1 - GBtrForcing state - -
+var persistent real FBtr ( nEdges Time ) 2 - FBtr state - -
+var persistent real GBtrForcing ( nEdges Time ) 2 - GBtrForcing state - -
var persistent real uBcl ( nVertLevels nEdges Time ) 2 - uBcl state - -
-var persistent real circulationBtr ( nVertices Time ) 1 - circulationBtr state - -
-var persistent real divergenceBtr ( nCells Time ) 1 - divergenceBtr state - -
-var persistent real vorticityBtr ( nVertices Time ) 1 - vorticityBtr state - -
-var persistent real u_diffusionBtr ( nEdges Time ) 1 - u_diffusionBtr state - -
-# Diagnostic fields: only written to output
+% Diagnostic fields: only written to output
+var persistent real zMid ( nVertLevels nCells Time ) 2 io zMid state - -
var persistent real v ( nVertLevels nEdges Time ) 2 - v state - -
var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
-var persistent real pv_edge ( nVertLevels nEdges Time ) 2 - pv_edge state - -
+var persistent real Vor_edge ( nVertLevels nEdges Time ) 2 - Vor_edge state - -
var persistent real h_edge ( nVertLevels nEdges Time ) 2 - h_edge state - -
var persistent real h_vertex ( nVertLevels nVertices Time ) 2 - h_vertex state - -
var persistent real ke ( nVertLevels nCells Time ) 2 o ke state - -
var persistent real kev ( nVertLevels nVertices Time ) 2 o kev state - -
var persistent real kevc ( nVertLevels nCells Time ) 2 o kevc state - -
var persistent real ke_edge ( nVertLevels nEdges Time ) 2 - ke_edge state - -
-var persistent real pv_vertex ( nVertLevels nVertices Time ) 2 - pv_vertex state - -
-var persistent real pv_cell ( nVertLevels nCells Time ) 2 - pv_cell state - -
+var persistent real Vor_vertex ( nVertLevels nVertices Time ) 2 - Vor_vertex state - -
+var persistent real Vor_cell ( nVertLevels nCells Time ) 2 o Vor_cell state - -
var persistent real uReconstructX ( nVertLevels nCells Time ) 2 - uReconstructX state - -
var persistent real uReconstructY ( nVertLevels nCells Time ) 2 - uReconstructY state - -
var persistent real uReconstructZ ( nVertLevels nCells Time ) 2 - uReconstructZ state - -
@@ -242,13 +246,13 @@
var persistent real wTop ( nVertLevelsP1 nCells Time ) 2 - wTop state - -
var persistent real rhoDisplaced ( nVertLevels nCells Time ) 2 - rhoDisplaced state - -
-# Other diagnostic variables: neither read nor written to any files
+% Other diagnostic variables: neither read nor written to any files
var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
-var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
-var persistent real gradPVn ( nVertLevels nEdges Time ) 2 - gradPVn state - -
+var persistent real gradVor_t ( nVertLevels nEdges Time ) 2 - gradVor_t state - -
+var persistent real gradVor_n ( nVertLevels nEdges Time ) 2 - gradVor_n state - -
-# Globally reduced diagnostic variables: only written to output
+% Globally reduced diagnostic variables: only written to output
var persistent real areaCellGlobal ( Time ) 2 o areaCellGlobal state - -
var persistent real areaEdgeGlobal ( Time ) 2 o areaEdgeGlobal state - -
var persistent real areaTriangleGlobal ( Time ) 2 o areaTriangleGlobal state - -
@@ -257,8 +261,18 @@
var persistent real volumeEdgeGlobal ( Time ) 2 o volumeEdgeGlobal state - -
var persistent real CFLNumberGlobal ( Time ) 2 o CFLNumberGlobal state - -
-# Diagnostics fields, only one time level required
+% Diagnostics fields, only one time level required
var persistent real RiTopOfCell ( nVertLevelsP1 nCells Time ) 1 - RiTopOfCell diagnostics - -
var persistent real RiTopOfEdge ( nVertLevelsP1 nEdges Time ) 1 - RiTopOfEdge diagnostics - -
var persistent real vertViscTopOfEdge ( nVertLevelsP1 nEdges Time ) 1 - vertViscTopOfEdge diagnostics - -
var persistent real vertDiffTopOfCell ( nVertLevelsP1 nCells Time ) 1 - vertDiffTopOfCell diagnostics - -
+
+var persistent real nAccumulate ( Time ) 2 o nAccumulate state - -
+var persistent real acc_ssh ( nCells Time ) 2 o acc_ssh state - -
+var persistent real acc_sshVar ( nCells Time ) 2 o acc_sshVar state - -
+var persistent real acc_uReconstructZonal ( nVertLevels nCells Time ) 2 o acc_uReconstructZonal state - -
+var persistent real acc_uReconstructMeridional ( nVertLevels nCells Time ) 2 o acc_uReconstructMeridional state - -
+var persistent real acc_uReconstructZonalVar ( nVertLevels nCells Time ) 2 o acc_uReconstructZonalVar state - -
+var persistent real acc_uReconstructMeridionalVar ( nVertLevels nCells Time ) 2 o acc_uReconstructMeridionalVar state - -
+var persistent real acc_u ( nVertLevels nEdges Time ) 2 o acc_u state - -
+var persistent real acc_uVar ( nVertLevels nEdges Time ) 2 o acc_uVar state - -
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_advection.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_advection.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_advection.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,6 @@
module ocn_advection
+ use mpas_kind_types
use mpas_grid_types
use mpas_configure
use mpas_constants
@@ -8,19 +9,25 @@
contains
- subroutine ocn_initialize_advection_rk( grid )
+ subroutine ocn_initialize_advection_rk( grid, err )!{{{
!
! compute the cell coefficients for the polynomial fit.
! this is performed during setup for model integration.
! WCS, 31 August 2009
!
+! Described in:
+! Skamarock, W. C., & Gassmann, A. (2011).
+! Conservative Transport Schemes for Spherical Geodesic Grids: High-Order Flux Operators for ODE-Based Time Integration.
+! Monthly Weather Review, 139(9), 2962-2975. doi:10.1175/MWR-D-10-05056.1
+!
implicit none
type (mesh_type), intent(in) :: grid
+ integer, intent(out) :: err
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- integer, dimension(:,:), pointer :: advCells
+ integer, dimension(:), pointer :: advCells
! local variables
@@ -49,9 +56,7 @@
integer :: cell1, cell2
integer, parameter :: polynomial_order = 2
-! logical, parameter :: debug = .true.
logical, parameter :: debug = .false.
-! logical, parameter :: least_squares = .false.
logical, parameter :: least_squares = .true.
logical :: add_the_cell, do_the_cell
@@ -60,11 +65,19 @@
real (kind=RKIND) :: rcell, cos2t, costsint, sin2t
real (kind=RKIND), dimension(grid%maxEdges) :: angle_2d
-!---
+!---
+ err = 0
+ if(polynomial_order > 2) then
+ write (*,*) 'Polynomial for second derivitave can only be 2'
+ err = 1
+ return
+ end if
+
pii = 2.*asin(1.0)
- advCells => grid % advCells % array
+! advCells => grid % advCells % array
+ allocate(advCells(grid % maxEdges2))
deriv_two => grid % deriv_two % array
deriv_two(:,:,:) = 0.
@@ -92,7 +105,7 @@
end do
end if
- advCells(1,iCell) = n
+ advCells(1) = n
! check to see if we are reaching outside the halo
@@ -109,15 +122,15 @@
if ( grid % on_a_sphere ) then
do i=1,n
- advCells(i+1,iCell) = cell_list(i)
- xc(i) = grid % xCell % array(advCells(i+1,iCell))/a
- yc(i) = grid % yCell % array(advCells(i+1,iCell))/a
- zc(i) = grid % zCell % array(advCells(i+1,iCell))/a
+ advCells(i+1) = cell_list(i)
+ xc(i) = grid % xCell % array(advCells(i+1))/a
+ yc(i) = grid % yCell % array(advCells(i+1))/a
+ zc(i) = grid % zCell % array(advCells(i+1))/a
end do
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -381,7 +394,7 @@
! end do
! stop
- end subroutine ocn_initialize_advection_rk
+ end subroutine ocn_initialize_advection_rk!}}}
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -390,7 +403,7 @@
! Computes the angle between arcs AB and AC, given points A, B, and C
! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+ real (kind=RKIND) function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)!{{{
implicit none
@@ -410,9 +423,9 @@
real (kind=RKIND) :: s ! Semiperimeter of the triangle
real (kind=RKIND) :: sin_angle
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1)
ABx = bx - ax
ABy = by - ay
@@ -428,15 +441,15 @@
s = 0.5*(a + b + c)
! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.0_RKIND,max(0.0_RKIND,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
end if
- end function sphere_angle
+ end function sphere_angle!}}}
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -445,7 +458,7 @@
! Computes the angle between vectors AB and AC, given points A, B, and C, and
! a vector (u,v,w) normal to the plane.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+ real (kind=RKIND) function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)!{{{
implicit none
@@ -480,12 +493,12 @@
cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = -acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
end if
- end function plane_angle
+ end function plane_angle!}}}
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -495,7 +508,7 @@
! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
! same sphere centered at the origin.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
+ real (kind=RKIND) function arc_length(ax, ay, az, bx, by, bz)!{{{
implicit none
@@ -518,7 +531,7 @@
! arc_length = sqrt(r) * 2.0 * asin(c/(2.0*r))
arc_length = r * 2.0 * asin(c/(2.0*r))
- end function arc_length
+ end function arc_length!}}}
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -528,7 +541,7 @@
! A=(ax, ay, az) to B=(bx, by, bz). It is assumed that A and B lie on the
! surface of a sphere centered at the origin.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- subroutine ocn_arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)
+ subroutine ocn_arc_bisect(ax, ay, az, bx, by, bz, cx, cy, cz)!{{{
implicit none
@@ -553,10 +566,10 @@
cz = r * cz / d
end if
- end subroutine ocn_arc_bisect
+ end subroutine ocn_arc_bisect!}}}
- subroutine ocn_poly_fit_2(a_in,b_out,weights_in,m,n,ne)
+ subroutine ocn_poly_fit_2(a_in,b_out,weights_in,m,n,ne)!{{{
implicit none
@@ -611,7 +624,7 @@
!
! write(6,*) ' '
- end subroutine ocn_poly_fit_2
+ end subroutine ocn_poly_fit_2!}}}
! Updated 10/24/2001.
@@ -630,119 +643,119 @@
! !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
-SUBROUTine ocn_migs (A,N,X,INDX)
+subroutine ocn_migs (a,n,x,indx)!{{{
!
-! Subroutine to invert matrix A(N,N) with the inverse stored
-! in X(N,N) in the output. Copyright (c) Tao Pang 2001.
+! subroutine to invert matrix a(n,n) with the inverse stored
+! in x(n,n) in the output. copyright (c) tao pang 2001.
!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N):: A
- REAL (kind=RKIND), INTENT (OUT), DIMENSION (N,N):: X
- REAL (kind=RKIND), DIMENSION (N,N) :: B
+ implicit none
+ integer, intent (in) :: n
+ integer :: i,j,k
+ integer, intent (out), dimension (n) :: indx
+ real (kind=RKIND), intent (inout), dimension (n,n):: a
+ real (kind=RKIND), intent (out), dimension (n,n):: x
+ real (kind=RKIND), dimension (n,n) :: b
!
- DO I = 1, N
- DO J = 1, N
- B(I,J) = 0.0
- END DO
- END DO
- DO I = 1, N
- B(I,I) = 1.0
- END DO
+ do i = 1, n
+ do j = 1, n
+ b(i,j) = 0.0
+ end do
+ end do
+ do i = 1, n
+ b(i,i) = 1.0
+ end do
!
- call ocn_elgs (A,N,INDX)
+ call ocn_elgs (a,n,indx)
!
- DO I = 1, N-1
- DO J = I+1, N
- DO K = 1, N
- B(INDX(J),K) = B(INDX(J),K)-A(INDX(J),I)*B(INDX(I),K)
- END DO
- END DO
- END DO
+ do i = 1, n-1
+ do j = i+1, n
+ do k = 1, n
+ b(indx(j),k) = b(indx(j),k)-a(indx(j),i)*b(indx(i),k)
+ end do
+ end do
+ end do
!
- DO I = 1, N
- X(N,I) = B(INDX(N),I)/A(INDX(N),N)
- DO J = N-1, 1, -1
- X(J,I) = B(INDX(J),I)
- DO K = J+1, N
- X(J,I) = X(J,I)-A(INDX(J),K)*X(K,I)
- END DO
- X(J,I) = X(J,I)/A(INDX(J),J)
- END DO
- END DO
-END SUBROUTine ocn_migs
+ do i = 1, n
+ x(n,i) = b(indx(n),i)/a(indx(n),n)
+ do j = n-1, 1, -1
+ x(j,i) = b(indx(j),i)
+ do k = j+1, n
+ x(j,i) = x(j,i)-a(indx(j),k)*x(k,i)
+ end do
+ x(j,i) = x(j,i)/a(indx(j),j)
+ end do
+ end do
+end subroutine ocn_migs!}}}
-SUBROUTine ocn_elgs (A,N,INDX)
+subroutine ocn_elgs (a,n,indx)!{{{
!
-! Subroutine to perform the partial-pivoting Gaussian elimination.
-! A(N,N) is the original matrix in the input and transformed matrix
+! subroutine to perform the partial-pivoting gaussian elimination.
+! a(n,n) is the original matrix in the input and transformed matrix
! plus the pivoting element ratios below the diagonal in the output.
-! INDX(N) records the pivoting order. Copyright (c) Tao Pang 2001.
+! indx(n) records the pivoting order. copyright (c) tao pang 2001.
!
- IMPLICIT NONE
- INTEGER, INTENT (IN) :: N
- INTEGER :: I,J,K,ITMP
- INTEGER, INTENT (OUT), DIMENSION (N) :: INDX
- REAL (kind=RKIND) :: C1,PI,PI1,PJ
- REAL (kind=RKIND), INTENT (INOUT), DIMENSION (N,N) :: A
- REAL (kind=RKIND), DIMENSION (N) :: C
+ implicit none
+ integer, intent (in) :: n
+ integer :: i,j,k,itmp
+ integer, intent (out), dimension (n) :: indx
+ real (kind=RKIND) :: c1,pi,pi1,pj
+ real (kind=RKIND), intent (inout), dimension (n,n) :: a
+ real (kind=RKIND), dimension (n) :: c
!
-! Initialize the index
+! initialize the index
!
- DO I = 1, N
- INDX(I) = I
- END DO
+ do i = 1, n
+ indx(i) = i
+ end do
!
-! Find the rescaling factors, one from each row
+! find the rescaling factors, one from each row
!
- DO I = 1, N
- C1= 0.0
- DO J = 1, N
- C1 = MAX(C1,ABS(A(I,J)))
- END DO
- C(I) = C1
- END DO
+ do i = 1, n
+ c1= 0.0
+ do j = 1, n
+ c1 = max(c1,abs(a(i,j)))
+ end do
+ c(i) = c1
+ end do
!
-! Search the pivoting (largest) element from each column
+! search the pivoting (largest) element from each column
!
- DO J = 1, N-1
- PI1 = 0.0
- DO I = J, N
- PI = ABS(A(INDX(I),J))/C(INDX(I))
- IF (PI.GT.PI1) THEN
- PI1 = PI
- K = I
- ENDIF
- END DO
+ do j = 1, n-1
+ pi1 = 0.0
+ do i = j, n
+ pi = abs(a(indx(i),j))/c(indx(i))
+ if (pi.gt.pi1) then
+ pi1 = pi
+ k = i
+ endif
+ end do
!
-! Interchange the rows via INDX(N) to record pivoting order
+! interchange the rows via indx(n) to record pivoting order
!
- ITMP = INDX(J)
- INDX(J) = INDX(K)
- INDX(K) = ITMP
- DO I = J+1, N
- PJ = A(INDX(I),J)/A(INDX(J),J)
+ itmp = indx(j)
+ indx(j) = indx(k)
+ indx(k) = itmp
+ do i = j+1, n
+ pj = a(indx(i),j)/a(indx(j),j)
!
-! Record pivoting ratios below the diagonal
+! record pivoting ratios below the diagonal
!
- A(INDX(I),J) = PJ
+ a(indx(i),j) = pj
!
-! Modify other elements accordingly
+! modify other elements accordingly
!
- DO K = J+1, N
- A(INDX(I),K) = A(INDX(I),K)-PJ*A(INDX(J),K)
- END DO
- END DO
- END DO
+ do k = j+1, n
+ a(indx(i),k) = a(indx(i),k)-pj*a(indx(j),k)
+ end do
+ end do
+ end do
!
-END SUBROUTine ocn_elgs
+end subroutine ocn_elgs!}}}
!-------------------------------------------------------------
- subroutine ocn_initialize_deformation_weights( grid )
+ subroutine ocn_initialize_deformation_weights( grid )!{{{
!
! compute the cell coefficients for the deformation calculations
@@ -839,7 +852,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -891,10 +904,10 @@
do i=2,n-1
ip1 = i+1
if (ip1 == n) ip1 = 1
- thetat(i) = plane_angle( 0.,0.,0., &
- xp(i)-xp(i-1), yp(i)-yp(i-1), 0., &
- xp(ip1)-xp(i), yp(ip1)-yp(i), 0., &
- 0., 0., 1.)
+ thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, &
+ xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, &
+ xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, &
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND)
thetat(i) = thetat(i) + thetat(i-1)
end do
@@ -929,6 +942,6 @@
if (debug) write(0,*) ' exiting def weight calc '
- end subroutine ocn_initialize_deformation_weights
+ end subroutine ocn_initialize_deformation_weights!}}}
end module ocn_advection
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
use ocn_equation_of_state_linear
use ocn_equation_of_state_jm
@@ -99,8 +98,6 @@
if(.not.eosOn) return
- call mpas_timer_start("ocn_equation_of_state_rho")
-
tracers => s % tracers % array
indexT = s % index_temperature
indexS = s % index_salinity
@@ -122,8 +119,6 @@
endif
- call mpas_timer_stop("ocn_equation_of_state_rho")
-
end subroutine ocn_equation_of_state_rho!}}}
!***********************************************************************
@@ -159,7 +154,7 @@
linearEos = .false.
jmEos = .false.
- if(config_vert_grid_type.eq.'zlevel') then
+ if(config_vert_grid_type.ne.'isopycnal') then
eosON = .true.
if (config_eos_type.eq.'linear') then
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state_jm.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state_jm.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state_jm.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -96,30 +95,30 @@
real (kind=RKIND), dimension(:), pointer :: &
- zMidZLevel, pRefEOS
+ referenceBottomDepth, pRefEOS
real (kind=RKIND), dimension(:,:), intent(inout) :: &
rho
real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers
integer, dimension(:), pointer :: maxLevelCell
- real (kind=RKIND) :: &
- TQ,SQ, &! adjusted T,S
- BULK_MOD, &! Bulk modulus
- RHO_S, &! density at the surface
- DRDT0, &! d(density)/d(temperature), for surface
- DRDS0, &! d(density)/d(salinity ), for surface
- DKDT, &! d(bulk modulus)/d(pot. temp.)
- DKDS, &! d(bulk modulus)/d(salinity )
- SQR,DENOMK, &! work arrays
- WORK1, WORK2, WORK3, WORK4, T2, depth
+ real (kind=RKIND) :: &
+ TQ,SQ, &! adjusted T,S
+ BULK_MOD, &! Bulk modulus
+ RHO_S, &! density at the surface
+ DRDT0, &! d(density)/d(temperature), for surface
+ DRDS0, &! d(density)/d(salinity ), for surface
+ DKDT, &! d(bulk modulus)/d(pot. temp.)
+ DKDS, &! d(bulk modulus)/d(salinity )
+ SQR,DENOMK, &! work arrays
+ WORK1, WORK2, WORK3, WORK4, T2, depth
- real (kind=RKIND) :: &
- tmin, tmax, &! valid temperature range for level k
- smin, smax ! valid salinity range for level k
+ real (kind=RKIND) :: &
+ tmin, tmax, &! valid temperature range for level k
+ smin, smax ! valid salinity range for level k
- real (kind=RKIND), dimension(:), allocatable :: &
- p, p2 ! temporary pressure scalars
+ real (kind=RKIND), dimension(:), allocatable :: &
+ p, p2 ! temporary pressure scalars
!-----------------------------------------------------------------------
!
@@ -127,79 +126,77 @@
!
!-----------------------------------------------------------------------
- !*** for density of fresh water (standard UNESCO)
+ !*** for density of fresh water (standard UNESCO)
- real (kind=RKIND), parameter :: &
- unt0 = 999.842594, &
- unt1 = 6.793952e-2, &
- unt2 = -9.095290e-3, &
- unt3 = 1.001685e-4, &
- unt4 = -1.120083e-6, &
- unt5 = 6.536332e-9
+ real (kind=RKIND), parameter :: &
+ unt0 = 999.842594, &
+ unt1 = 6.793952e-2, &
+ unt2 = -9.095290e-3, &
+ unt3 = 1.001685e-4, &
+ unt4 = -1.120083e-6, &
+ unt5 = 6.536332e-9
+
+ !*** for dependence of surface density on salinity (UNESCO)
- !*** for dependence of surface density on salinity (UNESCO)
-
- real (kind=RKIND), parameter :: &
- uns1t0 = 0.824493 , &
- uns1t1 = -4.0899e-3, &
- uns1t2 = 7.6438e-5, &
- uns1t3 = -8.2467e-7, &
- uns1t4 = 5.3875e-9, &
- unsqt0 = -5.72466e-3, &
- unsqt1 = 1.0227e-4, &
- unsqt2 = -1.6546e-6, &
- uns2t0 = 4.8314e-4
-
- !*** from Table A1 of Jackett and McDougall
-
- real (kind=RKIND), parameter :: &
- bup0s0t0 = 1.965933e+4, &
- bup0s0t1 = 1.444304e+2, &
- bup0s0t2 = -1.706103 , &
- bup0s0t3 = 9.648704e-3, &
- bup0s0t4 = -4.190253e-5
-
- real (kind=RKIND), parameter :: &
- bup0s1t0 = 5.284855e+1, &
- bup0s1t1 = -3.101089e-1, &
- bup0s1t2 = 6.283263e-3, &
- bup0s1t3 = -5.084188e-5
-
- real (kind=RKIND), parameter :: &
- bup0sqt0 = 3.886640e-1, &
- bup0sqt1 = 9.085835e-3, &
- bup0sqt2 = -4.619924e-4
-
- real (kind=RKIND), parameter :: &
- bup1s0t0 = 3.186519 , &
- bup1s0t1 = 2.212276e-2, &
- bup1s0t2 = -2.984642e-4, &
- bup1s0t3 = 1.956415e-6
-
- real (kind=RKIND), parameter :: &
- bup1s1t0 = 6.704388e-3, &
- bup1s1t1 = -1.847318e-4, &
- bup1s1t2 = 2.059331e-7, &
- bup1sqt0 = 1.480266e-4
-
- real (kind=RKIND), parameter :: &
- bup2s0t0 = 2.102898e-4, &
- bup2s0t1 = -1.202016e-5, &
- bup2s0t2 = 1.394680e-7, &
- bup2s1t0 = -2.040237e-6, &
- bup2s1t1 = 6.128773e-8, &
- bup2s1t2 = 6.207323e-10
-
- integer :: k_test, k_ref
-
+ real (kind=RKIND), parameter :: &
+ uns1t0 = 0.824493 , &
+ uns1t1 = -4.0899e-3, &
+ uns1t2 = 7.6438e-5, &
+ uns1t3 = -8.2467e-7, &
+ uns1t4 = 5.3875e-9, &
+ unsqt0 = -5.72466e-3, &
+ unsqt1 = 1.0227e-4, &
+ unsqt2 = -1.6546e-6, &
+ uns2t0 = 4.8314e-4
+
+ !*** from Table A1 of Jackett and McDougall
+
+ real (kind=RKIND), parameter :: &
+ bup0s0t0 = 1.965933e+4, &
+ bup0s0t1 = 1.444304e+2, &
+ bup0s0t2 = -1.706103 , &
+ bup0s0t3 = 9.648704e-3, &
+ bup0s0t4 = -4.190253e-5
+
+ real (kind=RKIND), parameter :: &
+ bup0s1t0 = 5.284855e+1, &
+ bup0s1t1 = -3.101089e-1, &
+ bup0s1t2 = 6.283263e-3, &
+ bup0s1t3 = -5.084188e-5
+
+ real (kind=RKIND), parameter :: &
+ bup0sqt0 = 3.886640e-1, &
+ bup0sqt1 = 9.085835e-3, &
+ bup0sqt2 = -4.619924e-4
+
+ real (kind=RKIND), parameter :: &
+ bup1s0t0 = 3.186519 , &
+ bup1s0t1 = 2.212276e-2, &
+ bup1s0t2 = -2.984642e-4, &
+ bup1s0t3 = 1.956415e-6
+
+ real (kind=RKIND), parameter :: &
+ bup1s1t0 = 6.704388e-3, &
+ bup1s1t1 = -1.847318e-4, &
+ bup1s1t2 = 2.059331e-7, &
+ bup1sqt0 = 1.480266e-4
+
+ real (kind=RKIND), parameter :: &
+ bup2s0t0 = 2.102898e-4, &
+ bup2s0t1 = -1.202016e-5, &
+ bup2s0t2 = 1.394680e-7, &
+ bup2s1t0 = -2.040237e-6, &
+ bup2s1t1 = 6.128773e-8, &
+ bup2s1t2 = 6.207323e-10
+
+ integer :: k_test, k_ref
+
err = 0
-
- call mpas_timer_start("equation_of_state_jm")
-
+
nCells = grid % nCells
maxLevelCell => grid % maxLevelCell % array
nVertLevels = grid % nVertLevels
- zMidZLevel => grid % zMidZLevel % array
+ referenceBottomDepth => grid % referenceBottomDepth % array
! Jackett and McDougall
@@ -208,109 +205,110 @@
smin = 0.0 ! valid salinity, in psu
smax = 42.0
- ! This could be put in a startup routine.
- ! Note I am using zMidZlevel, so pressure on top level does
- ! not include SSH contribution. I am not sure if that matters.
-
! This function computes pressure in bars from depth in meters
! using a mean density derived from depth-dependent global
! average temperatures and salinities from Levitus 1994, and
! integrating using hydrostatic balance.
allocate(pRefEOS(nVertLevels),p(nVertLevels),p2(nVertLevels))
- do k = 1,nVertLevels
- depth = -zMidZLevel(k)
- pRefEOS(k) = 0.059808*(exp(-0.025*depth) - 1.0) &
- + 0.100766*depth + 2.28405e-7*depth**2
- enddo
- ! If k_displaced=0, in-situ density is returned (no displacement)
- ! If k_displaced/=0, potential density is returned
-
- ! if displacement_type = 'relative', potential density is calculated
- ! referenced to level k + k_displaced
- ! if displacement_type = 'absolute', potential density is calculated
- ! referenced to level k_displaced for all k
- ! NOTE: k_displaced = 0 or > nVertLevels is incompatible with 'absolute'
- ! so abort if necessary
-
- if (displacement_type == 'absolute' .and. &
- (k_displaced <= 0 .or. k_displaced > nVertLevels) ) then
- write(0,*) 'Abort: In equation_of_state_jm', &
- ' k_displaced must be between 1 and nVertLevels for ', &
- 'displacement_type = absolute'
- call mpas_dmpar_abort(dminfo)
- endif
-
- if (k_displaced == 0) then
- do k=1,nVertLevels
- p(k) = pRefEOS(k)
- p2(k) = p(k)*p(k)
+ ! This could be put in the init routine.
+ ! Note I am using referenceBottomDepth, so pressure on top level does
+ ! not include SSH contribution. I am not sure if that matters, but
+ ! POP does it the same way.
+ depth = 0.5*referenceBottomDepth(1)
+ pRefEOS(1) = 0.059808*(exp(-0.025*depth) - 1.0) &
+ + 0.100766*depth + 2.28405e-7*depth**2
+ do k = 2,nVertLevels
+ depth = 0.5*(referenceBottomDepth(k)+referenceBottomDepth(k-1))
+ pRefEOS(k) = 0.059808*(exp(-0.025*depth) - 1.0) &
+ + 0.100766*depth + 2.28405e-7*depth**2
enddo
- else ! k_displaced /= 0
- do k=1,nVertLevels
- if (displacement_type == 'relative') then
- k_test = min(k + k_displaced, nVertLevels)
- k_ref = max(k_test, 1)
- else
- k_test = min(k_displaced, nVertLevels)
- k_ref = max(k_test, 1)
- endif
- p(k) = pRefEOS(k_ref)
- p2(k) = p(k)*p(k)
- enddo
- endif
- do iCell=1,nCells
- do k=1,maxLevelCell(iCell)
+ ! If k_displaced=0, in-situ density is returned (no displacement)
+ ! If k_displaced/=0, potential density is returned
- SQ = max(min(tracers(indexS,k,iCell),smax),smin)
- TQ = max(min(tracers(indexT,k,iCell),tmax),tmin)
+ ! if displacement_type = 'relative', potential density is calculated
+ ! referenced to level k + k_displaced
+ ! if displacement_type = 'absolute', potential density is calculated
+ ! referenced to level k_displaced for all k
+ ! NOTE: k_displaced = 0 or > nVertLevels is incompatible with 'absolute'
+ ! so abort if necessary
- SQR = sqrt(SQ)
- T2 = TQ*TQ
+ if (displacement_type == 'absolute' .and. &
+ (k_displaced <= 0 .or. k_displaced > nVertLevels) ) then
- !***
- !*** first calculate surface (p=0) values from UNESCO eqns.
- !***
+ write(0,*) 'Abort: In equation_of_state_jm', &
+ ' k_displaced must be between 1 and nVertLevels for ', &
+ 'displacement_type = absolute'
+ call mpas_dmpar_abort(dminfo)
+ endif
- WORK1 = uns1t0 + uns1t1*TQ + &
- (uns1t2 + uns1t3*TQ + uns1t4*T2)*T2
- WORK2 = SQR*(unsqt0 + unsqt1*TQ + unsqt2*T2)
+ if (k_displaced == 0) then
+ do k=1,nVertLevels
+ p(k) = pRefEOS(k)
+ p2(k) = p(k)*p(k)
+ enddo
+ else ! k_displaced /= 0
+ do k=1,nVertLevels
+ if (displacement_type == 'relative') then
+ k_test = min(k + k_displaced, nVertLevels)
+ k_ref = max(k_test, 1)
+ else
+ k_test = min(k_displaced, nVertLevels)
+ k_ref = max(k_test, 1)
+ endif
+ p(k) = pRefEOS(k_ref)
+ p2(k) = p(k)*p(k)
+ enddo
+ endif
- RHO_S = unt1*TQ + (unt2 + unt3*TQ + (unt4 + unt5*TQ)*T2)*T2 &
- + (uns2t0*SQ + WORK1 + WORK2)*SQ
+ do iCell=1,nCells
+ do k=1,maxLevelCell(iCell)
+ SQ = max(min(tracers(indexS,k,iCell),smax),smin)
+ TQ = max(min(tracers(indexT,k,iCell),tmax),tmin)
+
+ SQR = sqrt(SQ)
+ T2 = TQ*TQ
- !***
- !*** now calculate bulk modulus at pressure p from
- !*** Jackett and McDougall formula
- !***
+ !***
+ !*** first calculate surface (p=0) values from UNESCO eqns.
+ !***
- WORK3 = bup0s1t0 + bup0s1t1*TQ + &
- (bup0s1t2 + bup0s1t3*TQ)*T2 + &
- p(k) *(bup1s1t0 + bup1s1t1*TQ + bup1s1t2*T2) + &
- p2(k)*(bup2s1t0 + bup2s1t1*TQ + bup2s1t2*T2)
- WORK4 = SQR*(bup0sqt0 + bup0sqt1*TQ + bup0sqt2*T2 + &
- bup1sqt0*p(k))
+ WORK1 = uns1t0 + uns1t1*TQ + &
+ (uns1t2 + uns1t3*TQ + uns1t4*T2)*T2
+ WORK2 = SQR*(unsqt0 + unsqt1*TQ + unsqt2*T2)
- BULK_MOD = bup0s0t0 + bup0s0t1*TQ + &
- (bup0s0t2 + bup0s0t3*TQ + bup0s0t4*T2)*T2 + &
- p(k) *(bup1s0t0 + bup1s0t1*TQ + &
- (bup1s0t2 + bup1s0t3*TQ)*T2) + &
- p2(k)*(bup2s0t0 + bup2s0t1*TQ + bup2s0t2*T2) + &
- SQ*(WORK3 + WORK4)
+ RHO_S = unt1*TQ + (unt2 + unt3*TQ + (unt4 + unt5*TQ)*T2)*T2 &
+ + (uns2t0*SQ + WORK1 + WORK2)*SQ
- DENOMK = 1.0/(BULK_MOD - p(k))
+ !***
+ !*** now calculate bulk modulus at pressure p from
+ !*** Jackett and McDougall formula
+ !***
- rho(k,iCell) = (unt0 + RHO_S)*BULK_MOD*DENOMK
+ WORK3 = bup0s1t0 + bup0s1t1*TQ + &
+ (bup0s1t2 + bup0s1t3*TQ)*T2 + &
+ p(k) *(bup1s1t0 + bup1s1t1*TQ + bup1s1t2*T2) + &
+ p2(k)*(bup2s1t0 + bup2s1t1*TQ + bup2s1t2*T2)
+ WORK4 = SQR*(bup0sqt0 + bup0sqt1*TQ + bup0sqt2*T2 + &
+ bup1sqt0*p(k))
+
+ BULK_MOD = bup0s0t0 + bup0s0t1*TQ + &
+ (bup0s0t2 + bup0s0t3*TQ + bup0s0t4*T2)*T2 + &
+ p(k) *(bup1s0t0 + bup1s0t1*TQ + &
+ (bup1s0t2 + bup1s0t3*TQ)*T2) + &
+ p2(k)*(bup2s0t0 + bup2s0t1*TQ + bup2s0t2*T2) + &
+ SQ*(WORK3 + WORK4)
+
+ DENOMK = 1.0/(BULK_MOD - p(k))
+
+ rho(k,iCell) = (unt0 + RHO_S)*BULK_MOD*DENOMK
- end do
- end do
+ end do
+ end do
- deallocate(pRefEOS,p,p2)
-
- call mpas_timer_stop("equation_of_state_jm")
-
+ deallocate(pRefEOS,p,p2)
end subroutine ocn_equation_of_state_jm_rho!}}}
!***********************************************************************
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state_linear.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_equation_of_state_linear.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -87,8 +86,6 @@
integer :: nCells, iCell, k
type (dm_info) :: dminfo
- call mpas_timer_start("ocn_equation_of_state_linear")
-
maxLevelCell => grid % maxLevelCell % array
nCells = grid % nCells
@@ -103,8 +100,6 @@
end do
end do
- call mpas_timer_stop("ocn_equation_of_state_linear")
-
end subroutine ocn_equation_of_state_linear_rho!}}}
!***********************************************************************
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_global_diagnostics.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_global_diagnostics.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_global_diagnostics.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -4,14 +4,17 @@
use mpas_configure
use mpas_constants
use mpas_dmpar
+ use mpas_timer
implicit none
save
public
+ type (timer_node), pointer :: diagBlockTimer, diagMPITimer
+
contains
- subroutine ocn_compute_global_diagnostics(dminfo, state, grid, timeIndex, dt)
+ subroutine ocn_compute_global_diagnostics(domain, timeLevel, timeIndex, dt)!{{{
! Note: this routine assumes that there is only one block per processor. No looping
! is preformed over blocks.
@@ -26,197 +29,300 @@
implicit none
- type (dm_info), intent(in) :: dminfo
- type (state_type), intent(inout) :: state
- type (mesh_type), intent(in) :: grid
+ type (domain_type), intent(inout) :: domain !< Input/Output: domain information
integer, intent(in) :: timeIndex
real (kind=RKIND), intent(in) :: dt
+ type (block_type), pointer :: block
+ type (dm_info), pointer :: dminfo
+ type (state_type), pointer :: state
+ type (mesh_type), pointer :: grid
+
integer :: nVertLevels, nCellsSolve, nEdgesSolve, nVerticesSolve, nCellsGlobal, nEdgesGlobal, nVerticesGlobal, iTracer
+ integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
+ integer :: timeLevel,k,i, num_tracers
+ integer :: fileID
+ integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced
- real (kind=RKIND) :: areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal
+ real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal, localCFL, localSum, areaCellGlobal, areaEdgeGlobal, areaTriangleGlobal
real (kind=RKIND), dimension(:), pointer :: areaCell, dcEdge, dvEdge, areaTriangle, areaEdge
- real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, circulation, vorticity, ke, pv_edge, pv_vertex, &
- pv_cell, gradPVn, gradPVt, pressure, MontPot, wTop, rho, tracerTemp
+ real (kind=RKIND), dimension(:,:), pointer :: h, u, v, h_edge, circulation, vorticity, ke, Vor_edge, Vor_vertex, &
+ Vor_cell, gradVor_n, gradVor_t, pressure, MontPot, wTop, rho, tracerTemp
real (kind=RKIND), dimension(:,:,:), pointer :: tracers
+
+ real (kind=RKIND), dimension(kMaxVariables) :: sums, mins, maxes, averages, verticalSumMins, verticalSumMaxes, reductions
+ real (kind=RKIND), dimension(kMaxVariables) :: sums_tmp, mins_tmp, maxes_tmp, averages_tmp, verticalSumMins_tmp, verticalSumMaxes_tmp
- real (kind=RKIND) :: volumeCellGlobal, volumeEdgeGlobal, CFLNumberGlobal
- real (kind=RKIND) :: localCFL, localSum
- integer :: elementIndex, variableIndex, nVariables, nSums, nMaxes, nMins
- integer :: timeLevel,k,i, num_tracers
+ block => domain % blocklist
+ dminfo => domain % dminfo
- integer, parameter :: kMaxVariables = 1024 ! this must be a little more than double the number of variables to be reduced
+ sums = 0.0
+ mins = 0.0
+ maxes = 0.0
+ averages = 0.0
+ verticalSumMins = 0.0
+ verticalSumMaxes = 0.0
+ reductions = 0.0
- real (kind=RKIND), dimension(kMaxVariables) :: sums, mins, maxes, averages, verticalSumMins, verticalSumMaxes, reductions
+ call mpas_timer_start("diagnostic block loop", .false., diagBlockTimer)
+ do while (associated(block))
+ state => block % state % time_levs(timeLevel) % state
+ grid => block % mesh
+
+ num_tracers = state % num_tracers
- integer :: fileID
+ nVertLevels = grid % nVertLevels
+ nCellsSolve = grid % nCellsSolve
+ nEdgesSolve = grid % nEdgesSolve
+ nVerticesSolve = grid % nVerticesSolve
- num_tracers = state % num_tracers
+ areaCell => grid % areaCell % array
+ dcEdge => grid % dcEdge % array
+ dvEdge => grid % dvEdge % array
+ areaTriangle => grid % areaTriangle % array
+ allocate(areaEdge(1:nEdgesSolve))
+ areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve)
- nVertLevels = grid % nVertLevels
- nCellsSolve = grid % nCellsSolve
- nEdgesSolve = grid % nEdgesSolve
- nVerticesSolve = grid % nVerticesSolve
+ h => state % h % array
+ u => state % u % array
+ rho => state % rho % array
+ tracers => state % tracers % array
+ v => state % v % array
+ wTop => state % wTop % array
+ h_edge => state % h_edge % array
+ circulation => state % circulation % array
+ vorticity => state % vorticity % array
+ ke => state % ke % array
+ Vor_edge => state % Vor_edge % array
+ Vor_vertex => state % Vor_vertex % array
+ Vor_cell => state % Vor_cell % array
+ gradVor_n => state % gradVor_n % array
+ gradVor_t => state % gradVor_t % array
+ MontPot => state % MontPot % array
+ pressure => state % pressure % array
- areaCell => grid % areaCell % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaTriangle => grid % areaTriangle % array
- allocate(areaEdge(1:nEdgesSolve))
- areaEdge = dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve)
+ variableIndex = 0
+ ! h
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- h => state % h % array
- u => state % u % array
- rho => state % rho % array
- tracers => state % tracers % array
- v => state % v % array
- wTop => state % wTop % array
- h_edge => state % h_edge % array
- circulation => state % circulation % array
- vorticity => state % vorticity % array
- ke => state % ke % array
- pv_edge => state % pv_edge % array
- pv_vertex => state % pv_vertex % array
- pv_cell => state % pv_cell % array
- gradPVn => state % gradPVn % array
- gradPVt => state % gradPVt % array
- MontPot => state % MontPot % array
- pressure => state % pressure % array
+ ! u
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
+ u(:,1:nEdgesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- variableIndex = 0
- ! h
- variableIndex = variableIndex + 1
- call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), verticalSumMaxes(variableIndex))
+ ! v
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
+ v(:,1:nEdgesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! u
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
- u(:,1:nEdgesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! h_edge
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
+ sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! v
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
- v(:,1:nEdgesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! circulation
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_local_stats(dminfo, nVertLevels, nVerticesSolve, circulation(:,1:nVerticesSolve), &
+ sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! h_edge
- variableIndex = variableIndex + 1
- call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
- sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), verticalSumMaxes(variableIndex))
+ ! vorticity
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nVerticesSolve, areaTriangle(1:nVerticesSolve), &
+ vorticity(:,1:nVerticesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), &
+ verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! circulation
- variableIndex = variableIndex + 1
- call ocn_compute_field_local_stats(dminfo, nVertLevels, nVerticesSolve, circulation(:,1:nVerticesSolve), &
- sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), verticalSumMaxes(variableIndex))
+ ! ke
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ ke(:,1:nCellsSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! vorticity
- variableIndex = variableIndex + 1
- call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nVerticesSolve, areaTriangle(1:nVerticesSolve), &
- vorticity(:,1:nVerticesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), &
- verticalSumMins(variableIndex), verticalSumMaxes(variableIndex))
+ ! Vor_edge
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
+ Vor_edge(:,1:nEdgesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! ke
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- ke(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! Vor_vertex
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nVerticesSolve, areaTriangle(1:nVerticesSolve), &
+ Vor_vertex(:,1:nVerticesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), &
+ verticalSumMins_tmp(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! pv_edge
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
- pv_edge(:,1:nEdgesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! Vor_cell
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ Vor_cell(:,1:nCellsSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! pv_vertex
- variableIndex = variableIndex + 1
- call ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nVerticesSolve, areaTriangle(1:nVerticesSolve), &
- pv_vertex(:,1:nVerticesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), &
- verticalSumMins(variableIndex), verticalSumMaxes(variableIndex))
+ ! gradVor_n
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
+ gradVor_n(:,1:nEdgesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! pv_cell
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- pv_cell(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! gradVor_t
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
+ gradVor_t(:,1:nEdgesSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! gradPVn
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
- gradPVn(:,1:nEdgesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! pressure
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ pressure(:,1:nCellsSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! gradPVt
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nEdgesSolve, areaEdge(1:nEdgesSolve), h_edge(:,1:nEdgesSolve), &
- gradPVt(:,1:nEdgesSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! MontPot
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ MontPot(:,1:nCellsSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! pressure
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- pressure(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! wTop vertical velocity
+ variableIndex = variableIndex + 1
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels+1, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ wTop(:,1:nCellsSolve), sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
- ! MontPot
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- MontPot(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ ! Tracers
+ allocate(tracerTemp(nVertLevels,nCellsSolve))
+ do iTracer=1,num_tracers
+ variableIndex = variableIndex + 1
+ tracerTemp = Tracers(iTracer,:,1:nCellsSolve)
+ call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
+ tracerTemp, sums_tmp(variableIndex), mins_tmp(variableIndex), maxes_tmp(variableIndex), verticalSumMins_tmp(variableIndex), &
+ verticalSumMaxes_tmp(variableIndex))
+ sums(variableIndex) = sums(variableIndex) + sums_tmp(variableIndex)
+ mins(variableIndex) = min(mins(variableIndex), mins_tmp(variableIndex))
+ maxes(variableIndex) = max(maxes(variableIndex), maxes_tmp(variableIndex))
+ verticalSumMins(variableIndex) = min(verticalSumMins(variableIndex), verticalSumMins_tmp(variableIndex))
+ verticalSumMaxes(variableIndex) = max(verticalSumMaxes(variableIndex), verticalSumMaxes_tmp(variableIndex))
+ enddo
+ deallocate(tracerTemp)
- ! wTop vertical velocity
- variableIndex = variableIndex + 1
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels+1, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- wTop(:,1:nCellsSolve), sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
+ nVariables = variableIndex
+ nSums = nVariables
+ nMins = nVariables
+ nMaxes = nVariables
- ! Tracers
- allocate(tracerTemp(nVertLevels,nCellsSolve))
- do iTracer=1,num_tracers
- variableIndex = variableIndex + 1
- tracerTemp = Tracers(iTracer,:,1:nCellsSolve)
- call ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nCellsSolve, areaCell(1:nCellsSolve), h(:,1:nCellsSolve), &
- tracerTemp, sums(variableIndex), mins(variableIndex), maxes(variableIndex), verticalSumMins(variableIndex), &
- verticalSumMaxes(variableIndex))
- enddo
- deallocate(tracerTemp)
+ nSums = nSums + 1
+ sums(nSums) = sums(nSums) + sum(areaCell(1:nCellsSolve))
- nVariables = variableIndex
- nSums = nVariables
- nMins = nVariables
- nMaxes = nVariables
+ nSums = nSums + 1
+ sums(nSums) = sums(nSums) + sum(dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve))
- nSums = nSums + 1
- sums(nSums) = sum(areaCell(1:nCellsSolve))
+ nSums = nSums + 1
+ sums(nSums) = sums(nSums) + sum(areaTriangle(1:nVerticesSolve))
- nSums = nSums + 1
- sums(nSums) = sum(dcEdge(1:nEdgesSolve)*dvEdge(1:nEdgesSolve))
+ nSums = nSums + 1
+ sums(nSums) = sums(nSums) + nCellsSolve
- nSums = nSums + 1
- sums(nSums) = sum(areaTriangle(1:nVerticesSolve))
+ nSums = nSums + 1
+ sums(nSums) = sums(nSums) + nEdgesSolve
- nSums = nSums + 1
- sums(nSums) = nCellsSolve
+ nSums = nSums + 1
+ sums(nSums) = sums(nSums) + nVerticesSolve
- nSums = nSums + 1
- sums(nSums) = nEdgesSolve
+ localCFL = 0.0
+ do elementIndex = 1,nEdgesSolve
+ localCFL = max(localCFL, maxval(dt*u(:,elementIndex)/dcEdge(elementIndex)))
+ end do
+ nMaxes = nMaxes + 1
+ maxes(nMaxes) = localCFL
- nSums = nSums + 1
- sums(nSums) = nVerticesSolve
+ do i = 1, nVariables
+ mins(nMins+i) = min(mins(nMins+i),verticalSumMins_tmp(i))
+ maxes(nMaxes+i) = max(maxes(nMaxes+i),verticalSumMaxes_tmp(i))
+ end do
- localCFL = 0.0
- do elementIndex = 1,nEdgesSolve
- localCFL = max(localCFL, maxval(dt*u(:,elementIndex)/dcEdge(elementIndex)))
+ nMins = nMins + nVariables
+ nMaxes = nMaxes + nVariables
+
+ block => block % next
end do
- nMaxes = nMaxes + 1
- maxes(nMaxes) = localCFL
+ call mpas_timer_stop("diagnostic block loop", diagBlockTimer)
+ call mpas_timer_start("diagnostics mpi", .false., diagMPITimer)
- mins(nMins+1:nMins+nVariables) = verticalSumMins(1:nVariables)
- nMins = nMins + nVariables
- maxes(nMaxes+1:nMaxes+nVariables) = verticalSumMaxes(1:nVariables)
- nMaxes = nMaxes + nVariables
-
! global reduction of the 5 arrays (packed into 3 to minimize global communication)
call mpas_dmpar_sum_real_array(dminfo, nSums, sums(1:nSums), reductions(1:nSums))
sums(1:nVariables) = reductions(1:nVariables)
@@ -268,23 +374,23 @@
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
- ! pv_edge
+ ! Vor_edge
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal
- ! pv_vertex
+ ! Vor_vertex
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/(areaTriangleGlobal*nVertLevels)
- ! pv_cell
+ ! Vor_cell
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
- ! gradPVn
+ ! gradVor_n
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal
- ! gradPVt
+ ! gradVor_t
variableIndex = variableIndex + 1
averages(variableIndex) = sums(variableIndex)/volumeEdgeGlobal
@@ -306,6 +412,8 @@
averages(variableIndex) = sums(variableIndex)/volumeCellGlobal
enddo
+ call mpas_timer_stop("diagnostics mpi", diagMPITimer)
+
! write out the data to files
if (dminfo % my_proc_id == IO_NODE) then
fileID = getFreeUnit()
@@ -322,7 +430,7 @@
write (fileID,'(100es24.14)') averages(1:nVariables)
close (fileID)
open(fileID,file='stats_time.txt',ACCESS='append')
- write (fileID,'(i5,10x,a,100es24.14)') timeIndex, &
+ write (fileID,'(i10,10x,a,100es24.14)') timeIndex, &
state % xtime % scalar, dt, &
CFLNumberGlobal
close (fileID)
@@ -343,9 +451,9 @@
state % CFLNumberGlobal % scalar = CFLNumberGlobal
deallocate(areaEdge)
- end subroutine ocn_compute_global_diagnostics
+ end subroutine ocn_compute_global_diagnostics!}}}
- integer function getFreeUnit()
+ integer function getFreeUnit()!{{{
implicit none
integer :: index
@@ -361,9 +469,9 @@
end if
end if
end do
- end function getFreeUnit
+ end function getFreeUnit!}}}
- subroutine ocn_compute_field_local_stats(dminfo, nVertLevels, nElements, field, localSum, localMin, localMax, localVertSumMin, &
+ subroutine ocn_compute_field_local_stats(dminfo, nVertLevels, nElements, field, localSum, localMin, localMax, localVertSumMin, &!{{{
localVertSumMax)
implicit none
@@ -380,9 +488,9 @@
localVertSumMin = minval(sum(field,1))
localVertSumMax = maxval(sum(field,1))
- end subroutine ocn_compute_field_local_stats
+ end subroutine ocn_compute_field_local_stats!}}}
- subroutine ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nElements, areas, field, localSum, localMin, &
+ subroutine ocn_compute_field_area_weighted_local_stats(dminfo, nVertLevels, nElements, areas, field, localSum, localMin, &!{{{
localMax, localVertSumMin, localVertSumMax)
implicit none
@@ -406,9 +514,9 @@
localVertSumMin = minval(sum(field,1))
localVertSumMax = maxval(sum(field,1))
- end subroutine ocn_compute_field_area_weighted_local_stats
+ end subroutine ocn_compute_field_area_weighted_local_stats!}}}
- subroutine ocn_compute_field_thickness_weighted_local_stats(dminfo, nVertLevels, nElements, h, field, &
+ subroutine ocn_compute_field_thickness_weighted_local_stats(dminfo, nVertLevels, nElements, h, field, &!{{{
localSum, localMin, localMax, localVertSumMin, localVertSumMax)
implicit none
@@ -430,9 +538,9 @@
localVertSumMin = minval(sum(h*field,1))
localVertSumMax = maxval(sum(h*field,1))
- end subroutine ocn_compute_field_thickness_weighted_local_stats
+ end subroutine ocn_compute_field_thickness_weighted_local_stats!}}}
- subroutine ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nElements, areas, h, field, &
+ subroutine ocn_compute_field_volume_weighted_local_stats(dminfo, nVertLevels, nElements, areas, h, field, &!{{{
localSum, localMin, localMax, localVertSumMin, localVertSumMax)
implicit none
@@ -459,11 +567,10 @@
localVertSumMin = minval(sum(h*field,1))
localVertSumMax = maxval(sum(h*field,1))
- end subroutine ocn_compute_field_volume_weighted_local_stats
+ end subroutine ocn_compute_field_volume_weighted_local_stats!}}}
+ subroutine ocn_compute_global_sum(dminfo, nVertLevels, nElements, field, globalSum)!{{{
- subroutine ocn_compute_global_sum(dminfo, nVertLevels, nElements, field, globalSum)
-
implicit none
type (dm_info), intent(in) :: dminfo
@@ -476,9 +583,9 @@
localSum = sum(field)
call mpas_dmpar_sum_real(dminfo, localSum, globalSum)
- end subroutine ocn_compute_global_sum
+ end subroutine ocn_compute_global_sum!}}}
- subroutine ocn_compute_area_weighted_global_sum(dminfo, nVertLevels, nElements, areas, field, globalSum)
+ subroutine ocn_compute_area_weighted_global_sum(dminfo, nVertLevels, nElements, areas, field, globalSum)!{{{
implicit none
@@ -498,9 +605,9 @@
call mpas_dmpar_sum_real(dminfo, localSum, globalSum)
- end subroutine ocn_compute_area_weighted_global_sum
+ end subroutine ocn_compute_area_weighted_global_sum!}}}
- subroutine ocn_compute_volume_weighted_global_sum(dminfo, nVertLevels, nElements, areas, h, field, globalSum)
+ subroutine ocn_compute_volume_weighted_global_sum(dminfo, nVertLevels, nElements, areas, h, field, globalSum)!{{{
implicit none
@@ -517,9 +624,9 @@
call ocn_compute_area_weighted_global_sum(dminfo, nVertLevels, nElements, areas, hTimesField, globalSum)
- end subroutine ocn_compute_volume_weighted_global_sum
+ end subroutine ocn_compute_volume_weighted_global_sum!}}}
- subroutine ocn_compute_global_min(dminfo, nVertLevels, nElements, field, globalMin)
+ subroutine ocn_compute_global_min(dminfo, nVertLevels, nElements, field, globalMin)!{{{
implicit none
@@ -533,9 +640,9 @@
localMin = minval(field)
call mpas_dmpar_min_real(dminfo, localMin, globalMin)
- end subroutine ocn_compute_global_min
+ end subroutine ocn_compute_global_min!}}}
- subroutine ocn_compute_global_max(dminfo, nVertLevels, nElements, field, globalMax)
+ subroutine ocn_compute_global_max(dminfo, nVertLevels, nElements, field, globalMax)!{{{
implicit none
@@ -549,9 +656,9 @@
localMax = maxval(field)
call mpas_dmpar_max_real(dminfo, localMax, globalMax)
- end subroutine ocn_compute_global_max
+ end subroutine ocn_compute_global_max!}}}
- subroutine ocn_compute_global_vert_sum_horiz_min(dminfo, nVertLevels, nElements, field, globalMin)
+ subroutine ocn_compute_global_vert_sum_horiz_min(dminfo, nVertLevels, nElements, field, globalMin)!{{{
implicit none
@@ -565,9 +672,9 @@
localMin = minval(sum(field,1))
call mpas_dmpar_min_real(dminfo, localMin, globalMin)
- end subroutine ocn_compute_global_vert_sum_horiz_min
+ end subroutine ocn_compute_global_vert_sum_horiz_min!}}}
- subroutine ocn_compute_global_vert_sum_horiz_max(dminfo, nVertLevels, nElements, field, globalMax)
+ subroutine ocn_compute_global_vert_sum_horiz_max(dminfo, nVertLevels, nElements, field, globalMax)!{{{
implicit none
@@ -581,9 +688,9 @@
localMax = maxval(sum(field,1))
call mpas_dmpar_max_real(dminfo, localMax, globalMax)
- end subroutine ocn_compute_global_vert_sum_horiz_max
+ end subroutine ocn_compute_global_vert_sum_horiz_max!}}}
- subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_min(dminfo, nVertLevels, nElements, h, field, globalMin)
+ subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_min(dminfo, nVertLevels, nElements, h, field, globalMin)!{{{
implicit none
@@ -597,9 +704,9 @@
localMin = minval(sum(h*field,1))
call mpas_dmpar_min_real(dminfo, localMin, globalMin)
- end subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_min
+ end subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_min!}}}
- subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_max(dminfo, nVertLevels, nElements, h, field, globalMax)
+ subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_max(dminfo, nVertLevels, nElements, h, field, globalMax)!{{{
implicit none
@@ -613,6 +720,6 @@
localMax = maxval(sum(h*field,1))
call mpas_dmpar_max_real(dminfo, localMax, globalMax)
- end subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_max
+ end subroutine ocn_compute_global_vert_thickness_weighted_sum_horiz_max!}}}
end module ocn_global_diagnostics
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_mpas_core.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_mpas_core.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_mpas_core.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,12 +1,14 @@
module mpas_core
+ use mpas_configure
use mpas_framework
use mpas_timekeeping
use mpas_dmpar
+ use mpas_timer
+
+ use ocn_global_diagnostics
use ocn_test_cases
-
use ocn_time_integration
-
use ocn_tendency
use ocn_vel_pressure_grad
@@ -23,6 +25,8 @@
use ocn_vmix
+ use ocn_time_average
+
type (io_output_object) :: restart_obj
integer :: current_outfile_frames
@@ -33,12 +37,15 @@
integer, parameter :: restartAlarmID = 2
integer, parameter :: statsAlarmID = 3
+ type (timer_node), pointer :: globalDiagTimer, timeIntTimer
+ type (timer_node), pointer :: initDiagSolveTimer
+
contains
subroutine mpas_core_init(domain, startTimeStamp)!{{{
- use mpas_configure
use mpas_grid_types
+ use mpas_ocn_tracer_advection
implicit none
@@ -79,64 +86,83 @@
call ocn_equation_of_state_init(err_tmp)
err = ior(err, err_tmp)
+ call ocn_tendency_init(err_tmp)
+ err = ior(err,err_tmp)
+
+ call mpas_ocn_tracer_advection_init(err_tmp)
+ err = ior(err,err_tmp)
+
+ call mpas_timer_init(domain)
+
if(err.eq.1) then
call mpas_dmpar_abort(dminfo)
endif
if (.not. config_do_restart) call setup_sw_test_case(domain)
- call compute_maxLevel(domain)
+ call ocn_compute_max_level(domain)
- if (config_vert_grid_type.eq.'isopycnal') then
- print *, ' Using isopycnal coordinates'
- elseif (config_vert_grid_type.eq.'zlevel') then
- print *, ' Using z-level coordinates'
- call init_ZLevel(domain)
- else
- print *, ' Incorrect choice of config_vert_grid_type:',&
- config_vert_grid_type
+ call ocn_init_z_level(domain)
+
+ print *, ' Vertical grid type is: ',config_vert_grid_type
+
+ if (config_vert_grid_type.ne.'isopycnal'.and. &
+ config_vert_grid_type.ne.'zlevel'.and. &
+ config_vert_grid_type.ne.'zstar1'.and. &
+ config_vert_grid_type.ne.'zstar'.and. &
+ config_vert_grid_type.ne.'zstarWeights') then
+ print *, ' Incorrect choice of config_vert_grid_type.'
call mpas_dmpar_abort(dminfo)
endif
- if (trim(config_new_btr_variables_from) == 'btr_avg' &
- .and.trim(config_time_integration) == 'unsplit_explicit') then
- print *, ' unsplit_explicit option must use',&
- ' config_new_btr_variables_from==last_subcycle'
+ print *, ' Pressure type is: ',config_pressure_type
+ if (config_pressure_type.ne.'pressure'.and. &
+ config_pressure_type.ne.'MontgomeryPotential') then
+ print *, ' Incorrect choice of config_pressure_type.'
call mpas_dmpar_abort(dminfo)
endif
+ if (config_filter_btr_mode.and. &
+ config_vert_grid_type.ne.'zlevel')then
+ print *, 'filter_btr_mode has only been tested with'// &
+ ' config_vert_grid_type=zlevel.'
+ call mpas_dmpar_abort(dminfo)
+ endif
+
!
! Initialize core
!
dt = config_dt
- call simulation_clock_init(domain, dt, startTimeStamp)
+ call ocn_simulation_clock_init(domain, dt, startTimeStamp)
block => domain % blocklist
do while (associated(block))
- call mpas_init_block(block, block % mesh, dt)
+ call mpas_init_block(block, block % mesh, dt, err)
+ if(err.eq.1) then
+ call mpas_dmpar_abort(dminfo)
+ endif
block % state % time_levs(1) % state % xtime % scalar = startTimeStamp
block => block % next
-
- !dwj 110919 This allows the restorings to grab the indices for
- ! temperature and salinity tracers from state.
end do
! mrp 100316 In order for this to work, we need to pass domain % dminfo as an
! input arguement into mpas_init. Ask about that later. For now, there will be
! no initial statistics write.
- ! call mpas_timer_start("global diagnostics")
- ! call ocn_compute_global_diagnostics(domain % dminfo, block % state % time_levs(1) % state, mesh, 0, dt)
- ! call mpas_timer_stop("global diagnostics")
- ! call mpas_output_state_init(output_obj, domain, "OUTPUT")
- ! call write_output_frame(output_obj, domain)
+ if (config_initial_stats) then
+ call mpas_timer_start("global diagnostics", .false., globalDiagTimer)
+ call ocn_compute_global_diagnostics(domain, 1 , 0, dt)
+ call mpas_timer_stop("global diagnostics", globalDiagTimer)
+! call mpas_output_state_init(output_obj, domain, "OUTPUT")
+! call ocn_write_output_frame(output_obj, output_frame, domain)
+ endif
current_outfile_frames = 0
end subroutine mpas_core_init!}}}
- subroutine simulation_clock_init(domain, dt, startTimeStamp)!{{{
+ subroutine ocn_simulation_clock_init(domain, dt, startTimeStamp)!{{{
implicit none
@@ -192,25 +218,38 @@
call mpas_get_time(curr_time=startTime, dateTimeString=startTimeStamp, ierr=ierr)
- end subroutine simulation_clock_init!}}}
+ end subroutine ocn_simulation_clock_init!}}}
- subroutine mpas_init_block(block, mesh, dt)!{{{
+ subroutine mpas_init_block(block, mesh, dt, err)!{{{
use mpas_grid_types
use mpas_rbf_interpolation
use mpas_vector_reconstruction
+ use mpas_ocn_tracer_advection
+ use ocn_advection
implicit none
type (block_type), intent(inout) :: block
type (mesh_type), intent(inout) :: mesh
real (kind=RKIND), intent(in) :: dt
+ integer, intent(out) :: err
integer :: i, iEdge, iCell, k
+ integer :: err1
+ call ocn_initialize_advection_rk(mesh, err)
+ call mpas_ocn_tracer_advection_coefficients(mesh, err1)
+ err = ior(err, err1)
+
+ call ocn_time_average_init(block % state % time_levs(1) % state)
+ call mpas_timer_start("diagnostic solve", .false., initDiagSolveTimer)
call ocn_diagnostic_solve(dt, block % state % time_levs(1) % state, mesh)
+ call mpas_timer_stop("diagnostic solve", initDiagSolveTimer)
- call compute_mesh_scaling(mesh)
+ call ocn_wtop(block % state % time_levs(1) % state,block % state % time_levs(1) % state, mesh)
+
+ call ocn_compute_mesh_scaling(mesh)
call mpas_rbf_interp_initialize(mesh)
call mpas_init_reconstruct(mesh)
@@ -226,6 +265,8 @@
! The reconstructed velocity on land will have values not exactly
! -1e34 due to the interpolation of reconstruction.
+ block % mesh % areaCell % array(block % mesh % nCells+1) = -1.0e34
+
do iEdge=1,block % mesh % nEdges
! mrp 101115 note: in order to include flux boundary conditions, the following
! line will need to change. Right now, set boundary edges between land and
@@ -246,29 +287,13 @@
:block % mesh % nVertLevels,iCell) = 0.0
! mrp changed to 0
! :block % mesh % nVertLevels,iCell) = -1e34
-
-! mrp 110516, added just to test for conservation of tracers
-! block % state % time_levs(1) % state % tracers % array(block % state % time_levs(1) % state % index_tracer1,:,iCell) = 1.0
-
end do
- if (.not. config_do_restart) then
-
-! mrp 110808 add, so that variables are copied to * variables for split explicit
- do i=2,nTimeLevs
- call mpas_copy_state(block % state % time_levs(i) % state, &
+ do i=2,nTimeLevs
+ call mpas_copy_state(block % state % time_levs(i) % state, &
block % state % time_levs(1) % state)
- end do
-! mrp 110808 add end
+ end do
-
- else
- do i=2,nTimeLevs
- call mpas_copy_state(block % state % time_levs(i) % state, &
- block % state % time_levs(1) % state)
- end do
- endif
-
end subroutine mpas_init_block!}}}
subroutine mpas_core_run(domain, output_obj, output_frame)!{{{
@@ -298,8 +323,14 @@
call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
write(0,*) 'Initial time ', timeStamp
- call write_output_frame(output_obj, output_frame, domain)
+ call ocn_write_output_frame(output_obj, output_frame, domain)
+ block_ptr => domain % blocklist
+ do while(associated(block_ptr))
+ call ocn_time_average_init(block_ptr % state % time_levs(1) % state)
+ block_ptr => block_ptr % next
+ end do
+
! During integration, time level 1 stores the model state at the beginning of the
! time step, and time level 2 stores the state advanced dt in time by timestep(...)
itimestep = 0
@@ -312,9 +343,9 @@
call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr)
write(0,*) 'Doing timestep ', timeStamp
- call mpas_timer_start("time integration")
+ call mpas_timer_start("time integration", .false., timeIntTimer)
call mpas_timestep(domain, itimestep, dt, timeStamp)
- call mpas_timer_stop("time integration")
+ call mpas_timer_stop("time integration", timeIntTimer)
! Move time level 2 fields back into time level 1 for next time step
call mpas_shift_time_levels_state(domain % blocklist % state)
@@ -326,7 +357,20 @@
call mpas_output_state_finalize(output_obj, domain % dminfo)
call mpas_output_state_init(output_obj, domain, "OUTPUT", trim(timeStamp))
end if
- call write_output_frame(output_obj, output_frame, domain)
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call ocn_time_average_normalize(block_ptr % state % time_levs(1) % state)
+ block_ptr => block_ptr % next
+ end do
+
+ call ocn_write_output_frame(output_obj, output_frame, domain)
+
+ block_ptr => domain % blocklist
+ do while (associated(block_ptr))
+ call ocn_time_average_init(block_ptr % state % time_levs(1) % state)
+ block_ptr => block_ptr % next
+ end do
end if
if (mpas_is_alarm_ringing(clock, restartAlarmID, ierr=ierr)) then
@@ -342,7 +386,7 @@
end subroutine mpas_core_run!}}}
- subroutine write_output_frame(output_obj, output_frame, domain)!{{{
+ subroutine ocn_write_output_frame(output_obj, output_frame, domain)!{{{
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute diagnostic fields for a domain and write model state to output file
!
@@ -365,7 +409,7 @@
block_ptr => domain % blocklist
do while (associated(block_ptr))
- call compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
+ call ocn_compute_output_diagnostics(block_ptr % state % time_levs(1) % state, block_ptr % mesh)
block_ptr => block_ptr % next
end do
@@ -381,9 +425,9 @@
end if
end if
- end subroutine write_output_frame!}}}
+ end subroutine ocn_write_output_frame!}}}
- subroutine compute_output_diagnostics(state, grid)!{{{
+ subroutine ocn_compute_output_diagnostics(state, grid)!{{{
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Compute diagnostic fields for a domain
!
@@ -403,13 +447,11 @@
integer :: i, eoe
integer :: iEdge, k
- end subroutine compute_output_diagnostics!}}}
+ end subroutine ocn_compute_output_diagnostics!}}}
subroutine mpas_timestep(domain, itimestep, dt, timeStamp)!{{{
use mpas_grid_types
- use mpas_timer
- use ocn_global_diagnostics
implicit none
@@ -425,17 +467,9 @@
if (config_stats_interval > 0) then
if (mod(itimestep, config_stats_interval) == 0) then
- block_ptr => domain % blocklist
- if (associated(block_ptr % next)) then
- write(0,*) 'Error: computeGlobalDiagnostics assumes ',&
- 'that there is only one block per processor.'
- end if
-
- call mpas_timer_start("global diagnostics")
- call ocn_compute_global_diagnostics(domain % dminfo, &
- block_ptr % state % time_levs(2) % state, block_ptr % mesh, &
- itimestep, dt)
- call mpas_timer_stop("global diagnostics")
+ call mpas_timer_start("global diagnostics", .false., globalDiagTimer)
+ call ocn_compute_global_diagnostics(domain, 2, itimestep, dt);
+ call mpas_timer_stop("global diagnostics", globalDiagTimer)
end if
end if
@@ -458,76 +492,54 @@
end subroutine mpas_timestep!}}}
-subroutine init_ZLevel(domain)!{{{
-! Initialize maxLevel and bouncary grid variables.
+ subroutine ocn_init_z_level(domain)!{{{
+ ! Initialize maxLevel and bouncary grid variables.
- use mpas_grid_types
- use mpas_configure
+ use mpas_grid_types
+ use mpas_configure
- implicit none
+ implicit none
- type (domain_type), intent(inout) :: domain
+ type (domain_type), intent(inout) :: domain
- integer :: i, iCell, iEdge, iVertex, k
- type (block_type), pointer :: block
+ integer :: i, iCell, iEdge, iVertex, k
+ type (block_type), pointer :: block
- integer :: iTracer, cell, cell1, cell2
- real (kind=RKIND) :: uhSum, hSum, sshEdge
- real (kind=RKIND), dimension(:), pointer :: &
- hZLevel, zMidZLevel, zTopZLevel, &
- hMeanTopZLevel, hRatioZLevelK, hRatioZLevelKm1
- real (kind=RKIND), dimension(:,:), pointer :: h
- integer :: nVertLevels
+ integer :: iTracer, cell, cell1, cell2
+ real (kind=RKIND) :: uhSum, hSum, hEdge1
+ real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth, referenceBottomDepthTopOfCell
+
+ real (kind=RKIND), dimension(:,:), pointer :: h
+ integer :: nVertLevels
- ! Initialize z-level grid variables from h, read in from input file.
- block => domain % blocklist
- do while (associated(block))
+ ! Initialize z-level grid variables from h, read in from input file.
+ block => domain % blocklist
+ do while (associated(block))
- h => block % state % time_levs(1) % state % h % array
- hZLevel => block % mesh % hZLevel % array
- zMidZLevel => block % mesh % zMidZLevel % array
- zTopZLevel => block % mesh % zTopZLevel % array
- nVertLevels = block % mesh % nVertLevels
- hMeanTopZLevel => block % mesh % hMeanTopZLevel % array
- hRatioZLevelK => block % mesh % hRatioZLevelK % array
- hRatioZLevelKm1 => block % mesh % hRatioZLevelKm1 % array
+ h => block % state % time_levs(1) % state % h % array
+ referenceBottomDepth => block % mesh % referenceBottomDepth % array
+ referenceBottomDepthTopOfCell => block % mesh % referenceBottomDepthTopOfCell % array
+ nVertLevels = block % mesh % nVertLevels
- ! These should eventually be in an input file. For now
- ! I just read them in from h(:,1).
- ! Upon restart, the correct hZLevel should be in restart.nc
- if (.not. config_do_restart) hZLevel = h(:,1)
+ ! mrp 120208 right now hZLevel is in the grid.nc file.
+ ! We would like to transition to using referenceBottomDepth
+ ! as the defining variable instead, and will transition soon.
+ ! When the transition is done, hZLevel can be removed from
+ ! registry and the following four lines deleted.
+ referenceBottomDepth(1) = block % mesh % hZLevel % array(1)
+ do k = 2,nVertLevels
+ referenceBottomDepth(k) = referenceBottomDepth(k-1) + block % mesh % hZLevel % array(k)
+ end do
- ! hZLevel should be in the grid.nc and restart.nc file,
- ! and h for k=1 must be specified there as well.
-
- zTopZLevel(1) = 0.0
- do k = 1,nVertLevels
- zMidZLevel(k) = zTopZLevel(k)-0.5*hZLevel(k)
- zTopZLevel(k+1) = zTopZLevel(k)- hZLevel(k)
- end do
+ ! TopOfCell needed where zero depth for the very top may be referenced.
+ referenceBottomDepthTopOfCell(1) = 0.0
+ do k = 1,nVertLevels
+ referenceBottomDepthTopOfCell(k+1) = referenceBottomDepth(k)
+ end do
- hMeanTopZLevel(1) = 0.0
- hRatioZLevelK(1) = 0.0
- hRatioZLevelKm1(1) = 0.0
- do k = 2,nVertLevels
- hMeanTopZLevel(k) = 0.5*(hZLevel(k-1) + hZLevel(k))
- hRatioZLevelK(k) = 0.5*hZLevel(k)/hMeanTopZLevel(k)
- hRatioZLevelKm1(k) = 0.5*hZLevel(k-1)/hMeanTopZLevel(k)
- end do
-
- ! mrp 110601 For now, h is the variable saved in the restart file
- ! I am computing SSH here. In the future, could make smaller
- ! restart files for z-Level runs by saving SSH only.
- do iCell=1,block % mesh % nCells
-
- block % state % time_levs(1) % state % ssh % array(iCell) &
- = block % state % time_levs(1) % state % h % array(1,iCell) &
- - block % mesh % hZLevel % array(1)
- enddo
-
! Compute barotropic velocity at first timestep
! This is only done upon start-up.
- if (trim(config_time_integration) == 'unsplit_explicit') then
+ if (trim(config_time_integration) == 'unsplit_explicit') then
block % state % time_levs(1) % state % uBtr % array(:) = 0.0
block % state % time_levs(1) % state % uBcl % array(:,:) &
@@ -538,9 +550,7 @@
if (config_filter_btr_mode) then
do iCell=1,block % mesh % nCells
block % state % time_levs(1) % state % h % array(1,iCell) &
- = block % mesh % hZLevel % array(1)
-
- block % state % time_levs(1) % state % ssh % array(iCell) = 0.0
+ = block % mesh % referenceBottomDepth % array(1)
enddo
endif
@@ -548,21 +558,30 @@
cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
- sshEdge = 0.5*( &
- block % state % time_levs(1) % state % ssh % array(cell1) &
- + block % state % time_levs(1) % state % ssh % array(cell2) )
-
! uBtr = sum(u)/sum(h) on each column
- uhSum = (sshEdge + block % mesh % hZLevel % array(1)) &
- * block % state % time_levs(1) % state % u % array(1,iEdge)
- hSum = sshEdge + block % mesh % hZLevel % array(1)
+ ! ocn_diagnostic_solve has not yet been called, so compute hEdge
+ ! just for this edge.
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ hEdge1 = 0.5*( &
+ block % state % time_levs(1) % state % h % array(1,cell1) &
+ + block % state % time_levs(1) % state % h % array(1,cell2) )
+ uhSum = hEdge1*block % state % time_levs(1) % state % u % array(1,iEdge)
+ hSum = hEdge1
+
do k=2,block % mesh % maxLevelEdgeTop % array(iEdge)
+ ! ocn_diagnostic_solve has not yet been called, so compute hEdge
+ ! just for this edge.
+ hEdge1 = 0.5*( &
+ block % state % time_levs(1) % state % h % array(k,cell1) &
+ + block % state % time_levs(1) % state % h % array(k,cell2) )
+
uhSum = uhSum &
- + block % mesh % hZLevel % array(k) &
- *block % state % time_levs(1) % state % u % array(k,iEdge)
- hSum = hSum &
- + block % mesh % hZLevel % array(k)
+ + hEdge1*block % state % time_levs(1) % state % u % array(k,iEdge)
+ hSum = hSum + hEdge1
+
enddo
block % state % time_levs(1) % state % uBtr % array(iEdge) = uhSum/hsum
@@ -590,39 +609,12 @@
endif
-!print *, '11 u ',minval(domain % blocklist % state % time_levs(1) % state % u % array(:,1:domain % blocklist % mesh % nEdgesSolve)), &
-! maxval(domain % blocklist % state % time_levs(1) % state % u % array(:,1:domain % blocklist % mesh % nEdgesSolve))
-!print *, '11 uBtr ',minval(domain % blocklist % state % time_levs(1) % state % uBtr % array(1:domain % blocklist % mesh % nEdgesSolve)), &
-! maxval(domain % blocklist % state % time_levs(1) % state % uBtr % array(1:domain % blocklist % mesh % nEdgesSolve))
-!print *, '11 uBcl ',minval(domain % blocklist % state % time_levs(1) % state % uBcl % array(:,1:domain % blocklist % mesh % nEdgesSolve)), &
-! maxval(domain % blocklist % state % time_levs(1) % state % uBcl % array(:,1:domain % blocklist % mesh % nEdgesSolve))
-
-
-! mrp temp testing - is uBcl vert sum zero?
-! do iEdge=1,block % mesh % nEdges
-! uhSum = (sshEdge + block % mesh % hZLevel % array(1)) * block % state % time_levs(1) % state % uBcl % array(1,iEdge)
-! hSum = sshEdge + block % mesh % hZLevel % array(1)
-
-! do k=2,block % mesh % maxLevelEdgeTop % array(iEdge)
-! uhSum = uhSum + block % mesh % hZLevel % array(k) * block % state % time_levs(1) % state % uBcl % array(k,iEdge)
-! hSum = hSum + block % mesh % hZLevel % array(k)
-! enddo
-! block % state % time_levs(1) % state % FBtr % array(iEdge) = uhSum/hSum
-
-! enddo ! iEdge
-
-!print *, 'uBcl vert sum IC',minval(block % state % time_levs(1) % state % FBtr % array(1:block % mesh % nEdgesSolve)), &
-! maxval(block % state % time_levs(1) % state % FBtr % array(1:block % mesh % nEdgesSolve))
-
-! mrp temp testing - is uBcl vert sum zero? end
-
block => block % next
+ end do
- end do
+ end subroutine ocn_init_z_level!}}}
-end subroutine init_ZLevel!}}}
-
-subroutine compute_maxLevel(domain)!{{{
+subroutine ocn_compute_max_level(domain)!{{{
! Initialize maxLevel and bouncary grid variables.
use mpas_grid_types
@@ -647,7 +639,7 @@
maxLevelVertexTop, maxLevelVertexBot
integer, dimension(:,:), pointer :: &
cellsOnEdge, cellsOnVertex, boundaryEdge, boundaryCell, &
- boundaryVertex, verticesOnEdge
+ boundaryVertex, verticesOnEdge, edgeMask, cellMask, vertexMask
! Initialize z-level grid variables from h, read in from input file.
block => domain % blocklist
@@ -664,6 +656,9 @@
boundaryEdge => block % mesh % boundaryEdge % array
boundaryCell => block % mesh % boundaryCell % array
boundaryVertex => block % mesh % boundaryVertex % array
+ edgeMask => block % mesh % edgeMask % array
+ cellMask => block % mesh % cellMask % array
+ vertexMask => block % mesh % vertexMask % array
nCells = block % mesh % nCells
nEdges = block % mesh % nEdges
@@ -717,22 +712,35 @@
maxLevelVertexTop(nVertices+1) = 0
! set boundary edge
- boundaryEdge=1
+ boundaryEdge(:,1:nEdges+1)=1
+ edgeMask(:,1:nEdges+1)=0
do iEdge=1,nEdges
boundaryEdge(1:maxLevelEdgeTop(iEdge),iEdge)=0
+ edgeMask(1:maxLevelEdgeTop(iEdge),iEdge)=1
end do
!
! Find cells and vertices that have an edge on the boundary
!
- boundaryCell(:,:) = 0
+ boundaryCell(:,1:nCells+1) = 0
+ cellMask(:,1:nCells+1) = 1
+ boundaryVertex(:,1:nVertices+1) = 0
+ vertexMask(:,1:nVertices+1) = 1
do iEdge=1,nEdges
do k=1,nVertLevels
if (boundaryEdge(k,iEdge).eq.1) then
boundaryCell(k,cellsOnEdge(1,iEdge)) = 1
boundaryCell(k,cellsOnEdge(2,iEdge)) = 1
+ if(maxLevelCell(cellsOnEdge(1,iEdge)) > k) then
+ cellMask(k, cellsOnEdge(1,iEdge)) = 0
+ end if
+ if(maxLevelCell(cellsOnEdge(2,iEdge)) > k) then
+ cellMask(k, cellsOnEdge(2,iEdge)) = 0
+ end if
boundaryVertex(k,verticesOnEdge(1,iEdge)) = 1
boundaryVertex(k,verticesOnEdge(2,iEdge)) = 1
+ vertexMask(k,verticesOnEdge(1,iEdge)) = 0
+ vertexMask(k,verticesOnEdge(2,iEdge)) = 0
endif
end do
end do
@@ -743,7 +751,7 @@
! Note: We do not update halos on maxLevel* variables. I want the
! outside edge of a halo to be zero on each processor.
-end subroutine compute_maxLevel!}}}
+end subroutine ocn_compute_max_level!}}}
subroutine mpas_core_finalize(domain)!{{{
@@ -758,7 +766,7 @@
end subroutine mpas_core_finalize!}}}
- subroutine compute_mesh_scaling(mesh)!{{{
+ subroutine ocn_compute_mesh_scaling(mesh)!{{{
use mpas_grid_types
use mpas_configure
@@ -788,7 +796,7 @@
end do
end if
- end subroutine compute_mesh_scaling!}}}
+ end subroutine ocn_compute_mesh_scaling!}}}
end module mpas_core
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_restoring.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_restoring.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_restoring.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -111,6 +111,7 @@
integer :: iCell, nCellsSolve, k
real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore
+ real (kind=RKIND) :: invTemp, invSalinity
err = 0
@@ -121,17 +122,14 @@
temperatureRestore => grid % temperatureRestore % array
salinityRestore => grid % salinityRestore % array
+ invTemp = 1.0 / (temperatureTimeScale * 86400.0)
+ invSalinity = 1.0 / (salinityTimeScale * 86400.0)
+
k = 1 ! restoring only in top layer
do iCell=1,nCellsSolve
+ tend(indexT, k, iCell) = tend(indexT, k, iCell) - h(k,iCell)*(tracers(indexT, k, iCell) - temperatureRestore(iCell)) * invTemp
+ tend(indexS, k, iCell) = tend(indexS, k, iCell) - h(k,iCell)*(tracers(indexS, k, iCell) - salinityRestore(iCell)) * invSalinity
- tend(indexT, k, iCell) = tend(indexT, k, iCell) &
- - h(k,iCell)*(tracers(indexT, k, iCell) - temperatureRestore(iCell)) &
- / (temperatureTimeScale * 86400.0)
-
- tend(indexS, k, iCell) = tend(indexS, k, iCell) &
- - h(k,iCell)*(tracers(indexS, k, iCell) - salinityRestore(iCell)) &
- / (salinityTimeScale * 86400.0)
-
! write(6,10) iCell, tracers(indexT, k, iCell), &
! temperatureRestore(iCell), tracers(indexT, k, iCell), &
! (tracers(indexT, k, iCell) - temperatureRestore(iCell)) &
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tendency.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tendency.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tendency.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -21,6 +21,8 @@
use mpas_constants
use mpas_timer
+ use mpas_ocn_tracer_advection
+
use ocn_thick_hadv
use ocn_thick_vadv
@@ -38,10 +40,17 @@
use ocn_equation_of_state
use ocn_vmix
+ use ocn_time_average
+
implicit none
private
save
+ type (timer_node), pointer :: diagEOSTimer
+ type (timer_node), pointer :: thickHadvTimer, thickVadvTimer
+ type (timer_node), pointer :: velCorTimer, velVadvTimer, velPgradTimer, velHmixTimer, velForceTimer, velExpVmixTimer
+ type (timer_node), pointer :: tracerHadvTimer, tracerVadvTimer, tracerHmixTimer, tracerExpVmixTimer, tracerRestoringTimer
+
!--------------------------------------------------------------------
!
! Public parameters
@@ -59,7 +68,8 @@
ocn_tend_scalar, &
ocn_diagnostic_solve, &
ocn_wtop, &
- ocn_fuperp
+ ocn_fuperp, &
+ ocn_tendency_init
!--------------------------------------------------------------------
!
@@ -67,7 +77,11 @@
!
!--------------------------------------------------------------------
+ integer :: hadv2nd, hadv3rd, hadv4th
+ integer :: ke_cell_flag, ke_vertex_flag
+ real (kind=RKIND) :: coef_3rd_order, fCoef
+
!***********************************************************************
contains
@@ -85,100 +99,25 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tend_h(tend, s, d, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed tendencies for prognostic variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+ subroutine ocn_tend_h(tend, s, grid)!{{{
implicit none
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (diagnostics_type), intent(in) :: d
- type (mesh_type), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure
+ type (state_type), intent(in) :: s !< Input: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, &
- vertex1, vertex2, eoe, i, j, err
+ real (kind=RKIND), dimension(:,:), pointer :: h_edge, u, wTop, tend_h
-! mrp 110512 I just split compute_tend into compute_tend_u and ocn_tend_h.
-! Most of these variables can be removed, but at a later time.
- integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, &
- upstream_bias, wTopEdge, rho0Inv, r
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel
- real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure, &
- tend_h, circulation, vorticity, ke, ke_edge, pv_edge, &
- MontPot, wTop, divergence, vertViscTopOfEdge
- type (dm_info) :: dminfo
+ integer :: err
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot
- integer, dimension(:,:), pointer :: &
- cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, &
- edgesOnEdge, edgesOnVertex
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), allocatable:: fluxVertTop,w_dudzTopEdge
-
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
call mpas_timer_start("ocn_tend_h")
- h => s % h % array
u => s % u % array
- v => s % v % array
wTop => s % wTop % array
h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
- MontPot => s % MontPot % array
- pressure => s % pressure % array
- vertViscTopOfEdge => d % vertViscTopOfEdge % array
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
-
tend_h => tend % h % array
- nCells = grid % nCells
- nEdges = grid % nEdges
- nEdgesSolve = grid % nEdgesSolve
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
!
! height tendency: start accumulating tendency terms
!
@@ -190,23 +129,17 @@
! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
! for explanation of divergence operator.
!
- ! for z-level, only compute height tendency for top layer.
-
- call mpas_timer_start("ocn_tend_h-horiz adv")
-
+ call mpas_timer_start("hadv", .false., thickHadvTimer)
call ocn_thick_hadv_tend(grid, u, h_edge, tend_h, err)
+ call mpas_timer_stop("hadv", thickHadvTimer)
- call mpas_timer_stop("ocn_tend_h-horiz adv")
-
!
! height tendency: vertical advection term -d/dz(hw)
!
- ! Vertical advection computed for top layer of a z grid only.
- call mpas_timer_start("ocn_tend_h-vert adv")
-
+ call mpas_timer_start("vadv", .false., thickVadvTimer)
call ocn_thick_vadv_tend(grid, wtop, tend_h, err)
+ call mpas_timer_stop("vadv", thickVadvTimer)
- call mpas_timer_stop("ocn_tend_h-vert adv")
call mpas_timer_stop("ocn_tend_h")
end subroutine ocn_tend_h!}}}
@@ -225,109 +158,42 @@
!-----------------------------------------------------------------------
subroutine ocn_tend_u(tend, s, d, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute height and normal wind tendencies, as well as diagnostic variables
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed tendencies for prognostic variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
implicit none
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (diagnostics_type), intent(in) :: d
- type (mesh_type), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure
+ type (state_type), intent(in) :: s !< Input: State information
+ type (diagnostics_type), intent(in) :: d !< Input: Diagnostic information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
-! mrp 110512 I just split compute_tend into ocn_tend_u and compute_tend_h.
-! Some of these variables can be removed, but at a later time.
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, &
- vertex1, vertex2, eoe, i, j
-
- integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve, err
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, &
- upstream_bias, wTopEdge, rho0Inv, r, visc_vorticity_coef
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel, meshScalingDel2, meshScalingDel4
real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
+ h_edge, h, u, rho, zMid, pressure, &
+ tend_u, circulation, vorticity, ke, ke_edge, Vor_edge, &
MontPot, wTop, divergence, vertViscTopOfEdge
- type (dm_info) :: dminfo
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot
- integer, dimension(:,:), pointer :: &
- cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, &
- edgesOnEdge, edgesOnVertex
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), allocatable:: fluxVertTop,w_dudzTopEdge
-
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
-
real (kind=RKIND), dimension(:,:), pointer :: u_src
- real (kind=RKIND), parameter :: rho_ref = 1000.0
+ integer :: err
+
call mpas_timer_start("ocn_tend_u")
- h => s % h % array
u => s % u % array
- v => s % v % array
+ rho => s % rho % array
wTop => s % wTop % array
+ zMid => s % zMid % array
h_edge => s % h_edge % array
- circulation => s % circulation % array
vorticity => s % vorticity % array
divergence => s % divergence % array
ke => s % ke % array
ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
+ Vor_edge => s % Vor_edge % array
MontPot => s % MontPot % array
pressure => s % pressure % array
vertViscTopOfEdge => d % vertViscTopOfEdge % array
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
-! mrp 110516 cleanup fvertex fedge not used in this subroutine
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
-
tend_u => tend % u % array
- nCells = grid % nCells
- nEdges = grid % nEdges
- nEdgesSolve = grid % nEdgesSolve
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
u_src => grid % u_src % array
- meshScalingDel2 => grid % meshScalingDel2 % array
- meshScalingDel4 => grid % meshScalingDel4 % array
-
!
! velocity tendency: start accumulating tendency terms
!
@@ -338,66 +204,54 @@
! velocity tendency: nonlinear Coriolis term and grad of kinetic energy
!
- call mpas_timer_start("ocn_tend_u-coriolis")
+ call mpas_timer_start("coriolis", .false., velCorTimer)
+ call ocn_vel_coriolis_tend(grid, Vor_edge, h_edge, u, ke, tend_u, err)
+ call mpas_timer_stop("coriolis", velCorTimer)
- call ocn_vel_coriolis_tend(grid, pv_edge, h_edge, u, ke, tend_u, err)
-
- call mpas_timer_stop("ocn_tend_u-coriolis")
-
!
! velocity tendency: vertical advection term -w du/dz
!
- call mpas_timer_start("ocn_tend_u-vert adv")
+ call mpas_timer_start("vadv", .false., velVadvTimer)
+ call ocn_vel_vadv_tend(grid, u, h_edge, wtop, tend_u, err)
+ call mpas_timer_stop("vadv", velVadvTimer)
- call ocn_vel_vadv_tend(grid, u, wtop, tend_u, err)
-
- call mpas_timer_stop("ocn_tend_u-vert adv")
-
!
! velocity tendency: pressure gradient
!
- call mpas_timer_start("ocn_tend_u-pressure grad")
-
- if (config_vert_grid_type.eq.'isopycnal') then
- call ocn_vel_pressure_grad_tend(grid, MontPot, tend_u, err)
- elseif (config_vert_grid_type.eq.'zlevel') then
- call ocn_vel_pressure_grad_tend(grid, pressure, tend_u, err)
+ call mpas_timer_start("pressure grad", .false., velPgradTimer)
+ if (config_pressure_type.eq.'MontgomeryPotential') then
+ call ocn_vel_pressure_grad_tend(grid, MontPot, zMid, rho, tend_u, err)
+ else
+ call ocn_vel_pressure_grad_tend(grid, pressure, zMid, rho, tend_u, err)
end if
+ call mpas_timer_stop("pressure grad", velPgradTimer)
- call mpas_timer_stop("ocn_tend_u-pressure grad")
-
!
! velocity tendency: del2 dissipation, </font>
<font color="black">u_2 </font>
<font color="black">abla^2 u
! computed as </font>
<font color="black">u( </font>
<font color="black">abla divergence + k \times </font>
<font color="gray">abla vorticity )
! strictly only valid for config_h_mom_eddy_visc2 == constant
!
- call mpas_timer_start("ocn_tend_u-horiz mix")
-
+ call mpas_timer_start("hmix", .false., velHmixTimer)
call ocn_vel_hmix_tend(grid, divergence, vorticity, tend_u, err)
+ call mpas_timer_stop("hmix", velHmixTimer)
- call mpas_timer_stop("ocn_tend_u-horiz mix")
-
!
! velocity tendency: forcing and bottom drag
!
! mrp 101115 note: in order to include flux boundary conditions, we will need to
! know the bottom edge with nonzero velocity and place the drag there.
- call mpas_timer_start("ocn_tend_u-forcings")
-
+ call mpas_timer_start("forcings", .false., velForceTimer)
call ocn_vel_forcing_tend(grid, u, u_src, ke_edge, h_edge, tend_u, err)
+ call mpas_timer_stop("forcings", velForceTimer)
- call mpas_timer_stop("ocn_tend_u-forcings")
-
!
! velocity tendency: vertical mixing d/dz( nu_v du/dz))
!
if (.not.config_implicit_vertical_mix) then
- call mpas_timer_start("ocn_tend_u-explicit vert mix")
-
+ call mpas_timer_start("explicit vmix", .false., velExpVmixTimer)
call ocn_vel_vmix_tend_explicit(grid, u, h_edge, vertvisctopofedge, tend_u, err)
-
- call mpas_timer_stop("ocn_tend_u-explicit vert mix")
+ call mpas_timer_stop("explicit vmix", velExpVmixTimer)
endif
call mpas_timer_stop("ocn_tend_u")
@@ -415,93 +269,42 @@
!> This routine computes the scalar (tracer) tendency for the ocean
!
!-----------------------------------------------------------------------
-
- subroutine ocn_tend_scalar(tend, s, d, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Input: s - current model state
- ! grid - grid metadata
- ! note: the variable s % tracers really contains the tracers,
- ! not tracers*h
- !
- ! Output: tend - computed scalar tendencies
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+ subroutine ocn_tend_scalar(tend, s, d, grid, dt)!{{{
implicit none
- type (tend_type), intent(inout) :: tend
- type (state_type), intent(in) :: s
- type (diagnostics_type), intent(in) :: d
- type (mesh_type), intent(in) :: grid
+ type (tend_type), intent(inout) :: tend !< Input/Output: Tendency structure
+ type (state_type), intent(in) :: s !< Input: State information
+ type (diagnostics_type), intent(in) :: d !< Input: Diagnostic information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+ real (kind=RKIND), intent(in) :: dt !< Input: Time step
- integer :: i, k, iCell, iEdge, iTracer, cell1, cell2, upwindCell,&
- nEdges, nCells, nCellsSolve, nVertLevels, num_tracers, err
- real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux
- real (kind=RKIND) :: flux, tracer_edge, r
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
real (kind=RKIND), dimension(:,:), pointer :: &
- u,h,wTop, h_edge, vertDiffTopOfCell
+ u, h,wTop, h_edge, vertDiffTopOfCell, tend_h, uh
real (kind=RKIND), dimension(:,:,:), pointer :: &
tracers, tend_tr
- integer, dimension(:,:), pointer :: boundaryEdge
- type (dm_info) :: dminfo
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot
- integer, dimension(:,:), pointer :: cellsOnEdge, boundaryCell
- real (kind=RKIND), dimension(:), pointer :: zTopZLevel,zMidZLevel, &
- hRatioZLevelK, hRatioZLevelKm1, meshScalingDel2, meshScalingDel4
- real (kind=RKIND), dimension(:), allocatable:: tracer2ndDer, tracersIn, tracersOut, posZMidZLevel, &
- posZTopZLevel
- real (kind=RKIND), dimension(:,:), allocatable:: fluxVertTop, boundaryMask
- real (kind=RKIND), dimension(:,:,:), allocatable::tr_flux, tr_div, delsq_tracer, tracerTop
+ integer :: err, iEdge, k
-
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND) :: coef_3rd_order, flux3Coef, cSignWTop
-
- integer :: index_temperature, index_salinity, rrr
- real (kind=RKIND), dimension(:), pointer :: temperatureRestore, salinityRestore
-
call mpas_timer_start("ocn_tend_scalar")
u => s % u % array
h => s % h % array
- boundaryCell=> grid % boundaryCell % array
wTop => s % wTop % array
tracers => s % tracers % array
h_edge => s % h_edge % array
vertDiffTopOfCell => d % vertDiffTopOfCell % array
tend_tr => tend % tracers % array
-
- areaCell => grid % areaCell % array
- cellsOnEdge => grid % cellsOnEdge % array
- dvEdge => grid % dvEdge % array
- dcEdge => grid % dcEdge % array
- zTopZLevel => grid % zTopZLevel % array
- zMidZLevel => grid % zMidZLevel % array
- hRatioZLevelK => grid % hRatioZLevelK % array
- hRatioZLevelKm1 => grid % hRatioZLevelKm1 % array
- boundaryEdge => grid % boundaryEdge % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
+ tend_h => tend % h % array
- nEdges = grid % nEdges
- nCells = grid % nCells
- nCellsSolve = grid % nCellsSolve
- nVertLevels = grid % nVertLevels
- num_tracers = s % num_tracers
+ allocate(uh(grid % nVertLevels, grid % nEdges+1))
- meshScalingDel2 => grid % meshScalingDel2 % array
- meshScalingDel4 => grid % meshScalingDel4 % array
+ do iEdge = 1, grid % nEdges
+ do k = 1, grid % nVertLevels
+ uh(k, iEdge) = u(k, iEdge) * h_edge(k, iEdge)
+ end do
+ end do
-
- deriv_two => grid % deriv_two % array
-
!
! initialize tracer tendency (RHS of tracer equation) to zero.
!
@@ -515,32 +318,19 @@
! and then change maxLevelEdgeTop to maxLevelEdgeBot in the following section.
! tracer_edge at the boundary will also need to be defined for flux boundaries.
- call mpas_timer_start("ocn_tend_scalar-horiz adv")
+ ! Monotonoic Advection, or standard advection
+ call mpas_timer_start("adv", .false., tracerHadvTimer)
+ call mpas_ocn_tracer_advection_tend(tracers, uh, wTop, h, h, dt, grid, tend_h, tend_tr)
+ call mpas_timer_stop("adv", tracerHadvTimer)
- call ocn_tracer_hadv_tend(grid, u, h_edge, tracers, tend_tr, err)
- call mpas_timer_stop("ocn_tend_scalar-horiz adv")
-
-
!
- ! tracer tendency: vertical advection term -d/dz( h \phi w)
- !
-
- call mpas_timer_start("ocn_tend_scalar-vert adv")
-
- call ocn_tracer_vadv_tend(grid, wtop, tracers, tend_tr, err)
-
- call mpas_timer_stop("ocn_tend_scalar-vert adv")
-
- !
! tracer tendency: del2 horizontal tracer diffusion, div(h \kappa_2 </font>
<font color="gray">abla \phi)
!
- call mpas_timer_start("ocn_tend_scalar-horiz diff")
-
+ call mpas_timer_start("hmix", .false., tracerHmixTimer)
call ocn_tracer_hmix_tend(grid, h_edge, tracers, tend_tr, err)
+ call mpas_timer_stop("hmix", tracerHmixTimer)
- call mpas_timer_stop("ocn_tend_scalar-horiz diff")
-
! mrp 110516 printing
!print *, 'tend_tr 1',minval(tend_tr(3,1,1:nCells)),&
! maxval(tend_tr(3,1,1:nCells))
@@ -552,11 +342,11 @@
! tracer tendency: vertical diffusion h d/dz( \kappa_v d\phi/dz)
!
if (.not.config_implicit_vertical_mix) then
- call mpas_timer_start("ocn_tend_scalar-explicit vert diff")
+ call mpas_timer_start("explicit vmix", .false., tracerExpVmixTimer)
call ocn_tracer_vmix_tend_explicit(grid, h, vertdifftopofcell, tracers, tend_tr, err)
- call mpas_timer_stop("ocn_tend_scalar-explicit vert diff")
+ call mpas_timer_stop("explicit vmix", tracerExpVmixTimer)
endif
! mrp 110516 printing
@@ -567,15 +357,17 @@
!
! add restoring to T and S in top model layer
!
- call mpas_timer_start("ocn_tend_scalar-restoring")
+ call mpas_timer_start("restoring", .false., tracerRestoringTimer)
call ocn_restoring_tend(grid, h, s%index_temperature, s%index_salinity, tracers, tend_tr, err)
- call mpas_timer_stop("ocn_tend_scalar-restoring")
+ call mpas_timer_stop("restoring", tracerRestoringTimer)
10 format(2i8,10e20.10)
call mpas_timer_stop("ocn_tend_scalar")
+ deallocate(uh)
+
end subroutine ocn_tend_scalar!}}}
!***********************************************************************
@@ -592,57 +384,41 @@
!-----------------------------------------------------------------------
subroutine ocn_diagnostic_solve(dt, s, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields used in the tendency computations
- !
- ! Input: grid - grid metadata
- !
- ! Output: s - computed diagnostics
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
implicit none
- real (kind=RKIND), intent(in) :: dt
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
+ real (kind=RKIND), intent(in) :: dt !< Input: Time step
+ type (state_type), intent(inout) :: s !< Input/Output: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv
+ integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j
+ integer :: boundaryMask, velMask, nCells, nEdges, nVertices, nVertLevels, vertexDegree, err
- integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree, fCoef, err
+ integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
+ maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
+ maxLevelVertexBot
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
+ verticesOnEdge, edgesOnEdge, edgesOnVertex,boundaryCell
+ real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2, coef_3rd_order, r_tmp, invAreaCell1, invAreaCell2, invAreaTri1, invAreaTri2, invLength, h_vertex
+ real (kind=RKIND), dimension(:), allocatable:: pTop
+
real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- hZLevel
+ h_s, fVertex, dvEdge, dcEdge, areaCell, areaTriangle, &
+ referenceBottomDepth, ssh
real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, w, pressure,&
- circulation, vorticity, ke, ke_edge, MontPot, wTop, &
- pv_edge, pv_vertex, pv_cell, gradPVn, gradPVt, divergence, &
+ weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure,&
+ circulation, vorticity, ke, ke_edge, MontPot, wTop, zMid, &
+ Vor_edge, Vor_vertex, Vor_cell, gradVor_n, gradVor_t, divergence, &
rho, temperature, salinity, kev, kevc
- real (kind=RKIND), dimension(:,:,:), pointer :: tracers
- real (kind=RKIND), dimension(:), allocatable:: pTop
+ real (kind=RKIND), dimension(:,:,:), pointer :: tracers, deriv_two
real (kind=RKIND), dimension(:,:), allocatable:: div_u
character :: c1*6
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
- verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, &
- boundaryEdge, boundaryCell
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
- maxLevelVertexBot, maxLevelVertexTop
- real (kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2
- real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
- real (kind=RKIND) :: coef_3rd_order
- real (kind=RKIND) :: r, h1, h2
-
- call mpas_timer_start("ocn_diagnostic_solve")
-
h => s % h % array
u => s % u % array
v => s % v % array
- wTop => s % wTop % array
h_edge => s % h_edge % array
circulation => s % circulation % array
vorticity => s % vorticity % array
@@ -651,15 +427,17 @@
kev => s % kev % array
kevc => s % kevc % array
ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
- pv_vertex => s % pv_vertex % array
- pv_cell => s % pv_cell % array
- gradPVn => s % gradPVn % array
- gradPVt => s % gradPVt % array
+ Vor_edge => s % Vor_edge % array
+ Vor_vertex => s % Vor_vertex % array
+ Vor_cell => s % Vor_cell % array
+ gradVor_n => s % gradVor_n % array
+ gradVor_t => s % gradVor_t % array
rho => s % rho % array
- tracers => s % tracers % array
MontPot => s % MontPot % array
pressure => s % pressure % array
+ zMid => s % zMid % array
+ ssh => s % ssh % array
+ tracers => s % tracers % array
weightsOnEdge => grid % weightsOnEdge % array
kiteAreasOnVertex => grid % kiteAreasOnVertex % array
@@ -667,7 +445,6 @@
cellsOnVertex => grid % cellsOnVertex % array
verticesOnEdge => grid % verticesOnEdge % array
nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
nEdgesOnEdge => grid % nEdgesOnEdge % array
edgesOnEdge => grid % edgesOnEdge % array
edgesOnVertex => grid % edgesOnVertex % array
@@ -677,14 +454,12 @@
areaTriangle => grid % areaTriangle % array
h_s => grid % h_s % array
fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- hZLevel => grid % hZLevel % array
+ referenceBottomDepth => grid % referenceBottomDepth % array
deriv_two => grid % deriv_two % array
maxLevelCell => grid % maxLevelCell % array
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
maxLevelEdgeBot => grid % maxLevelEdgeBot % array
maxLevelVertexBot => grid % maxLevelVertexBot % array
- maxLevelVertexTop => grid % maxLevelVertexTop % array
nCells = grid % nCells
nEdges = grid % nEdges
@@ -692,7 +467,6 @@
nVertLevels = grid % nVertLevels
vertexDegree = grid % vertexDegree
- boundaryEdge => grid % boundaryEdge % array
boundaryCell => grid % boundaryCell % array
!
@@ -702,205 +476,168 @@
! mrp 101115 note: in order to include flux boundary conditions, we will need to
! assign h_edge for maxLevelEdgeTop:maxLevelEdgeBot in the following section
- ! mrp 110516 efficiency note: For z-level, only do this on level 1. h_edge for all
- ! lower levels is defined by hZlevel.
+ ! initialize h_edge to avoid divide by zero and NaN problems.
+ h_edge = -1.0e34
+ coef_3rd_order = config_coef_3rd_order
- call mpas_timer_start("ocn_diagnostic_solve-hEdge")
-
- coef_3rd_order = 0.
- if (config_thickness_adv_order == 3) coef_3rd_order = 1.0
- if (config_thickness_adv_order == 3 .and. config_monotonic) coef_3rd_order = 0.25
-
- if (config_thickness_adv_order == 2) then
- call mpas_timer_start("ocn_diagnostic_solve-hEdge 2")
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
- end do
+ do iEdge=1,nEdges*hadv2nd
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeTop(iEdge)
+ h_edge(k,iEdge) = 0.5 * (h(k,cell1) + h(k,cell2))
end do
- call mpas_timer_stop("ocn_diagnostic_solve-hEdge 2")
+ end do
- else if (config_thickness_adv_order == 3) then
- call mpas_timer_start("ocn_diagnostic_solve-hEdge 3")
+ do iEdge=1,nEdges*hadv3rd
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeTop(iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
+ boundaryMask = abs(transfer(.not.(boundaryCell(k,cell1) == 0 .and. boundaryCell(k,cell2) == 0), boundaryMask))
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1) * boundaryMask
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2) * boundaryMask
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+ !-- all edges of cell 1
+ do i=1, nEdgesOnCell(cell1) * boundaryMask
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
- end do
+ !-- all edges of cell 2
+ do i=1, nEdgesOnCell(cell2) * boundaryMask
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
- end do
+ velMask = 2*(abs(transfer(u(k,iEdge) <= 0, velMask))) - 1
- endif
+ h_edge(k,iEdge) = 0.5*(h(k,cell1) + h(k,cell2)) - (dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ + velMask * (dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
- !-- if u > 0:
- if (u(k,iEdge) > 0) then
- h_edge(k,iEdge) = &
- 0.5*(h(k,cell1) + h(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
- !-- else u <= 0:
- else
- h_edge(k,iEdge) = &
- 0.5*(h(k,cell1) + h(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12.
- end if
+ end do ! do k
+ end do ! do iEdge
- end do ! do k
- end do ! do iEdge
+ do iEdge=1,nEdges*hadv4th
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
- call mpas_timer_stop("ocn_diagnostic_solve-hEdge 3")
- else if (config_thickness_adv_order == 4) then
- call mpas_timer_start("ocn_diagnostic_solve-hEdge 4")
+ do k=1,maxLevelEdgeTop(iEdge)
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
+ d2fdx2_cell1 = 0.0
+ d2fdx2_cell2 = 0.0
- do k=1,maxLevelEdgeTop(iEdge)
+ boundaryMask = abs(transfer(.not.(boundaryCell(k,cell1) == 0 .and. boundaryCell(k,cell2) == 0), boundaryMask))
- d2fdx2_cell1 = 0.0
- d2fdx2_cell2 = 0.0
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1) * boundaryMask
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2) * boundaryMask
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+ !-- all edges of cell 1
+ do i=1, nEdgesOnCell(cell1) * boundaryMask
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
+ end do
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * h(k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * h(k,cell2)
+ !-- all edges of cell 2
+ do i=1, nEdgesOnCell(cell2) * boundaryMask
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
+ end do
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * h(k,grid % CellsOnCell % array (i,cell1))
- end do
+ h_edge(k,iEdge) = &
+ 0.5*(h(k,cell1) + h(k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * h(k,grid % CellsOnCell % array (i,cell2))
- end do
+ end do ! do k
+ end do ! do iEdge
- endif
-
- h_edge(k,iEdge) = &
- 0.5*(h(k,cell1) + h(k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.
-
- end do ! do k
- end do ! do iEdge
-
- call mpas_timer_stop("ocn_diagnostic_solve-hEdge 4")
- endif ! if(config_thickness_adv_order == 2)
- call mpas_timer_stop("ocn_diagnostic_solve-hEdge")
-
!
! set the velocity and height at dummy address
! used -1e34 so error clearly occurs if these values are used.
!
-!mrp 110516 change to zero, change back later:
u(:,nEdges+1) = -1e34
h(:,nCells+1) = -1e34
tracers(s % index_temperature,:,nCells+1) = -1e34
tracers(s % index_salinity,:,nCells+1) = -1e34
- !
- ! Compute circulation and relative vorticity at each vertex
- !
circulation(:,:) = 0.0
+ vorticity(:,:) = 0.0
+ divergence(:,:) = 0.0
+ ke(:,:) = 0.0
+ v(:,:) = 0.0
do iEdge=1,nEdges
vertex1 = verticesOnEdge(1,iEdge)
vertex2 = verticesOnEdge(2,iEdge)
- do k=1,maxLevelEdgeBot(iEdge)
- circulation(k,vertex1) = circulation(k,vertex1) - dcEdge(iEdge) * u(k,iEdge)
- circulation(k,vertex2) = circulation(k,vertex2) + dcEdge(iEdge) * u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- do k=1,maxLevelVertexBot(iVertex)
- vorticity(k,iVertex) = circulation(k,iVertex) / areaTriangle(iVertex)
- end do
- end do
- !
- ! Compute the divergence at each cell center
- !
- divergence(:,:) = 0.0
- do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeBot(iEdge)
- divergence(k,cell1) = divergence(k,cell1) + u(k,iEdge)*dvEdge(iEdge)
- divergence(k,cell2) = divergence(k,cell2) - u(k,iEdge)*dvEdge(iEdge)
- enddo
- end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,maxLevelCell(iCell)
- divergence(k,iCell) = divergence(k,iCell) * r
- enddo
- enddo
- !
- ! Compute kinetic energy in each cell
- !
- ke(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
+ invAreaTri1 = 1.0 / areaTriangle(vertex1)
+ invAreaTri2 = 1.0 / areaTriangle(vertex2)
+
+ !dwj: 02/23/12 arraCell(nCells+1) is still 0, this is a temporary fix
+ invAreaCell1 = 1.0 / max(areaCell(cell1), 1.0)
+ invAreaCell2 = 1.0 / max(areaCell(cell2), 1.0)
+
do k=1,maxLevelEdgeBot(iEdge)
- ke(k,cell1) = ke(k,cell1) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
- ke(k,cell2) = ke(k,cell2) + 0.25 * dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2.0
- enddo
+ ! Compute circulation and relative vorticity at each vertex
+ r_tmp = dcEdge(iEdge) * u(k,iEdge)
+ circulation(k,vertex1) = circulation(k,vertex1) - r_tmp
+ circulation(k,vertex2) = circulation(k,vertex2) + r_tmp
+
+ vorticity(k, vertex1) = vorticity(k, vertex1) - r_tmp * invAreaTri1
+ vorticity(k, vertex2) = vorticity(k, vertex2) + r_tmp * invAreaTri2
+
+ ! Compute the divergence at each cell center
+ r_tmp = dvEdge(iEdge) * u(k, iEdge)
+ divergence(k,cell1) = divergence(k,cell1) + r_tmp * invAreaCell1
+ divergence(k,cell2) = divergence(k,cell2) - r_tmp * invAreaCell2
+
+ ! Compute kinetic energy in each cell
+ r_tmp = r_tmp * dcEdge(iEdge) * u(k,iEdge)
+ ke(k,cell1) = ke(k,cell1) + 0.25 * r_tmp * invAreaCell1
+ ke(k,cell2) = ke(k,cell2) + 0.25 * r_tmp * invAreaCell2
+ end do
+
+ ! Compute v (tangential) velocities
+ do i=1,nEdgesOnEdge(iEdge)
+ eoe = edgesOnEdge(i,iEdge)
+ ! mrp 101115 note: in order to include flux boundary conditions,
+ ! the following loop may need to change to maxLevelEdgeBot
+ do k = 1,maxLevelEdgeTop(iEdge)
+ v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
+ end do
+ end do
+
end do
- do iCell = 1,nCells
- do k = 1,maxLevelCell(iCell)
- ke(k,iCell) = ke(k,iCell) / areaCell(iCell)
- enddo
- enddo
!
! Compute kinetic energy in each vertex
!
kev(:,:) = 0.0; kevc(:,:) = 0.0
- do iEdge=1,nEdges
+ do iEdge=1,nEdges*ke_vertex_flag
do k=1,nVertLevels
- kev(k,verticesOnEdge(1,iEdge)) = kev(k,verticesOnEdge(1,iEdge)) + dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2
- kev(k,verticesOnEdge(2,iEdge)) = kev(k,verticesOnEdge(2,iEdge)) + dcEdge(iEdge) * dvEdge(iEdge) * u(k,iEdge)**2
+ r_tmp = dcEdge(iEdge) * dvEdge(iEdge) * u(k, iEdge)**2
+ kev(k,verticesOnEdge(1,iEdge)) = kev(k,verticesOnEdge(1,iEdge)) + r_tmp
+ kev(k,verticesOnEdge(2,iEdge)) = kev(k,verticesOnEdge(2,iEdge)) + r_tmp
end do
end do
- do iVertex = 1,nVertices
+ do iVertex = 1,nVertices*ke_vertex_flag
do k=1,nVertLevels
- kev(k,iVertex) = kev(k,iVertex) / areaTriangle(iVertex) / 4.0
+ kev(k,iVertex) = kev(k,iVertex) / areaTriangle(iVertex) * 0.25
enddo
enddo
- do iVertex = 1, nVertices
+ do iVertex = 1, nVertices*ke_vertex_flag
do i=1,grid % vertexDegree
iCell = cellsOnVertex(i,iVertex)
+ !dwj: 02/23/12 arraCell(nCells+1) is still 0, this is a temporary fix
+ invAreaCell1 = 1.0 / max(areaCell(iCell), 1.0)
do k=1,nVertLevels
- kevc(k,iCell) = kevc(k,iCell) + kiteAreasOnVertex(i, iVertex) * kev(k, iVertex) / areaCell(iCell)
+ kevc(k,iCell) = kevc(k,iCell) + kiteAreasOnVertex(i, iVertex) * kev(k, iVertex) * invAreaCell1
enddo
enddo
enddo
@@ -908,35 +645,17 @@
!
! Compute kinetic energy in each cell by blending ke and kevc
!
- if(config_include_KE_vertex) then
- do iCell=1,nCells
+ do iCell=1,nCells*ke_vertex_flag
do k=1,nVertLevels
ke(k,iCell) = 5.0/8.0*ke(k,iCell) + 3.0/8.0*kevc(k,iCell)
end do
end do
- endif
!
- ! Compute v (tangential) velocities
- !
- v(:,:) = 0.0
- do iEdge = 1,nEdges
- do i=1,nEdgesOnEdge(iEdge)
- eoe = edgesOnEdge(i,iEdge)
- ! mrp 101115 note: in order to include flux boundary conditions,
- ! the following loop may need to change to maxLevelEdgeBot
- do k = 1,maxLevelEdgeTop(iEdge)
- v(k,iEdge) = v(k,iEdge) + weightsOnEdge(i,iEdge) * u(k, eoe)
- end do
- end do
- end do
-
- !
! Compute ke on cell edges at velocity locations for quadratic bottom drag.
!
! mrp 101025 efficiency note: we could get rid of ke_edge completely by
! using sqrt(u(k,iEdge)**2 + v(k,iEdge)**2) in its place elsewhere.
- ke_edge = 0.0 !mrp remove 0 for efficiency
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
@@ -947,85 +666,67 @@
!
! Compute height at vertices, pv at vertices, and average pv to edge locations
- ! ( this computes pv_vertex at all vertices bounding real cells and distance-1 ghost cells )
+ ! ( this computes Vor_vertex at all vertices bounding real cells and distance-1 ghost cells )
!
- if (trim(config_time_integration) == 'RK4') then
- ! for RK4, PV is really PV = (eta+f)/h
- fCoef = 1
- elseif (trim(config_time_integration) == 'split_explicit' &
- .or.trim(config_time_integration) == 'unsplit_explicit') then
- ! for split explicit, PV is eta/h because f is added separately to the momentum forcing.
-! mrp temp, new should be:
- fCoef = 0
-! old, for testing:
-! fCoef = 1
- end if
-
do iVertex = 1,nVertices
+ invAreaTri1 = 1.0 / areaTriangle(iVertex)
do k=1,maxLevelVertexBot(iVertex)
h_vertex = 0.0
do i=1,vertexDegree
h_vertex = h_vertex + h(k,cellsOnVertex(i,iVertex)) * kiteAreasOnVertex(i,iVertex)
end do
- h_vertex = h_vertex / areaTriangle(iVertex)
+ h_vertex = h_vertex * invAreaTri1
- pv_vertex(k,iVertex) = (fCoef*fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
+ Vor_vertex(k,iVertex) = (fCoef*fVertex(iVertex) + vorticity(k,iVertex)) / h_vertex
end do
end do
- !
- ! Compute pv at cell centers
- ! ( this computes pv_cell for all real cells and distance-1 ghost cells )
- !
- pv_cell(:,:) = 0.0
+ Vor_cell(:,:) = 0.0
+ Vor_edge(:,:) = 0.0
do iVertex = 1,nVertices
do i=1,vertexDegree
iCell = cellsOnVertex(i,iVertex)
+ iEdge = edgesOnVertex(i,iVertex)
+
+ !dwj: 02/23/12 arraCell(nCells+1) is still 0, this is a temporary fix
+ invAreaCell1 = 1.0 / max(areaCell(iCell), 1.0)
+
+ ! Compute pv at cell centers
+ ! ( this computes Vor_cell for all real cells and distance-1 ghost cells )
do k = 1,maxLevelCell(iCell)
- pv_cell(k,iCell) = pv_cell(k,iCell) &
- + kiteAreasOnVertex(i, iVertex) * pv_vertex(k, iVertex) &
- / areaCell(iCell)
+ Vor_cell(k,iCell) = Vor_cell(k,iCell) + kiteAreasOnVertex(i, iVertex) * Vor_vertex(k, iVertex) * invAreaCell1
enddo
- enddo
- enddo
- !
- ! Compute pv at the edges
- ! ( this computes pv_edge at all edges bounding real cells )
- !
- pv_edge(:,:) = 0.0
- do iVertex = 1,nVertices
- do i=1,vertexDegree
- iEdge = edgesOnVertex(i,iVertex)
+ ! Compute pv at the edges
+ ! ( this computes Vor_edge at all edges bounding real cells )
do k=1,maxLevelEdgeBot(iEdge)
- pv_edge(k,iEdge) = pv_edge(k,iEdge) + 0.5 * pv_vertex(k,iVertex)
+ Vor_edge(k,iEdge) = Vor_edge(k,iEdge) + 0.5 * Vor_vertex(k,iVertex)
enddo
- end do
- end do
+ enddo
+ enddo
- !
- ! Compute gradient of PV in normal direction
- ! ( this computes gradPVn for all edges bounding real cells )
- !
- gradPVn(:,:) = 0.0
+! gradVor_n(:,:) = 0.0
+! gradVor_t(:,:) = 0.0
do iEdge = 1,nEdges
+ cell1 = cellsOnEdge(1, iEdge)
+ cell2 = cellsOnEdge(2, iEdge)
+ vertex1 = verticesOnedge(1, iEdge)
+ vertex2 = verticesOnedge(2, iEdge)
+
+ invLength = 1.0 / dcEdge(iEdge)
+ ! Compute gradient of PV in normal direction
+ ! ( this computes gradVor_n for all edges bounding real cells )
do k=1,maxLevelEdgeTop(iEdge)
- gradPVn(k,iEdge) = ( pv_cell(k,cellsOnEdge(2,iEdge)) &
- - pv_cell(k,cellsOnEdge(1,iEdge))) &
- / dcEdge(iEdge)
+ gradVor_n(k,iEdge) = (Vor_cell(k,cell2) - Vor_cell(k,cell1)) * invLength
enddo
- enddo
- !
- ! Compute gradient of PV in the tangent direction
- ! ( this computes gradPVt at all edges bounding real cells and distance-1 ghost cells )
- !
- do iEdge = 1,nEdges
+ invLength = 1.0 / dvEdge(iEdge)
+ ! Compute gradient of PV in the tangent direction
+ ! ( this computes gradVor_t at all edges bounding real cells and distance-1 ghost cells )
do k = 1,maxLevelEdgeBot(iEdge)
- gradPVt(k,iEdge) = ( pv_vertex(k,verticesOnEdge(2,iEdge)) &
- - pv_vertex(k,verticesOnEdge(1,iEdge))) &
- /dvEdge(iEdge)
+ gradVor_t(k,iEdge) = (Vor_vertex(k,vertex2) - Vor_vertex(k,vertex1)) * invLength
enddo
+
enddo
!
@@ -1033,9 +734,9 @@
!
do iEdge = 1,nEdges
do k = 1,maxLevelEdgeBot(iEdge)
- pv_edge(k,iEdge) = pv_edge(k,iEdge) &
- - 0.5 * dt* ( u(k,iEdge) * gradPVn(k,iEdge) &
- + v(k,iEdge) * gradPVt(k,iEdge) )
+ Vor_edge(k,iEdge) = Vor_edge(k,iEdge) &
+ - config_apvm_scale_factor * dt* ( u(k,iEdge) * gradVor_n(k,iEdge) &
+ + v(k,iEdge) * gradVor_t(k,iEdge) )
enddo
enddo
@@ -1044,17 +745,20 @@
!
! For an isopycnal model, density should remain constant.
! For zlevel, calculate in-situ density
- if (config_vert_grid_type.eq.'zlevel') then
+ if (config_vert_grid_type.ne.'isopycnal') then
+ call mpas_timer_start("equation of state", .false., diagEOSTimer)
call ocn_equation_of_state_rho(s, grid, 0, 'relative', err)
! mrp 110324 In order to visualize rhoDisplaced, include the following
call ocn_equation_of_state_rho(s, grid, 1, 'relative', err)
+ call mpas_timer_stop("equation of state", diagEOSTimer)
endif
!
! Pressure
! This section must be after computing rho
!
- if (config_vert_grid_type.eq.'isopycnal') then
+ ! dwj: 10/25/2011 - Need to explore isopycnal vs zlevel flags
+ if (config_pressure_type.eq.'MontgomeryPotential') then
! For Isopycnal model.
! Compute pressure at top of each layer, and then
@@ -1081,34 +785,52 @@
end do
deallocate(pTop)
- elseif (config_vert_grid_type.eq.'zlevel') then
+ else
- ! For z-level model.
- ! Compute pressure at middle of each level.
- ! At k=1, where p is pressure at a depth of hZLevel(1)/2, not
- ! pressure at middle of layer including SSH.
-
do iCell=1,nCells
- ! compute pressure for z-level coordinates
+ ! pressure for generalized coordinates
! assume atmospheric pressure at the surface is zero for now.
-
pressure(1,iCell) = rho(1,iCell)*gravity &
- * (h(1,iCell)-0.5*hZLevel(1))
+ * 0.5*h(1,iCell)
do k=2,maxLevelCell(iCell)
pressure(k,iCell) = pressure(k-1,iCell) &
- + 0.5*gravity*( rho(k-1,iCell)*hZLevel(k-1) &
- + rho(k ,iCell)*hZLevel(k ))
+ + 0.5*gravity*( rho(k-1,iCell)*h(k-1,iCell) &
+ + rho(k ,iCell)*h(k ,iCell))
end do
+ ! Compute zMid, the z-coordinate of the middle of the layer.
+ ! This is used for the rho g grad z momentum term.
+ ! Note the negative sign, since referenceBottomDepth is positive
+ ! and z-coordinates are negative below the surface.
+ k = maxLevelCell(iCell)
+ zMid(k:nVertLevels,iCell) = -referenceBottomDepth(k) + 0.5*h(k,iCell)
+
+ do k=maxLevelCell(iCell)-1, 1, -1
+ zMid(k,iCell) = zMid(k+1,iCell) &
+ + 0.5*( h(k+1,iCell) &
+ + h(k ,iCell))
+ end do
+
end do
endif
- call ocn_wtop(s,grid)
+ !
+ ! Sea Surface Height
+ !
+ do iCell=1,nCells
+ ! Start at the bottom where we know the depth, and go up.
+ ! The bottom depth for this cell is
+ ! referenceBottomDepth(maxLevelCell(iCell)).
+ ! Note the negative sign, since referenceBottomDepth is positive
+ ! and z-coordinates are negative below the surface.
- call mpas_timer_stop("ocn_diagnostic_solve")
+ ssh(iCell) = -referenceBottomDepth(maxLevelCell(iCell)) &
+ + sum(h(1:maxLevelCell(iCell),iCell))
+ end do
+
end subroutine ocn_diagnostic_solve!}}}
!***********************************************************************
@@ -1123,33 +845,24 @@
!> This routine computes the vertical velocity in the top layer for the ocean
!
!-----------------------------------------------------------------------
-
- subroutine ocn_wtop(s, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Compute diagnostic fields used in the tendency computations
- !
- ! Input: grid - grid metadata
- !
- ! Output: s - computed diagnostics
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
+ subroutine ocn_wtop(s1,s2, grid)!{{{
implicit none
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
+ type (state_type), intent(inout) :: s1 !< Input/Output: State 1 information
+ type (state_type), intent(inout) :: s2 !< Input/Output: State 2 information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
- ! mrp 110512 could clean this out, remove pointers?
integer :: iEdge, iCell, iVertex, k, cell1, cell2, vertex1, vertex2, eoe, i, j, cov
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv
+ real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, rho0Inv, hSum
integer :: nCells, nEdges, nVertices, nVertLevels, vertexDegree
real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- hZLevel
- real (kind=RKIND), dimension(:,:), pointer :: u,wTop
- real (kind=RKIND), dimension(:,:), allocatable:: div_u
+ h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle
+ real (kind=RKIND), dimension(:,:), pointer :: u,h,wTop, h_edge
+ real (kind=RKIND), dimension(:,:), allocatable:: div_hu
+ real (kind=RKIND), dimension(:), allocatable:: div_hu_btr, h_tend_col, h_weights
integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnVertex, &
verticesOnEdge, edgesOnCell, edgesOnEdge, edgesOnVertex, &
@@ -1158,14 +871,13 @@
maxLevelCell, maxLevelEdgeTop, maxLevelEdgeBot, &
maxLevelVertexBot, maxLevelVertexTop
- call mpas_timer_start("wTop")
+ h => s1 % h % array
+ h_edge => s1 % h_edge % array
+ u => s2 % u % array
+ wTop => s2 % wTop % array
- u => s % u % array
- wTop => s % wTop % array
-
areaCell => grid % areaCell % array
cellsOnEdge => grid % cellsOnEdge % array
- hZLevel => grid % hZLevel % array
maxLevelCell => grid % maxLevelCell % array
maxLevelEdgeBot => grid % maxLevelEdgeBot % array
dvEdge => grid % dvEdge % array
@@ -1174,46 +886,128 @@
nEdges = grid % nEdges
nVertLevels = grid % nVertLevels
+ allocate(div_hu(nVertLevels,nCells+1), div_hu_btr(nCells+1), &
+ h_tend_col(nVertLevels), h_weights(nVertLevels))
+
!
+ ! Compute div(h^{edge} u) for each cell
+ ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
+ !
+ div_hu(:,:) = 0.0
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeBot(iEdge)
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
+ div_hu(k,cell1) = div_hu(k,cell1) + flux
+ div_hu(k,cell2) = div_hu(k,cell2) - flux
+ end do
+ end do
+
+ do iCell=1,nCells
+ div_hu_btr(iCell) = 0.0
+ do k=1,maxLevelCell(iCell)
+ div_hu(k,iCell) = div_hu(k,iCell) / areaCell(iCell)
+ div_hu_btr(iCell) = div_hu_btr(iCell) + div_hu(k,iCell)
+ end do
+ end do
+
+ !
! vertical velocity through layer interface
!
+ !dwj: 10/25/2011 - Need to explore isopycnal vs zlevel flags
if (config_vert_grid_type.eq.'isopycnal') then
! set vertical velocity to zero in isopycnal case
wTop=0.0
elseif (config_vert_grid_type.eq.'zlevel') then
- !
- ! Compute div(u) for each cell
- ! See Ringler et al. (2010) jcp paper, eqn 19, 21, and fig. 3.
- !
- allocate(div_u(nVertLevels,nCells+1))
- div_u(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=2,maxLevelEdgeBot(iEdge)
- flux = u(k,iEdge) * dvEdge(iEdge)
- div_u(k,cell1) = div_u(k,cell1) + flux
- div_u(k,cell2) = div_u(k,cell2) - flux
- end do
- end do
+ do iCell=1,nCells
+ ! Vertical velocity through layer interface at top and
+ ! bottom is zero.
+ wTop(1,iCell) = 0.0
+ wTop(maxLevelCell(iCell)+1,iCell) = 0.0
+ do k=maxLevelCell(iCell),2,-1
+ wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k,iCell)
+ end do
+ end do
+ elseif (config_vert_grid_type.eq.'zstar1') then
+
+ ! This is a testing setting. The computation is similar to zstar,
+ ! but the weights are all in the top layer, so is a bit-for-bit
+ ! match with zlevel.
+
do iCell=1,nCells
+
+ h_tend_col = 0.0
+ h_tend_col(1) = - div_hu_btr(iCell)
+
! Vertical velocity through layer interface at top and
! bottom is zero.
wTop(1,iCell) = 0.0
wTop(maxLevelCell(iCell)+1,iCell) = 0.0
+
do k=maxLevelCell(iCell),2,-1
- wTop(k,iCell) = wTop(k+1,iCell) &
- - div_u(k,iCell)/areaCell(iCell)*hZLevel(k)
+ wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k,iCell) - h_tend_col(k)
end do
end do
- deallocate(div_u)
+ elseif (config_vert_grid_type.eq.'zstar') then
+
+ ! Distribute the change in total column height due to the external
+ ! mode, div_hu_btr, among all the layers. Distribute in proportion
+ ! to the layer thickness.
+
+ do iCell=1,nCells
+
+ hSum = 0.0
+ do k=1,maxLevelCell(iCell)
+ h_tend_col(k) = - h(k,iCell)*div_hu_btr(iCell)
+ hSum = hSum + h(k,iCell)
+ end do
+ h_tend_col = h_tend_col / hSum
+
+ ! Vertical velocity through layer interface at top and
+ ! bottom is zero.
+ wTop(1,iCell) = 0.0
+ wTop(maxLevelCell(iCell)+1,iCell) = 0.0
+ do k=maxLevelCell(iCell),2,-1
+ wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k,iCell) - h_tend_col(k)
+ end do
+ end do
+
+ elseif (config_vert_grid_type.eq.'zstarWeights') then
+
+ ! This is a test with other weights, not meant to be permanent.
+
+ h_weights = 0.0
+ h_weights(1:5) = 1.0
+ do k=1,10
+ h_weights(5+k) = 1.0-k*0.1
+ end do
+
+ do iCell=1,nCells
+
+ hSum = 0.0
+ do k=1,maxLevelCell(iCell)
+ h_tend_col(k) = - h_weights(k)*h(k,iCell)*div_hu_btr(iCell)
+ hSum = hSum + h_weights(k)*h(k,iCell)
+ end do
+ h_tend_col = h_tend_col / hSum
+
+ ! Vertical velocity through layer interface at top and
+ ! bottom is zero.
+ wTop(1,iCell) = 0.0
+ wTop(maxLevelCell(iCell)+1,iCell) = 0.0
+ do k=maxLevelCell(iCell),2,-1
+ wTop(k,iCell) = wTop(k+1,iCell) - div_hu(k,iCell) - h_tend_col(k)
+ end do
+ end do
+
endif
- call mpas_timer_stop("wTop")
+ deallocate(div_hu, div_hu_btr, h_tend_col, h_weights)
end subroutine ocn_wtop!}}}
@@ -1231,104 +1025,42 @@
!-----------------------------------------------------------------------
subroutine ocn_fuperp(s, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Put f*uBcl^{perp} in u as a work variable
- !
- ! Input: s - current model state
- ! grid - grid metadata
- !
- ! Output: tend - computed tendencies for prognostic variables
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
implicit none
- type (state_type), intent(inout) :: s
- type (mesh_type), intent(in) :: grid
+ type (state_type), intent(inout) :: s !< Input/Output: State information
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
! mrp 110512 I just split compute_tend into compute_tend_u and compute_tend_h.
! Some of these variables can be removed, but at a later time.
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, &
- vertex1, vertex2, eoe, i, j
+ integer :: iEdge, cell1, cell2, eoe, i, j, k
- integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve
- real (kind=RKIND) :: flux, vorticity_abs, h_vertex, workpv, q, &
- upstream_bias, wTopEdge, rho0Inv, r
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel
- real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, uBcl, v, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
- MontPot, wTop, divergence, vertViscTopOfEdge
+ integer :: nEdgesSolve
+ real (kind=RKIND), dimension(:), pointer :: fEdge
+ real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge, u, uBcl
type (dm_info) :: dminfo
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot
- integer, dimension(:,:), pointer :: &
- cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, &
- edgesOnEdge, edgesOnVertex
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), allocatable:: fluxVertTop,w_dudzTopEdge
+ integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
-
- real (kind=RKIND), dimension(:,:), pointer :: u_src
- real (kind=RKIND), parameter :: rho_ref = 1000.0
-
call mpas_timer_start("ocn_fuperp")
- h => s % h % array
u => s % u % array
uBcl => s % uBcl % array
- v => s % v % array
- wTop => s % wTop % array
- h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
- MontPot => s % MontPot % array
- pressure => s % pressure % array
-
weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
+ fEdge => grid % fEdge % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
nEdgesOnEdge => grid % nEdgesOnEdge % array
edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
- maxLevelCell => grid % maxLevelCell % array
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
-
- nCells = grid % nCells
- nEdges = grid % nEdges
+ fEdge => grid % fEdge % array
+
nEdgesSolve = grid % nEdgesSolve
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
!
! Put f*uBcl^{perp} in u as a work variable
!
- do iEdge=1,grid % nEdgesSolve
+ do iEdge=1,nEdgesSolve
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
@@ -1347,7 +1079,70 @@
end subroutine ocn_fuperp!}}}
!***********************************************************************
+!
+! routine ocn_tendency_init
+!
+!> \brief Initializes flags used within tendency routines.
+!> \author Doug Jacobsen
+!> \date 4 November 2011
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes flags related to quantities computed within
+!> other tendency routines.
+!
+!-----------------------------------------------------------------------
+ subroutine ocn_tendency_init(err)!{{{
+ integer, intent(out) :: err !< Output: Error flag
+ err = 0
+
+ coef_3rd_order = 0.
+
+ if (config_thickness_adv_order == 2) then
+ hadv2nd = 1
+ hadv3rd = 0
+ hadv4th = 0
+ else if (config_thickness_adv_order == 3) then
+ hadv2nd = 0
+ hadv3rd = 1
+ hadv4th = 0
+
+ if(config_monotonic) then
+ coef_3rd_order = 0.25
+ else
+ coef_3rd_order = 1.0
+ endif
+ else if (config_thickness_adv_order == 4) then
+ hadv2nd = 0
+ hadv3rd = 0
+ hadv4th = 1
+ end if
+
+
+ if(config_include_KE_vertex) then
+ ke_vertex_flag = 1
+ ke_cell_flag = 0
+ else
+ ke_vertex_flag = 0
+ ke_cell_flag = 1
+ endif
+
+ if (trim(config_time_integration) == 'RK4') then
+ ! for RK4, PV is really PV = (eta+f)/h
+ fCoef = 1
+ elseif (trim(config_time_integration) == 'split_explicit' &
+ .or.trim(config_time_integration) == 'unsplit_explicit') then
+ ! for split explicit, PV is eta/h because f is added separately to the momentum forcing.
+ ! mrp temp, new should be:
+ fCoef = 0
+ ! old, for testing:
+ ! fCoef = 1
+ end if
+
+ end subroutine ocn_tendency_init!}}}
+
+!***********************************************************************
+
end module ocn_tendency
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_thick_hadv.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_thick_hadv.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_thick_hadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -104,10 +104,10 @@
integer :: iEdge, nEdges, cell1, cell2, nVertLevels, k
integer :: iCell, nCells
- integer, dimension(:), pointer :: maxLevelEdgeTop
+ integer, dimension(:), pointer :: maxLevelEdgeBot, MaxLevelCell
integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND) :: flux
+ real (kind=RKIND) :: flux, invAreaCell1, invAreaCell2
real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell
!-----------------------------------------------------------------
@@ -124,46 +124,27 @@
nCells = grid % nCells
nVertLevels = grid % nVertLevels
- maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ maxLevelCell => grid % maxLevelCell % array
+ maxLevelEdgeBot => grid % maxLevelEdgeBot % array
cellsOnEdge => grid % cellsOnEdge % array
dvEdge => grid % dvEdge % array
areaCell => grid % areaCell % array
- if (config_vert_grid_type.eq.'isopycnal') then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,nVertLevels
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- tend(k,cell1) = tend(k,cell1) - flux
- tend(k,cell2) = tend(k,cell2) + flux
- end do
+ do iEdge=1,nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k=1,maxLevelEdgeBot(iEdge)
+ flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
+ tend(k,cell1) = tend(k,cell1) - flux
+ tend(k,cell2) = tend(k,cell2) + flux
end do
- do iCell=1,nCells
- do k=1,nVertLevels
- tend(k,iCell) = tend(k,iCell) / areaCell(iCell)
- end do
+ end do
+ do iCell=1,nCells
+ do k=1,maxLevelCell(iCell)
+ tend(k,iCell) = tend(k,iCell) / areaCell(iCell)
end do
+ end do
- elseif (config_vert_grid_type.eq.'zlevel') then
-
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,min(1,maxLevelEdgeTop(iEdge))
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
- tend(k,cell1) = tend(k,cell1) - flux
- tend(k,cell2) = tend(k,cell2) + flux
- end do
- end do
- do iCell=1,nCells
- tend(1,iCell) = tend(1,iCell) / areaCell(iCell)
- end do
-
- endif ! config_vert_grid_type
-
-
!--------------------------------------------------------------------
end subroutine ocn_thick_hadv_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_thick_vadv.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_thick_vadv.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_thick_vadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -98,7 +98,8 @@
!
!-----------------------------------------------------------------
- integer :: iCell, nCells
+ integer :: iCell, nCells, nVertLevels, k
+ integer, dimension(:), pointer :: MaxLevelCell
!-----------------------------------------------------------------
!
@@ -110,15 +111,17 @@
err = 0
+ maxLevelCell => grid % maxLevelCell % array
+
nCells = grid % nCells
+ nVertLevels = grid % nVertLevels
- if (config_vert_grid_type.eq.'zlevel') then
- do iCell=1,nCells
- tend(1,iCell) = tend(1,iCell) + wTop(2,iCell)
- end do
- endif ! coordinate type
+ do iCell=1,nCells
+ do k=1,maxLevelCell(iCell)
+ tend(k,iCell) = tend(k,iCell) + wTop(k+1,iCell) - wTop(k,iCell)
+ end do
+ end do
-
!--------------------------------------------------------------------
end subroutine ocn_thick_vadv_tend!}}}
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_average.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_time_average.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_average.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_average.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,129 @@
+module ocn_time_average
+
+ use mpas_grid_types
+
+ implicit none
+ save
+ public
+
+ contains
+
+ subroutine ocn_time_average_init(state)!{{{
+ type (state_type), intent(inout) :: state
+
+ real, pointer :: nAccumulate
+
+ real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+
+ nAccumulate => state % nAccumulate % scalar
+
+ acc_ssh => state % acc_ssh % array
+ acc_sshVar => state % acc_sshVar % array
+ acc_uReconstructZonal => state % acc_uReconstructZonal % array
+ acc_uReconstructMeridional => state % acc_uReconstructMeridional % array
+ acc_uReconstructZonalVar => state % acc_uReconstructZonalVar % array
+ acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
+ acc_u => state % acc_u % array
+ acc_uVar => state % acc_uVar % array
+
+ nAccumulate = 0
+
+ acc_ssh = 0.0
+ acc_sshVar = 0.0
+ acc_uReconstructZonal = 0.0
+ acc_uReconstructMeridional = 0.0
+ acc_uReconstructZonalVar = 0.0
+ acc_uReconstructMeridionalVar = 0.0
+ acc_u = 0.0
+ acc_uVar = 0.0
+
+ end subroutine ocn_time_average_init!}}}
+
+ subroutine ocn_time_average_accumulate(state, old_state)!{{{
+ type (state_type), intent(inout) :: state
+ type (state_type), intent(in) :: old_state
+
+ real, pointer :: nAccumulate, old_nAccumulate
+
+ real (kind=RKIND), dimension(:), pointer :: ssh
+ real (kind=RKIND), dimension(:,:), pointer :: uReconstructZonal, uReconstructMeridional, u
+
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
+ real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
+
+ real (kind=RKIND), dimension(:,:), pointer :: old_acc_u, old_acc_uVar
+ real (kind=RKIND), dimension(:,:), pointer :: old_acc_uReconstructZonal, old_acc_uReconstructMeridional, old_acc_uReconstructZonalVar, old_acc_uReconstructMeridionalVar
+ real (kind=RKIND), dimension(:), pointer :: old_acc_ssh, old_acc_sshVar
+
+ old_nAccumulate => old_state % nAccumulate % scalar
+ nAccumulate => state % nAccumulate % scalar
+
+ ssh => state % ssh % array
+ uReconstructZonal => state % uReconstructZonal % array
+ uReconstructMeridional => state % uReconstructMeridional % array
+ u => state % u % array
+
+ acc_ssh => state % acc_ssh % array
+ acc_sshVar => state % acc_sshVar % array
+ acc_uReconstructZonal => state % acc_uReconstructZonal % array
+ acc_uReconstructMeridional => state % acc_uReconstructMeridional % array
+ acc_uReconstructZonalVar => state % acc_uReconstructZonalVar % array
+ acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
+ acc_u => state % acc_u % array
+ acc_uVar => state % acc_uVar % array
+
+ old_acc_ssh => old_state % acc_ssh % array
+ old_acc_sshVar => old_state % acc_sshVar % array
+ old_acc_uReconstructZonal => old_state % acc_uReconstructZonal % array
+ old_acc_uReconstructMeridional => old_state % acc_uReconstructMeridional % array
+ old_acc_uReconstructZonalVar => old_state % acc_uReconstructZonalVar % array
+ old_acc_uReconstructMeridionalVar => old_state % acc_uReconstructMeridionalVar % array
+ old_acc_u => old_state % acc_u % array
+ old_acc_uVar => old_state % acc_uVar % array
+
+ acc_ssh = old_acc_ssh + ssh
+ acc_sshVar = old_acc_sshVar + ssh**2
+ acc_uReconstructZonal = old_acc_uReconstructZonal + uReconstructZonal
+ acc_uReconstructMeridional = old_acc_uReconstructMeridional + uReconstructMeridional
+ acc_uReconstructZonalVar = old_acc_uReconstructZonalVar + uReconstructZonal**2
+ acc_uReconstructMeridionalVar = old_acc_uReconstructMeridionalVar + uReconstructMeridional**2
+ acc_u = old_acc_u + u
+ acc_uVar = old_acc_uVar + u**2
+
+ nAccumulate = old_nAccumulate + 1
+ end subroutine ocn_time_average_accumulate!}}}
+
+ subroutine ocn_time_average_normalize(state)!{{{
+ type (state_type), intent(inout) :: state
+
+ real, pointer :: nAccumulate
+
+ real (kind=RKIND), dimension(:), pointer :: acc_ssh, acc_sshVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_uReconstructZonal, acc_uReconstructMeridional, acc_uReconstructZonalVar, acc_uReconstructMeridionalVar
+ real (kind=RKIND), dimension(:,:), pointer :: acc_u, acc_uVar
+
+ nAccumulate => state % nAccumulate % scalar
+
+ acc_ssh => state % acc_ssh % array
+ acc_sshVar => state % acc_sshVar % array
+ acc_uReconstructZonal => state % acc_uReconstructZonal % array
+ acc_uReconstructMeridional => state % acc_uReconstructMeridional % array
+ acc_uReconstructZonalVar => state % acc_uReconstructZonalVar % array
+ acc_uReconstructMeridionalVar => state % acc_uReconstructMeridionalVar % array
+ acc_u => state % acc_u % array
+ acc_uVar => state % acc_uVar % array
+
+ acc_ssh = acc_ssh / nAccumulate
+ acc_sshVar = acc_sshVar / nAccumulate
+ acc_uReconstructZonal = acc_uReconstructZonal / nAccumulate
+ acc_uReconstructMeridional = acc_uReconstructMeridional / nAccumulate
+ acc_uReconstructZonalVar = acc_uReconstructZonalVar / nAccumulate
+ acc_uReconstructMeridionalVar = acc_uReconstructMeridionalVar / nAccumulate
+ acc_u = acc_u / nAccumulate
+ acc_uVar = acc_uVar / nAccumulate
+ end subroutine ocn_time_average_normalize!}}}
+
+end module ocn_time_average
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_integration_rk4.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_integration_rk4.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_integration_rk4.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -24,7 +24,8 @@
use ocn_tendency
use ocn_equation_of_state
- use ocn_Vmix
+ use ocn_vmix
+ use ocn_time_average
implicit none
private
@@ -143,7 +144,7 @@
call mpas_timer_start("RK4-diagnostic halo update")
block => domain % blocklist
do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % pv_edge % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % Vor_edge % array(:,:), &
block % mesh % nVertLevels, block % mesh % nEdges, &
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
@@ -165,10 +166,14 @@
call mpas_timer_start("RK4-tendency computations")
block => domain % blocklist
do while (associated(block))
+
+ ! mrp 111206 put ocn_wtop call at top for ALE
+ call ocn_wtop(provis, provis, block % mesh)
+
if (.not.config_implicit_vertical_mix) then
call ocn_vmix_coefs(block % mesh, provis, block % diagnostics, err)
end if
- call ocn_tend_h(block % tend, provis, block % diagnostics, block % mesh)
+ call ocn_tend_h(block % tend, provis, block % mesh)
call ocn_tend_u(block % tend, provis, block % diagnostics, block % mesh)
! mrp 110718 filter btr mode out of u_tend
@@ -177,8 +182,7 @@
call filter_btr_mode_tend_u(block % tend, provis, block % diagnostics, block % mesh)
endif
- call ocn_tend_scalar(block % tend, provis, block % diagnostics, block % mesh)
- call enforce_boundaryEdge(block % tend, block % mesh)
+ call ocn_tend_scalar(block % tend, provis, block % diagnostics, block % mesh, dt)
block => block % next
end do
call mpas_timer_stop("RK4-tendency computations")
@@ -227,6 +231,14 @@
provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
+ if (config_prescribe_velocity) then
+ provis % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
+ end if
+
+ if (config_prescribe_thickness) then
+ provis % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
+ end if
+
call ocn_diagnostic_solve(dt, provis, block % mesh)
block => block % next
@@ -295,8 +307,6 @@
if (config_implicit_vertical_mix) then
call mpas_timer_start("RK4-implicit vert mix")
- allocate(A(nVertLevels),C(nVertLevels),uTemp(nVertLevels), &
- tracersTemp(num_tracers,nVertLevels))
call ocn_vmix_coefs(block % mesh, block % state % time_levs(2) % state, block % diagnostics, err)
@@ -316,35 +326,21 @@
!
call ocn_tracer_vmix_tend_implicit(block % mesh, dt, vertdifftopofcell, h, tracers, err)
+ call mpas_timer_stop("RK4-implicit vert mix")
end if
- ! mrp 110725 momentum decay term
- if (config_mom_decay) then
- call mpas_timer_start("RK4-momentum decay")
-
- !
- ! Implicit solve for momentum decay
- !
- ! Add term to RHS of momentum equation: -1/gamma u
- !
- ! This changes the solve to:
- ! u^{n+1} = u_provis^{n+1}/(1+dt/gamma)
- !
- coef = 1.0/(1.0 + dt/config_mom_decay_time)
- do iEdge=1,block % mesh % nEdges
- do k=1,maxLevelEdgeTop(iEdge)
- u(k,iEdge) = coef*u(k,iEdge)
- end do
- end do
-
- call mpas_timer_stop("RK4-momentum decay")
+ if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
-
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ if (config_prescribe_velocity) then
block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
+ if (config_prescribe_thickness) then
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
+ end if
+
call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
@@ -355,6 +351,8 @@
block % state % time_levs(2) % state % uReconstructMeridional % array &
)
+ call ocn_time_average_accumulate(block % state % time_levs(2) % state, block % state % time_levs(1) % state)
+
block => block % next
end do
call mpas_timer_stop("RK4-cleaup phase")
@@ -388,11 +386,11 @@
integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve
real (kind=RKIND) :: vertSum, uhSum, hSum, sshEdge
real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel, meshScalingDel2, meshScalingDel4
+ h_s, dvEdge, dcEdge, areaCell, areaTriangle, &
+ meshScalingDel2, meshScalingDel4
real (kind=RKIND), dimension(:,:), pointer :: &
weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
+ tend_u, circulation, vorticity, ke, ke_edge, Vor_edge, &
MontPot, wTop, divergence, vertViscTopOfEdge
type (dm_info) :: dminfo
@@ -424,7 +422,7 @@
divergence => s % divergence % array
ke => s % ke % array
ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
+ Vor_edge => s % Vor_edge % array
MontPot => s % MontPot % array
pressure => s % pressure % array
vertViscTopOfEdge => d % vertViscTopOfEdge % array
@@ -444,11 +442,6 @@
areaCell => grid % areaCell % array
areaTriangle => grid % areaTriangle % array
h_s => grid % h_s % array
-! mrp 110516 cleanup fvertex fedge not used in this subroutine
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
maxLevelCell => grid % maxLevelCell % array
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
maxLevelVertexBot => grid % maxLevelVertexBot % array
@@ -465,15 +458,12 @@
do iEdge=1,grid % nEdges
- ! I am using hZLevel here. This assumes that SSH is zero everywhere already,
- ! which should be the case if the barotropic mode is filtered.
- ! The more general case is to use sshEdge or h_edge.
- uhSum = (grid % hZLevel % array(1)) * tend_u(1,iEdge)
- hSum = grid % hZLevel % array(1)
+ uhSum = (h_edge(1,iEdge)) * tend_u(1,iEdge)
+ hSum = h_edge(1,iEdge)
do k=2,grid % maxLevelEdgeTop % array(iEdge)
- uhSum = uhSum + grid % hZLevel % array(k) * tend_u(k,iEdge)
- hSum = hSum + grid % hZLevel % array(k)
+ uhSum = uhSum + h_edge(k,iEdge) * tend_u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
enddo
vertSum = uhSum/hSum
@@ -511,11 +501,11 @@
integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve
real (kind=RKIND) :: vertSum, uhSum, hSum, sshEdge
real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel, meshScalingDel2, meshScalingDel4
+ h_s, dvEdge, dcEdge, areaCell, areaTriangle, &
+ meshScalingDel2, meshScalingDel4
real (kind=RKIND), dimension(:,:), pointer :: &
weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
+ tend_u, circulation, vorticity, ke, ke_edge, Vor_edge, &
MontPot, wTop, divergence, vertViscTopOfEdge
type (dm_info) :: dminfo
@@ -547,7 +537,7 @@
divergence => s % divergence % array
ke => s % ke % array
ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
+ Vor_edge => s % Vor_edge % array
MontPot => s % MontPot % array
pressure => s % pressure % array
@@ -566,11 +556,6 @@
areaCell => grid % areaCell % array
areaTriangle => grid % areaTriangle % array
h_s => grid % h_s % array
-! mrp 110516 cleanup fvertex fedge not used in this subroutine
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
maxLevelCell => grid % maxLevelCell % array
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
maxLevelVertexBot => grid % maxLevelVertexBot % array
@@ -585,15 +570,12 @@
do iEdge=1,grid % nEdges
- ! I am using hZLevel here. This assumes that SSH is zero everywhere already,
- ! which should be the case if the barotropic mode is filtered.
- ! The more general case is to use sshedge or h_edge.
- uhSum = (grid % hZLevel % array(1)) * u(1,iEdge)
- hSum = grid % hZLevel % array(1)
+ uhSum = (h_edge(1,iEdge)) * u(1,iEdge)
+ hSum = h_edge(1,iEdge)
do k=2,grid % maxLevelEdgeTop % array(iEdge)
- uhSum = uhSum + grid % hZLevel % array(k) * u(k,iEdge)
- hSum = hSum + grid % hZLevel % array(k)
+ uhSum = uhSum + h_edge(k,iEdge) * u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
enddo
vertSum = uhSum/hSum
@@ -607,51 +589,6 @@
end subroutine filter_btr_mode_u!}}}
- subroutine enforce_boundaryEdge(tend, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Enforce any boundary conditions on the normal velocity at each edge
- !
- ! Input: grid - grid metadata
- !
- ! Output: tend_u set to zero at boundaryEdge == 1 locations
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (mesh_type), intent(in) :: grid
-
- integer, dimension(:,:), pointer :: boundaryEdge
- real (kind=RKIND), dimension(:,:), pointer :: tend_u
- integer :: nCells, nEdges, nVertices, nVertLevels
- integer :: iEdge, k
-
- call mpas_timer_start("enforce_boundaryEdge")
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- boundaryEdge => grid % boundaryEdge % array
- tend_u => tend % u % array
-
- if(maxval(boundaryEdge).le.0) return
-
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
-
- if(boundaryEdge(k,iEdge).eq.1) then
- tend_u(k,iEdge) = 0.0
- endif
-
- enddo
- enddo
- call mpas_timer_stop("enforce_boundaryEdge")
-
- end subroutine enforce_boundaryEdge!}}}
-
end module ocn_time_integration_rk4
! vim: foldmethod=marker
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_integration_split.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_integration_split.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_time_integration_split.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -27,8 +27,8 @@
use ocn_equation_of_state
use ocn_vmix
+ use ocn_time_average
-
implicit none
private
save
@@ -47,6 +47,10 @@
public :: ocn_time_integrator_split
+ type (timer_node), pointer :: timer_main, timer_prep, timer_bcl_vel, timer_btr_vel, timer_diagnostic_update, timer_implicit_vmix, &
+ timer_halo_diagnostic, timer_halo_ubtr, timer_halo_ssh, timer_halo_f, timer_halo_h, &
+ timer_halo_tracers, timer_halo_ubcl
+
contains
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
@@ -54,7 +58,7 @@
! ocn_time_integration_split
!
!> \brief MPAS ocean split explicit time integration scheme
-!> \author Doug Jacobsen
+!> \author Mark Petersen
!> \date 26 September 2011
!> \version SVN:$Id:$
!> \details
@@ -63,16 +67,16 @@
!
!-----------------------------------------------------------------------
-subroutine ocn_time_integrator_split(domain, dt)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Advance model state forward in time by the specified time step using
- ! Split_Explicit timestepping scheme
- !
- ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
- ! plus grid meta-data
- ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
- ! model state advanced forward in time by dt seconds
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ subroutine ocn_time_integrator_split(domain, dt)!{{{
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Advance model state forward in time by the specified time step using
+ ! Split_Explicit timestepping scheme
+ !
+ ! Input: domain - current model state in time level 1 (e.g., time_levs(1)state%h(:,:))
+ ! plus grid meta-data
+ ! Output: domain - upon exit, time level 2 (e.g., time_levs(2)%state%h(:,:)) contains
+ ! model state advanced forward in time by dt seconds
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
implicit none
@@ -81,72 +85,73 @@
type (dm_info) :: dminfo
integer :: iCell, i,k,j, iEdge, cell1, cell2, split_explicit_step, split, &
- eoe, oldBtrSubcycleTime, newBtrSubcycleTime, uPerpTime, BtrCorIter, &
- n_bcl_iter(config_n_ts_iter), &
- vertex1, vertex2, iVertex
-
+ eoe, oldBtrSubcycleTime, newBtrSubcycleTime, uPerpTime, BtrCorIter, &
+ n_bcl_iter(config_n_ts_iter)
type (block_type), pointer :: block
- real (kind=RKIND) :: uhSum, hSum, sshEdge, flux, &
- uPerp, uCorr, tracerTemp, coef, FBtr_coeff, sshCell1, sshCell2
- real (kind=RKIND), dimension(:), pointer :: sshNew
-
+ real (kind=RKIND) :: uhSum, hSum, flux, sshEdge, &
+ CoriolisTerm, uCorr, temp, temp_h, coef, FBtr_coeff, sshCell1, sshCell2
integer :: num_tracers, ucorr_coef, err
real (kind=RKIND), dimension(:,:), pointer :: &
- u, h, h_edge, ke_edge, vertViscTopOfEdge, vertDiffTopOfCell
+ u, h, h_edge, ke_edge, vertViscTopOfEdge, vertDiffTopOfCell
real (kind=RKIND), dimension(:,:,:), pointer :: tracers
integer, dimension(:), pointer :: &
- maxLevelCell, maxLevelEdgeTop
- real (kind=RKIND), dimension(:), allocatable:: A,C,uTemp, hNew
+ maxLevelCell, maxLevelEdgeTop
+ real (kind=RKIND), dimension(:), allocatable:: uTemp
real (kind=RKIND), dimension(:,:), allocatable:: tracersTemp
- call mpas_timer_start("split_explicit_timestep")
+ call mpas_timer_start("se timestep", .false., timer_main)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! Prep variables before first iteration
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ call mpas_timer_start("se prep", .false., timer_prep)
block => domain % blocklist
do while (associated(block))
+ ! Initialize * variables that are used to compute baroclinic tendencies below.
do iEdge=1,block % mesh % nEdges
+ do k=1,block % mesh % nVertLevels !maxLevelEdgeTop % array(iEdge)
- ! The baroclinic velocity needs be recomputed at the beginning of a
- ! timestep because the implicit vertical mixing is conducted on the
- ! total u. We keep uBtr from the previous timestep.
- block % state % time_levs(1) % state % uBcl % array(:,iEdge) &
- = block % state % time_levs(1) % state % u % array(:,iEdge) &
- - block % state % time_levs(1) % state % uBtr % array(iEdge)
+ ! The baroclinic velocity needs be recomputed at the beginning of a
+ ! timestep because the implicit vertical mixing is conducted on the
+ ! total u. We keep uBtr from the previous timestep.
+ block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
+ = block % state % time_levs(1) % state % u % array(k,iEdge) &
+ - block % state % time_levs(1) % state % uBtr % array( iEdge)
- block % state % time_levs(2) % state % u % array(:,iEdge) &
- = block % state % time_levs(1) % state % u % array(:,iEdge)
+ block % state % time_levs(2) % state % u % array(k,iEdge) &
+ = block % state % time_levs(1) % state % u % array(k,iEdge)
- block % state % time_levs(2) % state % uBcl % array(:,iEdge) &
- = block % state % time_levs(1) % state % uBcl % array(:,iEdge)
+ block % state % time_levs(2) % state % uBcl % array(k,iEdge) &
+ = block % state % time_levs(1) % state % uBcl % array(k,iEdge)
- enddo ! iEdge
+ block % state % time_levs(2) % state % h_edge % array(k,iEdge) &
+ = block % state % time_levs(1) % state % h_edge % array(k,iEdge)
- ! Initialize * variables that are used compute baroclinic tendencies below.
+ end do
+ end do
+
block % state % time_levs(2) % state % ssh % array(:) &
= block % state % time_levs(1) % state % ssh % array(:)
- block % state % time_levs(2) % state % h_edge % array(:,:) &
- = block % state % time_levs(1) % state % h_edge % array(:,:)
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % maxLevelCell % array(iCell)
- do iCell=1,block % mesh % nCells ! couple tracers to h
- ! change to maxLevelCell % array(iCell) ?
- do k=1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % h % array(k,iCell) &
+ = block % state % time_levs(1) % state % h % array(k,iCell)
- block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
- = block % state % time_levs(1) % state % tracers % array(:,k,iCell)
- end do
+ block % state % time_levs(2) % state % tracers % array(:,k,iCell) &
+ = block % state % time_levs(1) % state % tracers % array(:,k,iCell)
+ end do
end do
block => block % next
end do
-
+ call mpas_timer_stop("se prep", timer_prep)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BEGIN large iteration loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -155,671 +160,484 @@
n_bcl_iter(config_n_ts_iter) = config_n_bcl_iter_end
do split_explicit_step = 1, config_n_ts_iter
-! --- update halos for diagnostic variables
+ ! --- update halos for diagnostic variables
- block => domain % blocklist
- do while (associated(block))
-
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % pv_edge % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nVertices, &
- block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
- end if
-
- block => block % next
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Stage 1: Baroclinic velocity (3D) prediction, explicit with long timestep
- !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! compute velocity tendencies, T(u*,w*,p*)
-
- block => domain % blocklist
- do while (associated(block))
- if (.not.config_implicit_vertical_mix) then
- call ocn_vmix_coefs(block % mesh, block % state % time_levs(2) % state, block % diagnostics, err)
- end if
- call ocn_tend_u(block % tend, block % state % time_levs(2) % state , block % diagnostics, block % mesh)
- call enforce_boundaryEdge(block % tend, block % mesh)
- block => block % next
- end do
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN baroclinic iterations on linear Coriolis term
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do j=1,n_bcl_iter(split_explicit_step)
-
- ! Use this G coefficient to avoid an if statement within the iEdge loop.
- if (trim(config_time_integration) == 'unsplit_explicit') then
- split = 0
- elseif (trim(config_time_integration) == 'split_explicit') then
- split = 1
- endif
-
+ call mpas_timer_start("se halo diag", .false., timer_halo_diagnostic)
block => domain % blocklist
do while (associated(block))
- allocate(uTemp(block % mesh % nVertLevels))
- ! Put f*uBcl^{perp} in uNew as a work variable
- call ocn_fuperp(block % state % time_levs(2) % state , block % mesh)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
+ block % state % time_levs(2) % state % Vor_edge % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- do iEdge=1,block % mesh % nEdges
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+ if (config_h_mom_eddy_visc4 > 0.0) then
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
+ block % state % time_levs(2) % state % divergence % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
+ block % state % time_levs(2) % state % vorticity % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nVertices, &
+ block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
+ end if
- uTemp = 0.0 ! could put this after with uTemp(maxleveledgetop+1:nvertlevels)=0
- do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
-
- ! uBclNew = uBclOld + dt*(-f*uBclPerp + T(u*,w*,p*) + g*grad(SSH*) )
- ! Here uNew is a work variable containing -fEdge(iEdge)*uBclPerp(k,iEdge)
- uTemp(k) &
- = block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
- + dt * (block % tend % u % array (k,iEdge) &
- + block % state % time_levs(2) % state % u % array (k,iEdge) & ! this is f*uBcl^{perp}
- + split*gravity &
- *( block % state % time_levs(2) % state % ssh % array(cell2) &
- - block % state % time_levs(2) % state % ssh % array(cell1) ) &
- /block % mesh % dcEdge % array(iEdge) )
- enddo
-
- ! Compute GBtrForcing, the vertically averaged forcing
- sshEdge = 0.5*( &
- block % state % time_levs(1) % state % ssh % array(cell1) &
- + block % state % time_levs(1) % state % ssh % array(cell2) )
-
- uhSum = (sshEdge + block % mesh % hZLevel % array(1)) * uTemp(1)
- hSum = sshEdge + block % mesh % hZLevel % array(1)
-
- do k=2,block % mesh % maxLevelEdgeTop % array(iEdge)
- uhSum = uhSum + block % mesh % hZLevel % array(k) * uTemp(k)
- hSum = hSum + block % mesh % hZLevel % array(k)
- enddo
- block % state % time_levs(1) % state % GBtrForcing % array(iEdge) = split*uhSum/hSum/dt
-
-
- do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
- ! These two steps are together here:
- !{\bf u}'_{k,n+1} = {\bf u}'_{k,n} - \Delta t {\overline {\bf G}}
- !{\bf u}'_{k,n+1/2} = \frac{1}{2}\left({\bf u}^{'}_{k,n} +{\bf u}'_{k,n+1}\right)
- ! so that uBclNew is at time n+1/2
- block % state % time_levs(2) % state % uBcl % array(k,iEdge) &
- = 0.5*( &
- block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
- + uTemp(k) - dt * block % state % time_levs(1) % state % GBtrForcing % array(iEdge))
- enddo
-
- enddo ! iEdge
-
- deallocate(uTemp)
-
- block => block % next
+ block => block % next
end do
+ call mpas_timer_stop("se halo diag", timer_halo_diagnostic)
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % uBcl % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Stage 1: Baroclinic velocity (3D) prediction, explicit with long timestep
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- block => block % next
- end do
+ ! compute velocity tendencies, T(u*,w*,p*)
+ call mpas_timer_start("se bcl vel", .false., timer_bcl_vel)
- enddo ! do j=1,config_n_bcl_iter
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! END baroclinic iterations on linear Coriolis term
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Stage 2: Barotropic velocity (2D) prediction, explicitly subcycled
- !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- oldBtrSubcycleTime = 1
- newBtrSubcycleTime = 2
-
- if (trim(config_time_integration) == 'unsplit_explicit') then
-
block => domain % blocklist
do while (associated(block))
-
- ! For Split_Explicit unsplit, simply set uBtrNew=0, uBtrSubcycle=0, and uNew=uBclNew
- block % state % time_levs(2) % state % uBtr % array(:) = 0.0
-
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:) = 0.0
-
- block % state % time_levs(2) % state % u % array(:,:) &
- = block % state % time_levs(2) % state % uBcl % array(:,:)
-
+ if (.not.config_implicit_vertical_mix) then
+ call ocn_vmix_coefs(block % mesh, block % state % time_levs(2) % state, block % diagnostics, err)
+ end if
+ call ocn_tend_u(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh)
block => block % next
- end do ! block
+ end do
- elseif (trim(config_time_integration) == 'split_explicit') then
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! BEGIN baroclinic iterations on linear Coriolis term
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do j=1,n_bcl_iter(split_explicit_step)
- ! Initialize variables for barotropic subcycling
- block => domain % blocklist
- do while (associated(block))
+ ! Use this G coefficient to avoid an if statement within the iEdge loop.
+ if (trim(config_time_integration) == 'unsplit_explicit') then
+ split = 0
+ elseif (trim(config_time_integration) == 'split_explicit') then
+ split = 1
+ endif
- if (config_filter_btr_mode) then
- block % state % time_levs(1) % state % GBtrForcing % array(:) = 0.0
- endif
-
- do iCell=1,block % mesh % nCells
- ! sshSubcycleOld = sshOld
- block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
- = block % state % time_levs(1) % state % ssh % array(iCell)
-
- ! sshNew = sshOld This is the first for the summation
- block % state % time_levs(2) % state % ssh % array(iCell) &
- = block % state % time_levs(1) % state % ssh % array(iCell)
- enddo
-
- do iEdge=1,block % mesh % nEdges
-
- ! uBtrSubcycleOld = uBtrOld
- block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- = block % state % time_levs(1) % state % uBtr % array(iEdge)
-
- ! uBtrNew = BtrOld This is the first for the summation
- block % state % time_levs(2) % state % uBtr % array(iEdge) &
- = block % state % time_levs(1) % state % uBtr % array(iEdge)
-
- ! FBtr = 0
- block % state % time_levs(1) % state % FBtr % array(iEdge) = 0.0
- enddo
-
- block => block % next
- end do ! block
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! BEGIN Barotropic subcycle loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do j=1,config_n_btr_subcycles*config_btr_subcycle_loop_factor
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Barotropic subcycle: initial solve for velecity
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- if (config_btr_gam1_uWt1>1.0e-12) then ! only do this part if it is needed in next SSH solve
- uPerpTime = oldBtrSubcycleTime
-
block => domain % blocklist
do while (associated(block))
+ allocate(uTemp(block % mesh % nVertLevels))
- do iEdge=1,block % mesh % nEdges
+ ! Put f*uBcl^{perp} in uNew as a work variable
+ call ocn_fuperp(block % state % time_levs(2) % state , block % mesh)
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+ do iEdge=1,block % mesh % nEdges
+ cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
- ! Compute -f*uPerp
- uPerp = 0.0
- do i = 1,block % mesh % nEdgesOnEdge % array(iEdge)
- eoe = block % mesh % edgesOnEdge % array(i,iEdge)
- uPerp = uPerp + block % mesh % weightsOnEdge % array(i,iEdge) &
- * block % state % time_levs(uPerpTime) % state % uBtrSubcycle % array(eoe) &
- * block % mesh % fEdge % array(eoe)
- end do
+ uTemp = 0.0 ! could put this after with uTemp(maxleveledgetop+1:nvertlevels)=0
+ do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
- ! mrp 110606 efficiency note: could make this a 1D integer factor instead of an if statement.
- if (block % mesh % boundaryEdge % array(1,iEdge).eq.1) then
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) = 0.0
- else
+ ! uBclNew = uBclOld + dt*(-f*uBclPerp + T(u*,w*,p*) + g*grad(SSH*) )
+ ! Here uNew is a work variable containing -fEdge(iEdge)*uBclPerp(k,iEdge)
+ uTemp(k) = block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
+ + dt * (block % tend % u % array (k,iEdge) &
+ + block % state % time_levs(2) % state % u % array (k,iEdge) & ! this is f*uBcl^{perp}
+ + split * gravity * ( block % state % time_levs(2) % state % ssh % array(cell2) &
+ - block % state % time_levs(2) % state % ssh % array(cell1) ) &
+ /block % mesh % dcEdge % array(iEdge) )
+ enddo
- ! uBtrNew = uBtrOld + dt*(-f*uBtroldPerp - g*grad(SSH) + G)
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- = block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- + dt/config_n_btr_subcycles *( &
- uPerp &
- - gravity &
- *( block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
- - block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) ) &
- /block % mesh % dcEdge % array(iEdge) &
- + block % state % time_levs(1) % state % GBtrForcing % array(iEdge) )
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = block % state % time_levs(2) % state % h_edge % array(1,iEdge) * uTemp(1)
+ hSum = block % state % time_levs(2) % state % h_edge % array(1,iEdge)
- endif
+ do k=2,block % mesh % maxLevelEdgeTop % array(iEdge)
+ uhSum = uhSum + block % state % time_levs(2) % state % h_edge % array(k,iEdge) * uTemp(k)
+ hSum = hSum + block % state % time_levs(2) % state % h_edge % array(k,iEdge)
+ enddo
+ block % state % time_levs(1) % state % GBtrForcing % array(iEdge) = split*uhSum/hSum/dt
- end do
- ! Implicit solve for barotropic momentum decay
- if ( config_btr_mom_decay) then
- !
- ! Add term to RHS of momentum equation: -1/gamma u
- !
- ! This changes the solve to:
- ! u^{n+1} = u_provis^{n+1}/(1+dt/gamma)
- !
- coef = 1.0/(1.0 + dt/config_n_btr_subcycles/config_btr_mom_decay_time)
- do iEdge=1,block % mesh % nEdges
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- = block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- * coef
- end do
+ do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
+ ! These two steps are together here:
+ !{\bf u}'_{k,n+1} = {\bf u}'_{k,n} - \Delta t {\overline {\bf G}}
+ !{\bf u}'_{k,n+1/2} = \frac{1}{2}\left({\bf u}^{'}_{k,n} +{\bf u}'_{k,n+1}\right)
+ ! so that uBclNew is at time n+1/2
+ block % state % time_levs(2) % state % uBcl % array(k,iEdge) &
+ = 0.5*( &
+ block % state % time_levs(1) % state % uBcl % array(k,iEdge) &
+ + uTemp(k) - dt * block % state % time_levs(1) % state % GBtrForcing % array(iEdge))
+ enddo
+
+ enddo ! iEdge
- endif
+ deallocate(uTemp)
-
block => block % next
- end do ! block
+ end do
-
- ! boundary update on uBtrNew
+ call mpas_timer_start("se halo ubcl", .false., timer_halo_ubcl)
block => domain % blocklist
do while (associated(block))
-
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
- block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, &
+ block % state % time_levs(2) % state % uBcl % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nEdges, &
+ block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+
block => block % next
- end do ! block
+ end do
+ call mpas_timer_stop("se halo ubcl", timer_halo_ubcl)
- endif ! config_btr_gam1_uWt1>1.0e-12
+ end do ! do j=1,config_n_bcl_iter
+ call mpas_timer_stop("se bcl vel", timer_bcl_vel)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! END baroclinic iterations on linear Coriolis term
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Barotropic subcycle: Compute thickness flux and new SSH: PREDICTOR
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- block => domain % blocklist
- do while (associated(block))
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Stage 2: Barotropic velocity (2D) prediction, explicitly subcycled
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- block % tend % ssh % array(:) = 0.0
+ call mpas_timer_start("se btr vel", .false., timer_btr_vel)
- if (config_btr_solve_SSH2) then
- ! If config_btr_solve_SSH2=.true., then do NOT accumulate FBtr in this SSH predictor
- ! section, because it will be accumulated in the SSH corrector section.
- FBtr_coeff = 0.0
- else
- ! otherwise, DO accumulate FBtr in this SSH predictor section
- FBtr_coeff = 1.0
- endif
+ oldBtrSubcycleTime = 1
+ newBtrSubcycleTime = 2
- ! config_btr_gam1_uWt1 sets the forward weighting of velocity in the SSH computation
- ! config_btr_gam1_uWt1= 1 flux = uBtrNew*H
- ! config_btr_gam1_uWt1=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
- ! config_btr_gam1_uWt1= 0 flux = uBtrOld*H
- do iEdge=1,block % mesh % nEdges
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+ if (trim(config_time_integration) == 'unsplit_explicit') then
- sshEdge = 0.5 &
- *( block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
- + block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) )
- hSum = sum(block % mesh % hZLevel % array (1:block % mesh % maxLevelEdgeTop % array(iEdge)))
-
- flux = ((1.0-config_btr_gam1_uWt1) &
- * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- + config_btr_gam1_uWt1 &
- * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
- * (sshEdge + hSum)
-
- block % tend % ssh % array(cell1) = block % tend % ssh % array(cell1) &
- - flux * block % mesh % dvEdge % array(iEdge)
- block % tend % ssh % array(cell2) = block % tend % ssh % array(cell2) &
- + flux * block % mesh % dvEdge % array(iEdge)
-
- block % state % time_levs(1) % state % FBtr % array(iEdge) &
- = block % state % time_levs(1) % state % FBtr % array(iEdge) &
- + FBtr_coeff*flux
- end do
-
- ! SSHnew = SSHold + dt/J*(-div(Flux))
- do iCell=1,block % mesh % nCells
-
- block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
- = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
- + dt/config_n_btr_subcycles &
- * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell)
-
- end do
-
- block => block % next
- end do ! block
-
- ! boundary update on SSHnew
block => domain % blocklist
do while (associated(block))
-! block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
+ ! For Split_Explicit unsplit, simply set uBtrNew=0, uBtrSubcycle=0, and uNew=uBclNew
+ block % state % time_levs(2) % state % uBtr % array(:) = 0.0
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(2) % state % uBcl % array(:,:)
block => block % next
end do ! block
+ elseif (trim(config_time_integration) == 'split_explicit') then
-! mrp 110801 begin
-! This whole section, bounded by 'mrp 110801', may be deleted later if it is found
-! that barotropic del2 is not useful.
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Barotropic subcycle: compute btr_divergence and btr_vorticity for del2(u_btr)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Initialize variables for barotropic subcycling
block => domain % blocklist
do while (associated(block))
- block % state % time_levs(1) % state % u_diffusionBtr % array(:) = 0.0
- if ( config_btr_mom_eddy_visc2 > 0.0 ) then
- !
- ! Compute circulation and relative vorticity at each vertex
- !
- block % state % time_levs(1) % state % circulationBtr % array(:) = 0.0
- do iEdge=1,block % mesh % nEdges
- vertex1 = block % mesh % verticesOnEdge % array(1,iEdge)
- vertex2 = block % mesh % verticesOnEdge % array(2,iEdge)
- block % state % time_levs(1) % state % circulationBtr % array(vertex1) &
- = block % state % time_levs(1) % state % circulationBtr % array(vertex1) &
- - block % mesh % dcEdge % array (iEdge) &
- *block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)
- block % state % time_levs(1) % state % circulationBtr % array(vertex2) &
- = block % state % time_levs(1) % state % circulationBtr % array(vertex2) &
- + block % mesh % dcEdge % array (iEdge) &
- *block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)
- end do
- do iVertex=1,block % mesh % nVertices
- block % state % time_levs(1) % state % vorticityBtr % array(iVertex) &
- = block % state % time_levs(1) % state % circulationBtr % array(iVertex) / block % mesh % areaTriangle % array (iVertex)
- end do
+ if (config_filter_btr_mode) then
+ block % state % time_levs(1) % state % GBtrForcing % array(:) = 0.0
+ endif
- !
- ! Compute the divergence at each cell center
- !
- block % state % time_levs(1) % state % divergenceBtr % array(:) = 0.0
- do iEdge=1,block % mesh % nEdges
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
- block % state % time_levs(1) % state % divergenceBtr % array (cell1) &
- = block % state % time_levs(1) % state % divergenceBtr % array (cell1) &
- + block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- *block % mesh % dvEdge % array(iEdge)
+ do iCell=1,block % mesh % nCells
+ ! sshSubcycleOld = sshOld
+ block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
+ = block % state % time_levs(1) % state % ssh % array(iCell)
+ end do
- block % state % time_levs(1) % state % divergenceBtr % array (cell2) &
- = block % state % time_levs(1) % state % divergenceBtr % array (cell2) &
- - block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- *block % mesh % dvEdge % array(iEdge)
- end do
- do iCell = 1,block % mesh % nCells
- block % state % time_levs(1) % state % divergenceBtr % array(iCell) &
- = block % state % time_levs(1) % state % divergenceBtr % array(iCell) &
- /block % mesh % areaCell % array(iCell)
- enddo
+ do iEdge=1,block % mesh % nEdges
- !
- ! Compute Btr diffusion
- !
- do iEdge=1,block % mesh % nEdgesSolve
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
- vertex1 = block % mesh % verticesOnEdge % array(1,iEdge)
- vertex2 = block % mesh % verticesOnEdge % array(2,iEdge)
+ ! uBtrSubcycleOld = uBtrOld
+ block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ = block % state % time_levs(1) % state % uBtr % array(iEdge)
- ! Here -( vorticityBtr(vertex2) - vorticityBtr(vertex1) ) / dvEdge % array (iEdge)
- ! is - </font>
<font color="red">abla vorticity pointing from vertex 2 to vertex 1, or equivalently
- ! + k \times </font>
<font color="gray">abla vorticity pointing from cell1 to cell2.
+ ! uBtrNew = BtrOld This is the first for the summation
+ block % state % time_levs(2) % state % uBtr % array(iEdge) &
+ = block % state % time_levs(1) % state % uBtr % array(iEdge)
- block % state % time_levs(1) % state % u_diffusionBtr % array(iEdge) = block % mesh % meshScalingDel2 % array (iEdge) * config_btr_mom_eddy_visc2 * &
- (( block % state % time_levs(1) % state % divergenceBtr % array(cell2) - block % state % time_levs(1) % state % divergenceBtr % array(cell1) ) / block % mesh % dcEdge % array (iEdge) &
- -( block % state % time_levs(1) % state % vorticityBtr % array(vertex2) - block % state % time_levs(1) % state % vorticityBtr % array(vertex1) ) / block % mesh % dvEdge % array (iEdge))
+ ! FBtr = 0
+ block % state % time_levs(1) % state % FBtr % array(iEdge) = 0.0
+ end do
- end do
- end if
block => block % next
end do ! block
-! mrp 110801 end
-
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Barotropic subcycle: Final solve for velocity. Iterate for Coriolis term.
+ ! BEGIN Barotropic subcycle loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do j=1,config_n_btr_subcycles*config_btr_subcycle_loop_factor
- do BtrCorIter=1,config_n_btr_cor_iter
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Barotropic subcycle: VELOCITY PREDICTOR STEP
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if (config_btr_gam1_uWt1>1.0e-12) then ! only do this part if it is needed in next SSH solve
+ uPerpTime = oldBtrSubcycleTime
- uPerpTime = newBtrSubcycleTime
+ block => domain % blocklist
+ do while (associated(block))
- block => domain % blocklist
- do while (associated(block))
+ do iEdge=1,block % mesh % nEdges
- do iEdge=1,block % mesh % nEdges
+ cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+ ! Compute the barotropic Coriolis term, -f*uPerp
+ CoriolisTerm = 0.0
+ do i = 1,block % mesh % nEdgesOnEdge % array(iEdge)
+ eoe = block % mesh % edgesOnEdge % array(i,iEdge)
+ CoriolisTerm = CoriolisTerm &
+ + block % mesh % weightsOnEdge % array(i,iEdge) &
+ * block % state % time_levs(uPerpTime) % state % uBtrSubcycle % array(eoe) &
+ * block % mesh % fEdge % array(eoe)
+ end do
+
+ ! uBtrNew = uBtrOld + dt/J*(-f*uBtroldPerp - g*grad(SSH) + G)
+ block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ = (block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ + dt / config_n_btr_subcycles * (CoriolisTerm - gravity &
+ * (block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
+ - block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) ) &
+ / block % mesh % dcEdge % array(iEdge) &
+ + block % state % time_levs(1) % state % GBtrForcing % array(iEdge))) * block % mesh % edgeMask % array(1, iEdge)
+ end do
- ! Compute -f*uPerp
- uPerp = 0.0
- do i = 1,block % mesh % nEdgesOnEdge % array(iEdge)
- eoe = block % mesh % edgesOnEdge % array(i,iEdge)
- uPerp = uPerp + block % mesh % weightsOnEdge % array(i,iEdge) &
- * block % state % time_levs(uPerpTime) % state % uBtrSubcycle % array(eoe) &
- * block % mesh % fEdge % array(eoe)
- end do
+ block => block % next
+ end do ! block
- ! mrp 110606 efficiency note: could make this a 1D integer factor instead of an if statement.
- if (block % mesh % boundaryEdge % array(1,iEdge).eq.1) then
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) = 0.0
- else
+ ! boundary update on uBtrNew
+ call mpas_timer_start("se halo ubtr", .false., timer_halo_ubtr)
+ block => domain % blocklist
+ do while (associated(block))
- ! uBtrNew = uBtrOld + dt*(-f*uBtroldPerp - g*grad(SSH) + G)
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
+ block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
+ block % mesh % nEdges, block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
- sshCell1 = &
- (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
- + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell1)
+ block => block % next
+ end do ! block
+ call mpas_timer_stop("se halo ubtr", timer_halo_ubtr)
+ endif ! config_btr_gam1_uWt1>1.0e-12
- sshCell2 = &
- (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
- + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell2)
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Barotropic subcycle: SSH PREDICTOR STEP
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ block => domain % blocklist
+ do while (associated(block))
+
+ block % tend % ssh % array(:) = 0.0
+
+ if (config_btr_solve_SSH2) then
+ ! If config_btr_solve_SSH2=.true., then do NOT accumulate FBtr in this SSH predictor
+ ! section, because it will be accumulated in the SSH corrector section.
+ FBtr_coeff = 0.0
+ else
+ ! otherwise, DO accumulate FBtr in this SSH predictor section
+ FBtr_coeff = 1.0
+ endif
+
+ ! config_btr_gam1_uWt1 sets the forward weighting of velocity in the SSH computation
+ ! config_btr_gam1_uWt1= 1 flux = uBtrNew*H
+ ! config_btr_gam1_uWt1=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
+ ! config_btr_gam1_uWt1= 0 flux = uBtrOld*H
+ ! mrp 120201 efficiency: could we combine the following edge and cell loops?
+ do iEdge=1,block % mesh % nEdges
+ cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+
+ sshEdge = 0.5 * (block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
+ + block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) )
+ hSum = sshEdge + block % mesh % referenceBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+
+ flux = ((1.0-config_btr_gam1_uWt1) * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ + config_btr_gam1_uWt1 * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
+ * hSum
+
+ block % tend % ssh % array(cell1) = block % tend % ssh % array(cell1) - flux * block % mesh % dvEdge % array(iEdge)
+ block % tend % ssh % array(cell2) = block % tend % ssh % array(cell2) + flux * block % mesh % dvEdge % array(iEdge)
+
+ block % state % time_levs(1) % state % FBtr % array(iEdge) = block % state % time_levs(1) % state % FBtr % array(iEdge) &
+ + FBtr_coeff*flux
+ end do
+
+ ! SSHnew = SSHold + dt/J*(-div(Flux))
+ do iCell=1,block % mesh % nCells
+
+ block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
+ = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
+ + dt/config_n_btr_subcycles * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell)
+
+ end do
+
+ block => block % next
+ end do ! block
+
+ ! boundary update on SSHnew
+ call mpas_timer_start("se halo ssh", .false., timer_halo_ssh)
+ block => domain % blocklist
+ do while (associated(block))
+
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
+ block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
+ block % mesh % nCells, block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+
+ block => block % next
+ end do ! block
+ call mpas_timer_stop("se halo ssh", timer_halo_ssh)
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Barotropic subcycle: VELOCITY CORRECTOR STEP
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ do BtrCorIter=1,config_n_btr_cor_iter
+ uPerpTime = newBtrSubcycleTime
+
+ block => domain % blocklist
+ do while (associated(block))
+ do iEdge=1,block % mesh % nEdges
+ cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+
+ ! Compute the barotropic Coriolis term, -f*uPerp
+ CoriolisTerm = 0.0
+ do i = 1,block % mesh % nEdgesOnEdge % array(iEdge)
+ eoe = block % mesh % edgesOnEdge % array(i,iEdge)
+ CoriolisTerm = CoriolisTerm + block % mesh % weightsOnEdge % array(i,iEdge) &
+ * block % state % time_levs(uPerpTime) % state % uBtrSubcycle % array(eoe) &
+ * block % mesh % fEdge % array(eoe)
+ end do
+
+ ! In this final solve for velocity, SSH is a linear
+ ! combination of SSHold and SSHnew.
+ sshCell1 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
+ + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell1)
+ sshCell2 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
+ + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell2)
+
+ ! uBtrNew = uBtrOld + dt/J*(-f*uBtroldPerp - g*grad(SSH) + G)
+ block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ = (block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ + dt/config_n_btr_subcycles *(CoriolisTerm - gravity *(sshCell2 - sshCell1) /block % mesh % dcEdge % array(iEdge) &
+ + block % state % time_levs(1) % state % GBtrForcing % array(iEdge))) * block % mesh % edgeMask % array(1,iEdge)
+ end do
+
+ block => block % next
+ end do ! block
+
+ ! boundary update on uBtrNew
+ call mpas_timer_start("se halo ubtr", .false., timer_halo_ubtr)
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
+ block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
+ block % mesh % nEdges, block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+
+ block => block % next
+ end do ! block
+ call mpas_timer_stop("se halo ubtr", timer_halo_ubtr)
+ end do !do BtrCorIter=1,config_n_btr_cor_iter
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Barotropic subcycle: SSH CORRECTOR STEP
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if (config_btr_solve_SSH2) then
+
+ block => domain % blocklist
+ do while (associated(block))
+ block % tend % ssh % array(:) = 0.0
+
+ ! config_btr_gam3_uWt2 sets the forward weighting of velocity in the SSH computation
+ ! config_btr_gam3_uWt2= 1 flux = uBtrNew*H
+ ! config_btr_gam3_uWt2=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
+ ! config_btr_gam3_uWt2= 0 flux = uBtrOld*H
+ ! mrp 120201 efficiency: could we combine the following edge and cell loops?
+ do iEdge=1,block % mesh % nEdges
+ cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
+ cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+
+ ! SSH is a linear combination of SSHold and SSHnew.
+ sshCell1 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
+ + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell1)
+ sshCell2 = (1-config_btr_gam2_SSHWt1)*block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) &
+ + config_btr_gam2_SSHWt1 *block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(cell2)
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- = block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- + dt/config_n_btr_subcycles *( &
- uPerp &
- - gravity &
- *( sshCell2 &
- - sshCell1 )&
- /block % mesh % dcEdge % array(iEdge) &
- + block % state % time_levs(1) % state % GBtrForcing % array(iEdge) &
- + block % state % time_levs(1) % state % u_diffusionBtr % array(iEdge))
- ! added del2 diffusion to btr solve
-
- endif
-
- end do
-
- ! Implicit solve for barotropic momentum decay
- if ( config_btr_mom_decay) then
- ! Add term to RHS of momentum equation: -1/gamma u
- !
- ! This changes the solve to:
- ! u^{n+1} = u_provis^{n+1}/(1+dt/gamma)
- !
- coef = 1.0/(1.0 + dt/config_n_btr_subcycles/config_btr_mom_decay_time)
- do iEdge=1,block % mesh % nEdges
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- = block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- * coef
- end do
-
- endif
-
- block => block % next
- end do ! block
-
-
- ! boundary update on uBtrNew
- block => domain % blocklist
- do while (associated(block))
-
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(:), &
- block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- block => block % next
- end do ! block
-
- end do !do BtrCorIter=1,config_n_btr_cor_iter
-
+ sshEdge = 0.5 * (sshCell1 + sshCell2)
+ hSum = sshEdge + block % mesh % referenceBottomDepthTopOfCell % array (block % mesh % maxLevelEdgeTop % array(iEdge)+1)
+
+ flux = ((1.0-config_btr_gam3_uWt2) * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
+ + config_btr_gam3_uWt2 * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
+ * hSum
+
+ block % tend % ssh % array(cell1) = block % tend % ssh % array(cell1) - flux * block % mesh % dvEdge % array(iEdge)
+ block % tend % ssh % array(cell2) = block % tend % ssh % array(cell2) + flux * block % mesh % dvEdge % array(iEdge)
+
+ block % state % time_levs(1) % state % FBtr % array(iEdge) = block % state % time_levs(1) % state % FBtr % array(iEdge) + flux
+ end do
+
+ ! SSHnew = SSHold + dt/J*(-div(Flux))
+ do iCell=1,block % mesh % nCells
+ block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
+ = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
+ + dt/config_n_btr_subcycles * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell)
+ end do
+
+ block => block % next
+ end do ! block
+
+ ! boundary update on SSHnew
+ call mpas_timer_start("se halo ssh", .false., timer_halo_ssh)
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
+ block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
+ block % mesh % nCells, block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+
+ block => block % next
+ end do ! block
+ call mpas_timer_stop("se halo ssh", timer_halo_ssh)
+ endif ! config_btr_solve_SSH2
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ ! Barotropic subcycle: Accumulate running sums, advance timestep pointers
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ block => domain % blocklist
+ do while (associated(block))
+
+ ! uBtrNew = uBtrNew + uBtrSubcycleNEW
+ ! This accumulates the sum.
+ ! If the Barotropic Coriolis iteration is limited to one, this could
+ ! be merged with the above code.
+ do iEdge=1,block % mesh % nEdges
+
+ block % state % time_levs(2) % state % uBtr % array(iEdge) &
+ = block % state % time_levs(2) % state % uBtr % array(iEdge) &
+ + block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)
+
+ end do ! iEdge
+ block => block % next
+ end do ! block
+
+ ! advance time pointers
+ oldBtrSubcycleTime = mod(oldBtrSubcycleTime,2)+1
+ newBtrSubcycleTime = mod(newBtrSubcycleTime,2)+1
+
+ end do ! j=1,config_n_btr_subcycles
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Barotropic subcycle: Compute thickness flux and new SSH: CORRECTOR
+ ! END Barotropic subcycle loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- if (config_btr_solve_SSH2) then
- block => domain % blocklist
- do while (associated(block))
-
- block % tend % ssh % array(:) = 0.0
-
- ! config_btr_gam3_uWt2 sets the forward weighting of velocity in the SSH computation
- ! config_btr_gam3_uWt2= 1 flux = uBtrNew*H
- ! config_btr_gam3_uWt2=0.5 flux = 1/2*(uBtrNew+uBtrOld)*H
- ! config_btr_gam3_uWt2= 0 flux = uBtrOld*H
-
- do iEdge=1,block % mesh % nEdges
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
-
- sshEdge = 0.5 &
- *( block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell1) &
- + block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(cell2) )
- hSum = sum(block % mesh % hZLevel % array (1:block % mesh % maxLevelEdgeTop % array(iEdge)))
-
- flux = ((1.0-config_btr_gam3_uWt2) &
- * block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge) &
- + config_btr_gam3_uWt2 &
- * block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)) &
- * (sshEdge + hSum)
-
- block % tend % ssh % array(cell1) = block % tend % ssh % array(cell1) &
- - flux * block % mesh % dvEdge % array(iEdge)
- block % tend % ssh % array(cell2) = block % tend % ssh % array(cell2) &
- + flux * block % mesh % dvEdge % array(iEdge)
-
- block % state % time_levs(1) % state % FBtr % array(iEdge) &
- = block % state % time_levs(1) % state % FBtr % array(iEdge) &
- + flux
-
-
- end do
-
- ! SSHnew = SSHold + dt/J*(-div(Flux))
- do iCell=1,block % mesh % nCells
-
- block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
- = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
- + dt/config_n_btr_subcycles &
- * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell)
-
- end do
-
- block => block % next
- end do ! block
-
- ! boundary update on SSHnew
- block => domain % blocklist
- do while (associated(block))
-
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(:), &
- block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
-
- block => block % next
- end do ! block
-
- endif ! config_btr_solve_SSH2
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Barotropic subcycle: Accumulate running sums, advance timestep pointers
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- block => domain % blocklist
- do while (associated(block))
-
- ! Accumulate SSH in running sum over the subcycles.
- do iCell=1,block % mesh % nCells
- block % state % time_levs(2) % state % ssh % array(iCell) &
- = block % state % time_levs(2) % state % ssh % array(iCell) &
- + block % state % time_levs(newBtrSubcycleTime) % state % sshSubcycle % array(iCell)
- end do
-
- ! uBtrNew = uBtrNew + uBtrSubcycleNEW
- ! This accumulates the sum.
- ! If the Barotropic Coriolis iteration is limited to one, this could
- ! be merged with the above code.
- do iEdge=1,block % mesh % nEdges
-
- block % state % time_levs(2) % state % uBtr % array(iEdge) &
- = block % state % time_levs(2) % state % uBtr % array(iEdge) &
- + block % state % time_levs(newBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)
-
- end do ! iEdge
- block => block % next
- end do ! block
-
- ! advance time pointers
- oldBtrSubcycleTime = mod(oldBtrSubcycleTime,2)+1
- newBtrSubcycleTime = mod(newBtrSubcycleTime,2)+1
-
- end do ! j=1,config_n_btr_subcycles
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! END Barotropic subcycle loop
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
! Normalize Barotropic subcycle sums: ssh, uBtr, and F
block => domain % blocklist
do while (associated(block))
-
- do iEdge=1,block % mesh % nEdges
- block % state % time_levs(1) % state % FBtr % array(iEdge) &
- = block % state % time_levs(1) % state % FBtr % array(iEdge) &
- / (config_n_btr_subcycles*config_btr_subcycle_loop_factor)
-
- block % state % time_levs(2) % state % uBtr % array(iEdge) &
- = block % state % time_levs(2) % state % uBtr % array(iEdge) &
- / (config_n_btr_subcycles*config_btr_subcycle_loop_factor + 1)
- end do
-
- if (config_SSH_from=='avg_of_SSH_subcycles') then
- do iCell=1,block % mesh % nCells
- block % state % time_levs(2) % state % ssh % array(iCell) &
- = block % state % time_levs(2) % state % ssh % array(iCell) &
- / (config_n_btr_subcycles*config_btr_subcycle_loop_factor + 1)
- end do
- elseif (config_SSH_from=='avg_flux') then
- ! see below
- else
- write(0,*) 'Abort: Unknown config_SSH_from option: '&
- //trim(config_SSH_from)
- call mpas_dmpar_abort(dminfo)
- endif
-
+
+ do iEdge=1,block % mesh % nEdges
+ block % state % time_levs(1) % state % FBtr % array(iEdge) = block % state % time_levs(1) % state % FBtr % array(iEdge) &
+ / (config_n_btr_subcycles*config_btr_subcycle_loop_factor)
+
+ block % state % time_levs(2) % state % uBtr % array(iEdge) = block % state % time_levs(2) % state % uBtr % array(iEdge) &
+ / (config_n_btr_subcycles*config_btr_subcycle_loop_factor + 1)
+ end do
+
block => block % next
end do ! block
-
-
+
+
! boundary update on F
+ call mpas_timer_start("se halo F", .false., timer_halo_f)
block => domain % blocklist
do while (associated(block))
-
- call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
- block % state % time_levs(1) % state % FBtr % array(:), &
- block % mesh % nEdges, &
- block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
-
- block => block % next
+ call mpas_dmpar_exch_halo_field1d_real(domain % dminfo, &
+ block % state % time_levs(1) % state % FBtr % array(:), &
+ block % mesh % nEdges, block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
+
+ block => block % next
end do ! block
+ call mpas_timer_stop("se halo F", timer_halo_f)
! Check that you can compute SSH using the total sum or the individual increments
@@ -831,363 +649,236 @@
allocate(uTemp(block % mesh % nVertLevels))
- if (config_SSH_from=='avg_flux') then
- ! Accumulate fluxes in the tend % ssh variable
- block % tend % ssh % array(:) = 0.0
- do iEdge=1,block % mesh % nEdges
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+ ! Correction velocity uCorr = (Flux - Sum(h u*))/H
+ ! or, for the full latex version:
+ !{\bf u}^{corr} = \left( {\overline {\bf F}}
+ ! - \sum_{k=1}^{N^{edge}} h_{k,*}^{edge} {\bf u}_k^{avg} \right)
+ ! \left/ \sum_{k=1}^{N^{edge}} h_{k,*}^{edge} \right.
- block % tend % ssh % array(cell1) &
- = block % tend % ssh % array(cell1) &
- - block % state % time_levs(1) % state % FBtr % array(iEdge) &
- * block % mesh % dvEdge % array(iEdge)
+ if (config_u_correction) then
+ ucorr_coef = 1
+ else
+ ucorr_coef = 0
+ endif
+ do iEdge=1,block % mesh % nEdges
- block % tend % ssh % array(cell2) &
- = block % tend % ssh % array(cell2) &
- + block % state % time_levs(1) % state % FBtr % array(iEdge) &
- * block % mesh % dvEdge % array(iEdge)
+ ! This is u^{avg}
+ uTemp(:) = block % state % time_levs(2) % state % uBtr % array(iEdge) &
+ + block % state % time_levs(2) % state % uBcl % array(:,iEdge)
- end do
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = block % state % time_levs(2) % state % h_edge % array(1,iEdge) * uTemp(1)
+ hSum = block % state % time_levs(2) % state % h_edge % array(1,iEdge)
- do iCell=1,block % mesh % nCells
-
- ! SSHnew = SSHold + dt*(-div(Flux))
- block % state % time_levs(2) % state % ssh % array(iCell) &
- = block % state % time_levs(1) % state % ssh % array(iCell) &
- + dt &
- * block % tend % ssh % array(iCell) / block % mesh % areaCell % array (iCell)
- end do
- endif
+ do k=2,block % mesh % maxLevelEdgeTop % array(iEdge)
+ uhSum = uhSum + block % state % time_levs(2) % state % h_edge % array(k,iEdge) * uTemp(k)
+ hSum = hSum + block % state % time_levs(2) % state % h_edge % array(k,iEdge)
+ enddo
- ! Correction velocity uCorr = (Flux - Sum(h u*))/H
- ! or, for the full latex version:
- !u^{corr} = \left( {\overline {\bf F}}
- ! - \sum_{k=1}^{N^{edge}} \left(\zeta_{k,n}^{*\;edge}+\Delta z_k\right) u_k^* \right)
- !\left/ \sum_{k=1}^{N^{edge}} \left(\zeta_{k,n}^{*\;edge}+\Delta z_k\right) \right.
+ uCorr = ucorr_coef*(( block % state % time_levs(1) % state % FBtr % array(iEdge) - uhSum)/hSum)
- if (config_u_correction) then
- ucorr_coef = 1
- else
- ucorr_coef = 0
- endif
+ ! put u^{tr}, the velocity for tracer transport, in uNew
+ ! mrp 060611 not sure if boundary enforcement is needed here.
+ if (block % mesh % boundaryEdge % array(1,iEdge).eq.1) then
+ block % state % time_levs(2) % state % u % array(:,iEdge) = 0.0
+ else
+ do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
+ block % state % time_levs(2) % state % u % array(k,iEdge) = uTemp(k) + uCorr
+ enddo
+ do k=block % mesh % maxLevelEdgeTop % array(iEdge)+1,block % mesh % nVertLevels
+ block % state % time_levs(2) % state % u % array(k,iEdge) = 0.0
+ end do
+ endif
- do iEdge=1,block % mesh % nEdges
- cell1 = block % mesh % cellsOnEdge % array(1,iEdge)
- cell2 = block % mesh % cellsOnEdge % array(2,iEdge)
+ end do ! iEdge
- sshEdge = 0.5 &
- *( block % state % time_levs(2) % state % ssh % array(cell1) &
- + block % state % time_levs(2) % state % ssh % array(cell2) )
+ deallocate(uTemp)
- ! This is u*
- uTemp(:) &
- = block % state % time_levs(2) % state % uBtr % array(iEdge) &
- + block % state % time_levs(2) % state % uBcl % array(:,iEdge)
-
- uhSum = (sshEdge + block % mesh % hZLevel % array(1)) * uTemp(1)
- hSum = sshEdge + block % mesh % hZLevel % array(1)
-
- do k=2,block % mesh % maxLevelEdgeTop % array(iEdge)
- uhSum = uhSum + block % mesh % hZLevel % array(k) * uTemp(k)
- hSum = hSum + block % mesh % hZLevel % array(k)
- enddo
-
- uCorr = ucorr_coef*(( block % state % time_levs(1) % state % FBtr % array(iEdge) &
- - uhSum)/hSum)
-
- ! put u^{tr}, the velocity for tracer transport, in uNew
- ! mrp 060611 not sure if boundary enforcement is needed here.
- if (block % mesh % boundaryEdge % array(1,iEdge).eq.1) then
- block % state % time_levs(2) % state % u % array(:,iEdge) = 0.0
- else
- do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
- block % state % time_levs(2) % state % u % array(k,iEdge) = uTemp(k) + uCorr
- enddo
- do k=block % mesh % maxLevelEdgeTop % array(iEdge)+1,block % mesh % nVertLevels
- block % state % time_levs(2) % state % u % array(k,iEdge) = 0.0
- enddo
- endif
-
- ! Put new sshEdge values in h_edge array, for the OcnTendScalar call below.
- block % state % time_levs(2) % state % h_edge % array(1,iEdge) &
- = sshEdge + block % mesh % hZLevel % array(1)
-
- do k=2,block % mesh % nVertLevels
- block % state % time_levs(2) % state % h_edge % array(k,iEdge) &
- = block % mesh % hZLevel % array(k)
- enddo
-
- end do ! iEdge
-
- ! Put new SSH values in h array, for the OcnTendScalar call below.
- do iCell=1,block % mesh % nCells
- block % state % time_levs(2) % state % h % array(1,iCell) &
- = block % state % time_levs(2) % state % ssh % array(iCell) &
- + block % mesh % hZLevel % array(1)
-
- ! mrp 110601 efficiency note: Since h just moves back and forth between pointers,
- ! this is not necessary once initialized.
- do k=2,block % mesh % nVertLevels
- block % state % time_levs(2) % state % h % array(k,iCell) &
- = block % mesh % hZLevel % array(k)
- enddo
- enddo ! iCell
-
- deallocate(uTemp)
-
block => block % next
end do ! block
+ endif ! split_explicit
- endif ! split_explicit
+ call mpas_timer_stop("se btr vel", timer_btr_vel)
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Stage 3: Tracer, density, pressure, vertical velocity prediction
- !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Stage 3: Tracer, density, pressure, vertical velocity prediction
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !TDR: it seems almost trivial to hold off on doing T, S and rho updates until the
+ !TDR: dycore time step is complete. we might want to take this opportunity to clean-up
+ !TDR: Stage3 in order to faciliate the testing of not doing tracer updates after this code is committed to trunk.
+ !TDR: at this point, I am suggesting just pushing some of this code into subroutines.
+ !TDR: see comments farther down
+
+ ! dwj: 02/22/12 splitting thickness and tracer tendency computations and halo updates to allow monotonic advection.
block => domain % blocklist
do while (associated(block))
+ call ocn_wtop(block % state % time_levs(1) % state,block % state % time_levs(2) % state, block % mesh)
- call ocn_wtop(block % state % time_levs(2) % state, block % mesh)
+ call ocn_tend_h(block % tend, block % state % time_levs(2) % state, block % mesh)
+ block => block % next
+ end do
- if (trim(config_time_integration) == 'unsplit_explicit') then
- call ocn_tend_h(block % tend, block % state % time_levs(2) % state , block % diagnostics, block % mesh)
- endif
+ ! update halo for thickness and tracer tendencies
+ call mpas_timer_start("se halo h", .false., timer_halo_h)
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
+ block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+ call mpas_timer_stop("se halo h", timer_halo_h)
- call ocn_tend_scalar(block % tend, block % state % time_levs(2) % state , block % diagnostics, block % mesh)
+ block => domain % blocklist
+ do while (associated(block))
+ call ocn_tend_scalar(block % tend, block % state % time_levs(2) % state, block % diagnostics, block % mesh, dt)
- block => block % next
+ block => block % next
end do
- ! update halo for thicknes for unsplit only
- if (trim(config_time_integration) == 'unsplit_explicit') then
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % tend % h % array(:,:), &
- block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
- endif ! unsplit_explicit
+ ! update halo for thickness and tracer tendencies
+ call mpas_timer_start("se halo tracers", .false., timer_halo_tracers)
+ block => domain % blocklist
+ do while (associated(block))
+ call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % tend % tracers % array(:,:,:), &
+ block % tend % num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
+ block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
+ block => block % next
+ end do
+ call mpas_timer_stop("se halo tracers", timer_halo_tracers)
+ block => domain % blocklist
+ do while (associated(block))
- block => domain % blocklist
- do while (associated(block))
- allocate(hNew(block % mesh % nVertLevels))
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! If iterating, reset variables for next iteration
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ if (split_explicit_step < config_n_ts_iter) then
- if (trim(config_new_btr_variables_from) == 'last_subcycle') then
- ! This points to the last barotropic SSH subcycle
- sshNew => block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array
- elseif (trim(config_new_btr_variables_from) == 'btr_avg') then
- ! This points to the tendency variable SSH*
- sshNew => block % state % time_levs(2) % state % ssh % array
- endif
+ !TDR: should we move this code into a subroutine called "compute_intermediate_value_at_midtime"
+ !TDR: this could be within a contains statement in this routine
- if (trim(config_time_integration) == 'unsplit_explicit') then
+ ! Only need T & S for earlier iterations,
+ ! then all the tracers needed the last time through.
+ do iCell=1,block % mesh % nCells
+ ! sshNew is a pointer, defined above.
+ do k=1,block % mesh % maxLevelCell % array(iCell)
- do iCell=1,block % mesh % nCells
- ! this is h_{n+1}
- block % state % time_levs(2) % state % h % array(:,iCell) &
- = block % state % time_levs(1) % state % h % array(:,iCell) &
- + dt* block % tend % h % array(:,iCell)
+ ! this is h_{n+1}
+ temp_h &
+ = block % state % time_levs(1) % state % h % array(k,iCell) &
+ + dt* block % tend % h % array(k,iCell)
- ! this is only for the hNew computation below, so there is the correct
- ! value in the ssh variable for unsplit_explicit case.
- block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell) &
- = block % state % time_levs(2) % state % h % array(1,iCell) &
- - block % mesh % hZLevel % array(1)
- end do ! iCell
+ ! this is h_{n+1/2}
+ block % state % time_levs(2) % state % h % array(k,iCell) &
+ = 0.5*( &
+ block % state % time_levs(1) % state % h % array(k,iCell) &
+ + temp_h)
- endif ! unsplit_explicit
+ do i=1,2
+ ! This is Phi at n+1
+ temp = ( &
+ block % state % time_levs(1) % state % tracers % array(i,k,iCell) &
+ * block % state % time_levs(1) % state % h % array(k,iCell) &
+ + dt * block % tend % tracers % array(i,k,iCell)) &
+ / temp_h
+
+ ! This is Phi at n+1/2
+ block % state % time_levs(2) % state % tracers % array(i,k,iCell) &
+ = 0.5*( &
+ block % state % time_levs(1) % state % tracers % array(i,k,iCell) &
+ + temp )
+ end do
+ end do
+ end do ! iCell
- ! Only need T & S for earlier iterations,
- ! then all the tracers needed the last time through.
- if (split_explicit_step < config_n_ts_iter) then
+ ! uBclNew is u'_{n+1/2}
+ ! uBtrNew is {\bar u}_{avg}
+ ! uNew is u^{tr}
- hNew(:) = block % mesh % hZLevel % array(:)
- do iCell=1,block % mesh % nCells
- ! sshNew is a pointer, defined above.
- hNew(1) = sshNew(iCell) + block % mesh % hZLevel % array(1)
- do k=1,block % mesh % maxLevelCell % array(iCell)
- do i=1,2
- ! This is Phi at n+1
- tracerTemp &
- = ( block % state % time_levs(1) % state % tracers % array(i,k,iCell) &
- * block % state % time_levs(1) % state % h % array(k,iCell) &
- + dt * block % tend % tracers % array(i,k,iCell) &
- ) / hNew(k)
+ ! mrp 110512 I really only need this to compute h_edge, density, pressure, and SSH
+ ! I can par this down later.
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
- ! This is Phi at n+1/2
- block % state % time_levs(2) % state % tracers % array(i,k,iCell) &
- = 0.5*( &
- block % state % time_levs(1) % state % tracers % array(i,k,iCell) &
- + tracerTemp )
- enddo
- end do
- end do ! iCell
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! If large iteration complete, compute all variables at time n+1
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ elseif (split_explicit_step == config_n_ts_iter) then
+ !TDR: should we move this code into a subroutine called "compute_final_values_at_nplus1"?
+ !TDR: this could be within a contains statement in this routine
- if (trim(config_time_integration) == 'unsplit_explicit') then
+ do iCell=1,block % mesh % nCells
+ do k=1,block % mesh % maxLevelCell % array(iCell)
- ! compute h*, which is h at n+1/2 and put into array hNew
- ! on last iteration, hNew remains at n+1
- do iCell=1,block % mesh % nCells
- block % state % time_levs(2) % state % h % array(1,iCell) &
- = 0.5*( &
- block % state % time_levs(2) % state % h % array(1,iCell) &
- + block % state % time_levs(1) % state % h % array(1,iCell) )
+ ! this is h_{n+1}
+ block % state % time_levs(2) % state % h % array(k,iCell) &
+ = block % state % time_levs(1) % state % h % array(k,iCell) &
+ + dt* block % tend % h % array(k,iCell)
- end do ! iCell
- endif ! unsplit_explicit
+ ! This is Phi at n+1
+ do i=1,block % state % time_levs(1) % state % num_tracers
+ block % state % time_levs(2) % state % tracers % array(i,k,iCell) &
+ = (block % state % time_levs(1) % state % tracers % array(i,k,iCell) &
+ * block % state % time_levs(1) % state % h % array(k,iCell) &
+ + dt * block % tend % tracers % array(i,k,iCell)) &
+ / block % state % time_levs(2) % state % h % array(k,iCell)
- ! compute u*, the velocity for tendency terms. Put in uNew.
- ! uBclNew is at time n+1/2 here.
- ! This overwrites u^{tr}, the tracer transport velocity, which was in uNew.
- ! The following must occur after call OcnTendScalar
- do iEdge=1,block % mesh % nEdges
- block % state % time_levs(2) % state % u % array(:,iEdge) &
- = block % state % time_levs(2) % state % uBtr % array(iEdge) &
- + block % state % time_levs(2) % state % uBcl % array(:,iEdge)
- end do ! iEdge
+ enddo
+ end do
+ end do
- elseif (split_explicit_step == config_n_ts_iter) then
+ ! Recompute final u to go on to next step.
+ ! u_{n+1} = uBtr_{n+1} + uBcl_{n+1}
+ ! Right now uBclNew is at time n+1/2, so back compute to get uBcl at time n+1
+ ! using uBcl_{n+1/2} = 1/2*(uBcl_n + u_Bcl_{n+1})
+ ! so the following lines are
+ ! u_{n+1} = uBtr_{n+1} + 2*uBcl_{n+1/2} - uBcl_n
+ ! note that uBcl is recomputed at the beginning of the next timestep due to Imp Vert mixing,
+ ! so uBcl does not have to be recomputed here.
+
+ do iEdge=1,block % mesh % nEdges
+ do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
+ block % state % time_levs(2) % state % u % array(k,iEdge) &
+ = block % state % time_levs(2) % state % uBtr % array( iEdge) &
+ +2*block % state % time_levs(2) % state % uBcl % array(k,iEdge) &
+ - block % state % time_levs(1) % state % uBcl % array(k,iEdge)
+ end do
+ end do ! iEdges
- hNew(:) = block % mesh % hZLevel % array(:)
- do iCell=1,block % mesh % nCells
- ! sshNew is a pointer, defined above.
- hNew(1) = sshNew(iCell) + block % mesh % hZLevel % array(1)
- do k=1,block % mesh % maxLevelCell % array(iCell)
- do i=1,block % state % time_levs(1) % state % num_tracers
- ! This is Phi at n+1
- block % state % time_levs(2) % state % tracers % array(i,k,iCell) &
- = ( block % state % time_levs(1) % state % tracers % array(i,k,iCell) &
- * block % state % time_levs(1) % state % h % array(k,iCell) &
- + dt * block % tend % tracers % array(i,k,iCell) &
- ) / hNew(k)
+ endif ! split_explicit_step
- enddo
- end do
- end do
+ block => block % next
+ end do
- endif ! split_explicit_step
- deallocate(hNew)
- block => block % next
- end do
- ! Boundary update on tracers. This is placed here, rather than
- ! on tend % tracers as in RK4, because I needed to update
- ! afterwards for the del4 diffusion operator.
- block => domain % blocklist
- do while (associated(block))
- call mpas_dmpar_exch_halo_field3d_real(domain % dminfo, block % state % time_levs(2) % state % tracers % array(:,:,:), &
- block % tend % num_tracers, block % mesh % nVertLevels, block % mesh % nCells, &
- block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- block => block % next
- end do
-
-
- if (split_explicit_step < config_n_ts_iter) then
- ! mrp 110512 I really only need this to compute h_edge, density, pressure.
- ! I can par this down later.
- block => domain % blocklist
- do while (associated(block))
-
- call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
-
- block => block % next
- end do
- endif
-
end do ! split_explicit_step = 1, config_n_ts_iter
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! END large iteration loop
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! A little clean up at the end: decouple new scalar fields and compute diagnostics for new state
- !
block => domain % blocklist
do while (associated(block))
- if (trim(config_new_btr_variables_from) == 'last_subcycle') then
- do iEdge=1,block % mesh % nEdges
- ! uBtrNew = uBtrSubcycleNew (old here is because counter already flipped)
- ! This line is not needed if u is resplit at the beginning of the timestep.
- block % state % time_levs(2) % state % uBtr % array(iEdge) &
- = block % state % time_levs(oldBtrSubcycleTime) % state % uBtrSubcycle % array(iEdge)
- enddo ! iEdges
- elseif (trim(config_new_btr_variables_from) == 'btr_avg') then
- ! uBtrNew from u*. this is done above, so u* is already in
- ! block % state % time_levs(2) % state % uBtr % array(iEdge)
- else
- write(0,*) 'Abort: Unknown config_new_btr_variables_from: '&
- //trim(config_time_integration)
- call mpas_dmpar_abort(dminfo)
- endif
- ! Recompute final u to go on to next step.
- ! u_{n+1} = uBtr_{n+1} + uBcl_{n+1}
- ! Right now uBclNew is at time n+1/2, so back compute to get uBcl at time n+1
- ! using uBcl_{n+1/2} = 1/2*(uBcl_n + u_Bcl_{n+1})
- ! so the following lines are
- ! u_{n+1} = uBtr_{n+1} + 2*uBcl_{n+1/2} - uBcl_n
- ! note that uBcl is recomputed at the beginning of the next timestep due to Imp Vert mixing,
- ! so uBcl does not have to be recomputed here.
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Implicit vertical mixing, done after timestep is complete
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- do iEdge=1,block % mesh % nEdges
- do k=1,block % mesh % maxLevelEdgeTop % array(iEdge)
-
- block % state % time_levs(2) % state % u % array(k,iEdge) &
- = block % state % time_levs(2) % state % uBtr % array(iEdge) &
- +2*block % state % time_levs(2) % state % uBcl % array(k,iEdge) &
- - block % state % time_levs(1) % state % uBcl % array(k,iEdge)
- enddo
- ! mrp 110607 zero out velocity below land edges. efficiency: this may not be required.
- do k=block % mesh % maxLevelEdgeTop % array(iEdge) + 1, block % mesh % nVertLevels
- block % state % time_levs(2) % state % u % array(k,iEdge) = 0.0
- enddo
-
- enddo ! iEdges
-
- if (trim(config_time_integration) == 'split_explicit') then
-
- if (trim(config_new_btr_variables_from) == 'last_subcycle') then
- do iCell=1,block % mesh % nCells
- ! SSH for the next step is from the end of the barotropic subcycle.
- block % state % time_levs(2) % state % ssh % array(iCell) &
- = block % state % time_levs(oldBtrSubcycleTime) % state % sshSubcycle % array(iCell)
- end do ! iCell
- elseif (trim(config_new_btr_variables_from) == 'btr_avg') then
- ! sshNew from ssh*. This is done above, so ssh* is already in
- ! block % state % time_levs(2) % state % ssh % array(iCell)
- endif
-
- do iCell=1,block % mesh % nCells
- ! Put new SSH values in h array, for the OcnTendScalar call below.
- block % state % time_levs(2) % state % h % array(1,iCell) &
- = block % state % time_levs(2) % state % ssh % array(iCell) &
- + block % mesh % hZLevel % array(1)
-
- ! mrp 110601 efficiency note: Since h just moves back and forth between pointers,
- ! this is not necessary once initialized.
- do k=2,block % mesh % nVertLevels
- block % state % time_levs(2) % state % h % array(k,iCell) &
- = block % mesh % hZLevel % array(k)
- end do
- end do ! iCell
- end if ! split_explicit
-
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- !
- ! Implicit vertical mixing, done after timestep is complete
- !
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
u => block % state % time_levs(2) % state % u % array
tracers => block % state % time_levs(2) % state % tracers % array
h => block % state % time_levs(2) % state % h % array
@@ -1200,61 +891,43 @@
maxLevelEdgeTop => block % mesh % maxLevelEdgeTop % array
if (config_implicit_vertical_mix) then
- allocate(A(block % mesh % nVertLevels),C(block % mesh % nVertLevels),uTemp(block % mesh % nVertLevels), &
- tracersTemp(num_tracers,block % mesh % nVertLevels))
-
call ocn_vmix_coefs(block % mesh, block % state % time_levs(2) % state, block % diagnostics, err)
- !
! Implicit vertical solve for momentum
- !
-
call ocn_vel_vmix_tend_implicit(block % mesh, dt, ke_edge, vertvisctopofedge, h, h_edge, u, err)
-
- !
+
! Implicit vertical solve for tracers
- !
call ocn_tracer_vmix_tend_implicit(block % mesh, dt, vertdifftopofcell, h, tracers, err)
end if
- ! mrp 110725 adding momentum decay term
- if (config_mom_decay) then
-
- !
- ! Implicit solve for momentum decay
- !
- ! Add term to RHS of momentum equation: -1/gamma u
- !
- ! This changes the solve to:
- ! u^{n+1} = u_provis^{n+1}/(1+dt/gamma)
- !
- coef = 1.0/(1.0 + dt/config_mom_decay_time)
- do iEdge=1,block % mesh % nEdges
- do k=1,maxLevelEdgeTop(iEdge)
- u(k,iEdge) = coef*u(k,iEdge)
- end do
- end do
-
+ if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
- if (config_test_case == 1) then ! For case 1, wind field should be fixed
+ if (config_prescribe_velocity) then
block % state % time_levs(2) % state % u % array(:,:) = block % state % time_levs(1) % state % u % array(:,:)
end if
- call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
+ if (config_prescribe_thickness) then
+ block % state % time_levs(2) % state % h % array(:,:) = block % state % time_levs(1) % state % h % array(:,:)
+ end if
+ call ocn_diagnostic_solve(dt, block % state % time_levs(2) % state, block % mesh)
call mpas_reconstruct(block % mesh, block % state % time_levs(2) % state % u % array, &
- block % state % time_levs(2) % state % uReconstructX % array, &
- block % state % time_levs(2) % state % uReconstructY % array, &
- block % state % time_levs(2) % state % uReconstructZ % array, &
- block % state % time_levs(2) % state % uReconstructZonal % array, &
- block % state % time_levs(2) % state % uReconstructMeridional % array &
- )
+ block % state % time_levs(2) % state % uReconstructX % array, &
+ block % state % time_levs(2) % state % uReconstructY % array, &
+ block % state % time_levs(2) % state % uReconstructZ % array, &
+ block % state % time_levs(2) % state % uReconstructZonal % array, &
+ block % state % time_levs(2) % state % uReconstructMeridional % array)
+ call ocn_time_average_accumulate(block % state % time_levs(2) % state, block % state % time_levs(1) % state)
+
+
block => block % next
end do
- call mpas_timer_stop("split_explicit_timestep")
+ call mpas_timer_stop("se timestep", timer_main)
+
end subroutine ocn_time_integrator_split!}}}
subroutine filter_btr_mode_tend_u(tend, s, d, grid)!{{{
@@ -1274,110 +947,49 @@
type (diagnostics_type), intent(in) :: d
type (mesh_type), intent(in) :: grid
-! mrp 110512 I just split compute_tend into compute_tend_u and compute_tend_h.
-! Some of these variables can be removed, but at a later time.
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, &
- vertex1, vertex2, eoe, i, j
+ integer :: iEdge, k
integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve
- real (kind=RKIND) :: vertSum, uhSum, hSum, sshEdge
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel, meshScalingDel2, meshScalingDel4
+ real (kind=RKIND) :: vertSum, uhSum, hSum
real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
- MontPot, wTop, divergence, vertViscTopOfEdge
+ h_edge, h, u,tend_u
type (dm_info) :: dminfo
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot
- integer, dimension(:,:), pointer :: &
- cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, &
- edgesOnEdge, edgesOnVertex
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), allocatable:: fluxVertTop,w_dudzTopEdge
+ integer, dimension(:), pointer :: maxLevelEdgeTop
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
-
- real (kind=RKIND), dimension(:,:), pointer :: u_src
- real (kind=RKIND), parameter :: rho_ref = 1000.0
-
call mpas_timer_start("filter_btr_mode_tend_u")
h => s % h % array
u => s % u % array
- v => s % v % array
- wTop => s % wTop % array
h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
- MontPot => s % MontPot % array
- pressure => s % pressure % array
- vertViscTopOfEdge => d % vertViscTopOfEdge % array
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
-! mrp 110516 cleanup fvertex fedge not used in this subroutine
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
- maxLevelCell => grid % maxLevelCell % array
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
tend_u => tend % u % array
nCells = grid % nCells
nEdges = grid % nEdges
- nEdgesSolve = grid % nEdgesSolve
- nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
- u_src => grid % u_src % array
+ do iEdge=1,nEdges
- do iEdge=1,grid % nEdges
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = h_edge(1,iEdge) * tend_u(1,iEdge)
+ hSum = h_edge(1,iEdge)
- ! I am using hZLevel here. This assumes that SSH is zero everywhere already,
- ! which should be the case if the barotropic mode is filtered.
- ! The more general case is to use sshEdge or h_edge.
- uhSum = (grid % hZLevel % array(1)) * tend_u(1,iEdge)
- hSum = grid % hZLevel % array(1)
+ do k=2,maxLevelEdgeTop(iEdge)
+ uhSum = uhSum + h_edge(k,iEdge) * tend_u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
+ enddo
- do k=2,grid % maxLevelEdgeTop % array(iEdge)
- uhSum = uhSum + grid % hZLevel % array(k) * tend_u(k,iEdge)
- hSum = hSum + grid % hZLevel % array(k)
- enddo
+ vertSum = uhSum/hSum
+ do k=1,maxLevelEdgeTop(iEdge)
+ tend_u(k,iEdge) = tend_u(k,iEdge) - vertSum
+ enddo
+ enddo ! iEdge
- vertSum = uhSum/hSum
-
- do k=1,grid % maxLevelEdgeTop % array(iEdge)
- tend_u(k,iEdge) = tend_u(k,iEdge) - vertSum
- enddo
-
- enddo ! iEdge
-
call mpas_timer_stop("filter_btr_mode_tend_u")
end subroutine filter_btr_mode_tend_u!}}}
@@ -1397,155 +1009,51 @@
type (state_type), intent(inout) :: s
type (mesh_type), intent(in) :: grid
-! mrp 110512 I just split compute_tend into compute_tend_u and compute_tend_h.
-! Some of these variables can be removed, but at a later time.
- integer :: iEdge, iCell, iVertex, k, cell1, cell2, &
- vertex1, vertex2, eoe, i, j
+ integer :: iEdge, k
integer :: nCells, nEdges, nVertices, nVertLevels, nEdgesSolve
- real (kind=RKIND) :: vertSum, uhSum, hSum, sshEdge
- real (kind=RKIND), dimension(:), pointer :: &
- h_s, fVertex, fEdge, dvEdge, dcEdge, areaCell, areaTriangle, &
- zMidZLevel, zTopZLevel, meshScalingDel2, meshScalingDel4
+ real (kind=RKIND) :: vertSum, uhSum, hSum
real (kind=RKIND), dimension(:,:), pointer :: &
- weightsOnEdge, kiteAreasOnVertex, h_edge, h, u, v, pressure, &
- tend_u, circulation, vorticity, ke, ke_edge, pv_edge, &
- MontPot, wTop, divergence, vertViscTopOfEdge
+ h_edge, h, u
type (dm_info) :: dminfo
- integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge, &
- maxLevelCell, maxLevelEdgeTop, maxLevelVertexBot
- integer, dimension(:,:), pointer :: &
- cellsOnEdge, cellsOnVertex, verticesOnEdge, edgesOnCell, &
- edgesOnEdge, edgesOnVertex
- real (kind=RKIND) :: u_diffusion
- real (kind=RKIND), dimension(:), allocatable:: fluxVertTop,w_dudzTopEdge
+ integer, dimension(:), pointer :: maxLevelEdgeTop
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_divergence
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_u
- real (kind=RKIND), allocatable, dimension(:,:) :: delsq_circulation, delsq_vorticity
-
-
- real (kind=RKIND), dimension(:,:), pointer :: u_src
- real (kind=RKIND), parameter :: rho_ref = 1000.0
-
call mpas_timer_start("filter_btr_mode_u")
h => s % h % array
u => s % u % array
- v => s % v % array
- wTop => s % wTop % array
h_edge => s % h_edge % array
- circulation => s % circulation % array
- vorticity => s % vorticity % array
- divergence => s % divergence % array
- ke => s % ke % array
- ke_edge => s % ke_edge % array
- pv_edge => s % pv_edge % array
- MontPot => s % MontPot % array
- pressure => s % pressure % array
- weightsOnEdge => grid % weightsOnEdge % array
- kiteAreasOnVertex => grid % kiteAreasOnVertex % array
- cellsOnEdge => grid % cellsOnEdge % array
- cellsOnVertex => grid % cellsOnVertex % array
- verticesOnEdge => grid % verticesOnEdge % array
- nEdgesOnCell => grid % nEdgesOnCell % array
- edgesOnCell => grid % edgesOnCell % array
- nEdgesOnEdge => grid % nEdgesOnEdge % array
- edgesOnEdge => grid % edgesOnEdge % array
- edgesOnVertex => grid % edgesOnVertex % array
- dcEdge => grid % dcEdge % array
- dvEdge => grid % dvEdge % array
- areaCell => grid % areaCell % array
- areaTriangle => grid % areaTriangle % array
- h_s => grid % h_s % array
-! mrp 110516 cleanup fvertex fedge not used in this subroutine
- fVertex => grid % fVertex % array
- fEdge => grid % fEdge % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
- maxLevelCell => grid % maxLevelCell % array
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- maxLevelVertexBot => grid % maxLevelVertexBot % array
nCells = grid % nCells
nEdges = grid % nEdges
- nEdgesSolve = grid % nEdgesSolve
- nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
- u_src => grid % u_src % array
+ do iEdge=1,nEdges
- do iEdge=1,grid % nEdges
+ ! hSum is initialized outside the loop because on land boundaries
+ ! maxLevelEdgeTop=0, but I want to initialize hSum with a
+ ! nonzero value to avoid a NaN.
+ uhSum = h_edge(1,iEdge) * u(1,iEdge)
+ hSum = h_edge(1,iEdge)
- ! I am using hZLevel here. This assumes that SSH is zero everywhere already,
- ! which should be the case if the barotropic mode is filtered.
- ! The more general case is to use sshedge or h_edge.
- uhSum = (grid % hZLevel % array(1)) * u(1,iEdge)
- hSum = grid % hZLevel % array(1)
+ do k=2,maxLevelEdgeTop(iEdge)
+ uhSum = uhSum + h_edge(k,iEdge) * u(k,iEdge)
+ hSum = hSum + h_edge(k,iEdge)
+ enddo
- do k=2,grid % maxLevelEdgeTop % array(iEdge)
- uhSum = uhSum + grid % hZLevel % array(k) * u(k,iEdge)
- hSum = hSum + grid % hZLevel % array(k)
- enddo
+ vertSum = uhSum/hSum
+ do k=1,maxLevelEdgeTop(iEdge)
+ u(k,iEdge) = u(k,iEdge) - vertSum
+ enddo
+ enddo ! iEdge
- vertSum = uhSum/hSum
- do k=1,grid % maxLevelEdgeTop % array(iEdge)
- u(k,iEdge) = u(k,iEdge) - vertSum
- enddo
-
- enddo ! iEdge
-
call mpas_timer_stop("filter_btr_mode_u")
end subroutine filter_btr_mode_u!}}}
- subroutine enforce_boundaryEdge(tend, grid)!{{{
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- ! Enforce any boundary conditions on the normal velocity at each edge
- !
- ! Input: grid - grid metadata
- !
- ! Output: tend_u set to zero at boundaryEdge == 1 locations
- !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- implicit none
-
- type (tend_type), intent(inout) :: tend
- type (mesh_type), intent(in) :: grid
-
- integer, dimension(:,:), pointer :: boundaryEdge
- real (kind=RKIND), dimension(:,:), pointer :: tend_u
- integer :: nCells, nEdges, nVertices, nVertLevels
- integer :: iEdge, k
-
- call mpas_timer_start("enforce_boundaryEdge")
-
- nCells = grid % nCells
- nEdges = grid % nEdges
- nVertices = grid % nVertices
- nVertLevels = grid % nVertLevels
-
- boundaryEdge => grid % boundaryEdge % array
- tend_u => tend % u % array
-
- if(maxval(boundaryEdge).le.0) return
-
- do iEdge = 1,nEdges
- do k = 1,nVertLevels
-
- if(boundaryEdge(k,iEdge).eq.1) then
- tend_u(k,iEdge) = 0.0
- endif
-
- enddo
- enddo
- call mpas_timer_stop("enforce_boundaryEdge")
-
- end subroutine enforce_boundaryEdge!}}}
-
end module ocn_time_integration_split
! vim: foldmethod=marker
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,316 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection
+!
+!> \brief MPAS ocean tracer advection driver
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains driver routine for tracer advection tendencys
+!> as well as the routines for setting up advection coefficients and
+!> initialization of the advection routines.
+!
+!-----------------------------------------------------------------------
+
+module mpas_ocn_tracer_advection
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+
+ use mpas_ocn_tracer_advection_std
+ use mpas_ocn_tracer_advection_mono
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_init, &
+ mpas_ocn_tracer_advection_coefficients, &
+ mpas_ocn_tracer_advection_tend
+
+ logical :: monotonicOn
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_coefficients
+!
+!> \brief MPAS ocean tracer advection coefficients
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine precomputes the advection coefficients for horizontal
+!> advection of tracers.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_coefficients( grid, err )!{{{
+
+ implicit none
+ type (mesh_type) :: grid !< Input: Grid information
+ integer, intent(out) :: err
+
+ real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
+ real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_2nd, adv_coefs_3rd
+ integer, dimension(:,:), pointer :: cellsOnCell, cellsOnEdge, advCellsForEdge, highOrderAdvectionMask, lowOrderAdvectionMask, boundaryCell
+ integer, dimension(:), pointer :: nEdgesOnCell, nAdvCellsForEdge, maxLevelCell
+
+ integer, dimension(:), pointer :: cell_list, ordered_cell_list
+ integer :: cell1, cell2, iEdge, n, i, j, j_in, iCell, k, nVertLevels
+ logical :: addcell, highOrderAdvection
+
+ deriv_two => grid % deriv_two % array
+ adv_coefs => grid % adv_coefs % array
+ adv_coefs_2nd => grid % adv_coefs_2nd % array
+ adv_coefs_3rd => grid % adv_coefs_3rd % array
+ cellsOnCell => grid % cellsOnCell % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ advCellsForEdge => grid % advCellsForEdge % array
+ boundaryCell => grid % boundaryCell % array
+ highOrderAdvectionMask => grid % highOrderAdvectionMask % array
+ lowOrderAdvectionMask => grid % lowOrderAdvectionMask % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ maxLevelCell => grid % maxLevelCell % array
+ nAdvCellsForEdge => grid % nAdvCellsForEdge % array
+
+ nVertLevels = grid % nVertLevels
+
+ allocate(cell_list(grid % maxEdges2 + 2))
+ allocate(ordered_cell_list(grid % maxEdges2 + 2))
+
+ err = 0
+
+ highOrderAdvectionMask = 0
+ lowOrderAdvectionMask = 0
+ if(config_horiz_tracer_adv_order == 2) then
+
+ end if
+
+ do iEdge = 1, grid % nEdges
+ nAdvCellsForEdge(iEdge) = 0
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+
+ do k = 1, nVertLevels
+ if (boundaryCell(k, cell1) == 1 .or. boundaryCell(k, cell2) == 1) then
+ highOrderAdvectionMask(k, iEdge) = 0
+ lowOrderAdvectionMask(k, iEdge) = 1
+ else
+ highOrderAdvectionMask(k, iEdge) = 1
+ lowOrderAdvectionMask(k, iEdge) = 0
+ end if
+ end do
+
+ !
+ ! do only if this edge flux is needed to update owned cells
+ !
+ if (cell1 <= grid%nCells .or. cell2 <= grid%nCells) then
+
+ cell_list(1) = cell1
+ cell_list(2) = cell2
+ n = 2
+
+ ! add cells surrounding cell 1. n is number of cells currently in list
+ do i = 1, nEdgesOnCell(cell1)
+ if(cellsOnCell(i,cell1) /= cell2) then
+ n = n + 1
+ cell_list(n) = cellsOnCell(i,cell1)
+ end if
+ end do
+
+ ! add cells surrounding cell 2 (brute force approach)
+ do iCell = 1, nEdgesOnCell(cell2)
+ addcell = .true.
+ do i=1,n
+ if(cell_list(i) == cellsOnCell(iCell,cell2)) addcell = .false.
+ end do
+ if(addcell) then
+ n = n+1
+ cell_list(n) = cellsOnCell(iCell,cell2)
+ end if
+ end do
+
+ ! order the list by increasing cell number (brute force approach)
+
+ do i=1,n
+ ordered_cell_list(i) = grid % nCells + 2
+ j_in = 1
+ do j=1,n
+ if(ordered_cell_list(i) > cell_list(j) ) then
+ j_in = j
+ ordered_cell_list(i) = cell_list(j)
+ end if
+ end do
+! ordered_cell_list(i) = cell_list(j_in)
+ cell_list(j_in) = grid % nCells + 3
+ end do
+
+ nAdvCellsForEdge(iEdge) = n
+ do iCell = 1, nAdvCellsForEdge(iEdge)
+ advCellsForEdge(iCell,iEdge) = ordered_cell_list(iCell)
+ end do
+
+ ! we have the ordered list, now construct coefficients
+
+ adv_coefs(:,iEdge) = 0.
+ adv_coefs_2nd(:,iEdge) = 0.
+ adv_coefs_3rd(:,iEdge) = 0.
+
+ ! pull together third and fourth order contributions to the flux
+ ! first from cell1
+
+ j_in = 0
+ do j=1, n
+ if( ordered_cell_list(j) == cell1 ) j_in = j
+ end do
+ adv_coefs (j_in,iEdge) = adv_coefs (j_in,iEdge) + deriv_two(1,1,iEdge)
+ adv_coefs_3rd(j_in,iEdge) = adv_coefs_3rd(j_in,iEdge) + deriv_two(1,1,iEdge)
+
+ do iCell = 1, nEdgesOnCell(cell1)
+ j_in = 0
+ do j=1, n
+ if( ordered_cell_list(j) == cellsOnCell(iCell,cell1) ) j_in = j
+ end do
+ adv_coefs (j_in,iEdge) = adv_coefs (j_in,iEdge) + deriv_two(iCell+1,1,iEdge)
+ adv_coefs_3rd(j_in,iEdge) = adv_coefs_3rd(j_in,iEdge) + deriv_two(iCell+1,1,iEdge)
+ end do
+
+ ! pull together third and fourth order contributions to the flux
+ ! now from cell2
+
+ j_in = 0
+ do j=1, n
+ if( ordered_cell_list(j) == cell2 ) j_in = j
+ enddo
+ adv_coefs (j_in,iEdge) = adv_coefs (j_in,iEdge) + deriv_two(1,2,iEdge)
+ adv_coefs_3rd(j_in,iEdge) = adv_coefs_3rd(j_in,iEdge) - deriv_two(1,2,iEdge)
+
+ do iCell = 1, nEdgesOnCell(cell2)
+ j_in = 0
+ do j=1, n
+ if( ordered_cell_list(j) == cellsOnCell(iCell,cell2) ) j_in = j
+ enddo
+ adv_coefs (j_in,iEdge) = adv_coefs (j_in,iEdge) + deriv_two(iCell+1,2,iEdge)
+ adv_coefs_3rd(j_in,iEdge) = adv_coefs_3rd(j_in,iEdge) - deriv_two(iCell+1,2,iEdge)
+ end do
+
+ do j = 1,n
+ adv_coefs (j,iEdge) = - (grid % dcEdge % array (iEdge) **2) * adv_coefs (j,iEdge) / 12.
+ adv_coefs_3rd(j,iEdge) = - (grid % dcEdge % array (iEdge) **2) * adv_coefs_3rd(j,iEdge) / 12.
+ end do
+
+ ! 2nd order centered contribution - place this in the main flux weights
+
+ j_in = 0
+ do j=1, n
+ if( ordered_cell_list(j) == cell1 ) j_in = j
+ enddo
+ adv_coefs(j_in,iEdge) = adv_coefs(j_in,iEdge) + 0.5
+ adv_coefs_2nd(j_in,iEdge) = adv_coefs_2nd(j_in,iEdge) + 0.5
+
+ j_in = 0
+ do j=1, n
+ if( ordered_cell_list(j) == cell2 ) j_in = j
+ enddo
+ adv_coefs(j_in,iEdge) = adv_coefs(j_in,iEdge) + 0.5
+ adv_coefs_2nd(j_in,iEdge) = adv_coefs_2nd(j_in,iEdge) + 0.5
+
+ ! multiply by edge length - thus the flux is just dt*ru times the results of the vector-vector multiply
+
+ do j=1,n
+ adv_coefs (j,iEdge) = grid % dvEdge % array(iEdge) * adv_coefs (j,iEdge)
+ adv_coefs_2nd(j,iEdge) = grid % dvEdge % array(iEdge) * adv_coefs_2nd(j,iEdge)
+ adv_coefs_3rd(j,iEdge) = grid % dvEdge % array(iEdge) * adv_coefs_3rd(j,iEdge)
+ end do
+
+ end if ! only do for edges of owned-cells
+
+ end do ! end loop over edges
+
+ deallocate(cell_list)
+ deallocate(ordered_cell_list)
+
+ ! If 2nd order advection, set masks appropriately.
+ if(config_horiz_tracer_adv_order == 2) then
+ lowOrderAdvectionMask = 1
+ highOrderAdvectionMask = 0
+ end if
+
+ if (maxval(highOrderAdvectionMask+lowOrderAdvectionMask) > 1) then
+ write(*,*) "Masks don't sum to 1."
+ err = 1
+ endif
+
+ end subroutine mpas_ocn_tracer_advection_coefficients!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_tend
+!
+!> \brief MPAS ocean tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine is the driver routine for computing the tendency for
+!> advection of tracers.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend)!{{{
+
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: tracer tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input/Output: tracer values
+ real (kind=RKIND), dimension(:,:), intent(in) :: uh !< Input: Thickness weighted horizontal velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: h !< Input: Thickness field
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell
+ real (kind=RKIND), intent(in) :: dt !< Input: Time step
+ type (mesh_type), intent(in) :: grid !< Input: grid information
+ real (kind=RKIND), dimension(:,:), intent(in) :: tend_h !< Input: Thickness tendency information
+
+ if(monotonicOn) then
+ call mpas_ocn_tracer_advection_mono_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend)
+ else
+ call mpas_ocn_tracer_advection_std_tend(tracers, uh, w, verticalCellSize, grid, tend)
+ endif
+ end subroutine mpas_ocn_tracer_advection_tend!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_init
+!
+!> \brief MPAS ocean tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine is the driver routine for initialization of
+!> the tracer advection routines.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_init(err)!{{{
+
+ integer, intent(inout) :: err !< Input/Output: Error flag
+
+ integer :: err_tmp
+
+ err = 0
+
+ call mpas_ocn_tracer_advection_std_init(err_tmp)
+ call mpas_ocn_tracer_advection_mono_init(err_tmp)
+
+ err = ior(err, err_tmp)
+
+ monotonicOn = .false.
+
+ if(config_monotonic) then
+ monotonicOn = .true.
+ endif
+
+ end subroutine mpas_ocn_tracer_advection_init!}}}
+
+end module mpas_ocn_tracer_advection
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_helpers.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_helpers.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_helpers.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_helpers.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,68 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_helpers
+!
+!> \brief MPAS ocean tracer advection helper functions
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains helper functions tracer advection.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_helpers
+
+ use mpas_kind_types
+
+ implicit none
+ save
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! function mpas_ocn_tracer_advection_vflux4
+!
+!> \brief MPAS ocean 4th order vertical tracer advection stencil
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This function provides the stencil for 4th order vertical advection of tracers.
+!
+!-----------------------------------------------------------------------
+ real function mpas_ocn_tracer_advection_vflux4(q_im2, q_im1, q_i, q_ip1, w)!{{{
+ real (kind=RKIND), intent(in) :: q_im2 !< Input: Tracer value at index i-2
+ real (kind=RKIND), intent(in) :: q_im1 !< Input: Tracer value at index i-1
+ real (kind=RKIND), intent(in) :: q_i !< Input: Tracer value at index i
+ real (kind=RKIND), intent(in) :: q_ip1 !< Input: Tracer value at index i+1
+ real (kind=RKIND), intent(in) :: w !< Input: vertical veloicity
+ mpas_ocn_tracer_advection_vflux4 = w*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0
+ end function!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! function mpas_ocn_tracer_advection_vflux3
+!
+!> \brief MPAS ocean 3rd order vertical tracer advection stencil
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This function provides the stencil for 3rd order vertical advection of tracers.
+!
+!-----------------------------------------------------------------------
+ real function mpas_ocn_tracer_advection_vflux3( q_im2, q_im1, q_i, q_ip1, w, coef)!{{{
+ real (kind=RKIND), intent(in) :: q_im2 !< Input: Tracer value at index i-2
+ real (kind=RKIND), intent(in) :: q_im1 !< Input: Tracer value at index i-1
+ real (kind=RKIND), intent(in) :: q_i !< Input: Tracer value at index i
+ real (kind=RKIND), intent(in) :: q_ip1 !< Input: Tracer value at index i+1
+ real (kind=RKIND), intent(in) :: w !< Input: vertical veloicity
+ real (kind=RKIND), intent(in) :: coef !< Input: Advection coefficient
+
+ !dwj 02/21/12 flux3 is different in ocean and atmosphere
+ !flux3 = (u * (7.0 * (q_i + q_im1) - (q_ip1 + q_im2)) + coef * abs(u) * ((q_ip1 - q_im2) - 3.0*(q_i-q_im1)))/12.0
+ mpas_ocn_tracer_advection_vflux3 = (w * (7.0 * (q_i + q_im1) - (q_ip1 + q_im2)) - coef * abs(w) * ((q_ip1 - q_im2) - 3.0*(q_i-q_im1)))/12.0
+ end function!}}}
+
+end module mpas_ocn_tracer_advection_helpers
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_mono.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_mono.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_mono.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_mono.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,382 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_mono
+!
+!> \brief MPAS ocean monotonic tracer advection with FCT
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains routines for monotonic advection of tracers using a FCT
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_mono
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+
+ use mpas_ocn_tracer_advection_helpers
+
+ implicit none
+ private
+ save
+
+ real (kind=RKIND) :: coef_3rd_order
+
+ public :: mpas_ocn_tracer_advection_mono_tend, &
+ mpas_ocn_tracer_advection_mono_init
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_mono_tend
+!
+!> \brief MPAS ocean monotonic tracer advection tendency with FCT
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the monotonic tracer advection tendencity using a FCT.
+!> Both horizontal and vertical.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_mono_tend(tracers, uh, w, h, verticalCellSize, dt, grid, tend_h, tend)!{{{
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: current tracer values
+ real (kind=RKIND), dimension(:,:), intent(in) :: uh !< Input: Thichness weighted velocitiy
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical velocitiy
+ real (kind=RKIND), dimension(:,:), intent(in) :: h !< Input: Thickness
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell
+ real (kind=RKIND), dimension(:,:), intent(in) :: tend_h !< Input: Tendency for thickness field
+ real (kind=RKIND), intent(in) :: dt !< Input: Timestep
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer tendency
+
+ integer :: i, iCell, iEdge, k, iTracer, cell1, cell2
+ integer :: nVertLevels, num_tracers, nCells, nEdges, nCellsSolve
+ integer, dimension(:), pointer :: nAdvCellsForEdge, maxLevelCell, maxLevelEdgeTop, nEdgesOnCell
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell, advCellsForEdge, highOrderAdvectionMask, lowOrderAdvectionMask
+
+ real (kind=RKIND) :: flux_upwind, tracer_min_new, tracer_max_new, tracer_upwind_new, scale_factor
+ real (kind=RKIND) :: flux, tracer_weight, invDvEdge, invAreaCell1, invAreaCell2
+ real (kind=RKIND) :: cur_max, cur_min, new_max, new_min
+ real (kind=RKIND) :: verticalWeightK, verticalWeightKm1
+ real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell
+ real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_2nd, adv_coefs_3rd
+ real (kind=RKIND), dimension(:,:), pointer :: tracer_cur, tracer_new, upwind_tendency, inv_h_new, tracer_max, tracer_min
+ real (kind=RKIND), dimension(:,:), pointer :: flux_incoming, flux_outgoing, high_order_horiz_flux, high_order_vert_flux
+
+ real (kind=RKIND), parameter :: eps = 1.e-10
+
+ ! Initialize pointers
+ dvEdge => grid % dvEdge % array
+ cellsOnEdge => grid % cellsOnEdge % array
+ cellsOnCell => grid % cellsOnCell % array
+ areaCell => grid % areaCell % array
+
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ nAdvCellsForEdge => grid % nAdvCellsForEdge % array
+ advCellsForEdge => grid % advCellsForEdge % array
+ adv_coefs => grid % adv_coefs % array
+ adv_coefs_2nd => grid % adv_coefs_2nd % array
+ adv_coefs_3rd => grid % adv_coefs_3rd % array
+ maxLevelCell => grid % maxLevelCell % array
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ highOrderAdvectionMask => grid % highOrderAdvectionMask % array
+ lowOrderAdvectionMask => grid % lowOrderAdvectionMask % array
+
+ nCells = grid % nCells
+ nCellsSolve = grid % nCellsSolve
+ nEdges = grid % nEdges
+ nVertLevels = grid % nVertLevels
+ num_tracers = size(tracers,dim=1)
+
+ ! allocate nCells arrays
+
+ allocate(tracer_new(nVertLevels, nCells))
+ allocate(tracer_cur(nVertLevels, nCells))
+ allocate(upwind_tendency(nVertLevels, nCells))
+ allocate(inv_h_new(nVertLevels, nCells))
+ allocate(tracer_max(nVertLevels, nCells))
+ allocate(tracer_min(nVertLevels, nCells))
+ allocate(flux_incoming(nVertLevels, nCells))
+ allocate(flux_outgoing(nVertLevels, nCells))
+
+ ! allocate nEdges arrays
+ allocate(high_order_horiz_flux(nVertLevels, nEdges))
+
+ ! allocate nVertLevels+1 and nCells arrays
+ allocate(high_order_vert_flux(nVertLevels+1, nCells))
+
+ do iCell = 1, nCells
+ do k=1, maxLevelCell(iCell)
+ inv_h_new(k, iCell) = 1.0 / (h(k, iCell) + dt * tend_h(k, iCell))
+ end do
+ end do
+
+ ! Loop over tracers. One tracer is advected at a time. It is copied into a temporary array in order to improve locality
+ do iTracer = 1, num_tracers
+ ! Initialize variables for use in this iTracer iteration
+ do iCell = 1, nCells
+ do k=1, maxLevelCell(iCell)
+ tracer_cur(k,iCell) = tracers(iTracer,k,iCell)
+ upwind_tendency(k, iCell) = 0.0
+
+ !tracer_new is supposed to be the "new" tracer state. This allows bounds checks.
+ if (config_check_monotonicity) then
+ tracer_new(k,iCell) = 0.0
+ end if
+ end do ! k loop
+ end do ! iCell loop
+
+ high_order_vert_flux = 0.0
+ high_order_horiz_flux = 0.0
+
+ ! Compute the high order vertical flux. Also determine bounds on tracer_cur.
+ do iCell = 1, nCells
+ k = 1
+ tracer_max(k,iCell) = max(tracer_cur(k,iCell),tracer_cur(k+1,iCell))
+ tracer_min(k,iCell) = min(tracer_cur(k,iCell),tracer_cur(k+1,iCell))
+
+ k = 2
+ verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell))
+ verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell))
+ high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell))
+ tracer_max(k,iCell) = max(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell))
+ tracer_min(k,iCell) = min(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell))
+
+ do k=3,maxLevelCell(iCell)-1
+ high_order_vert_flux(k,iCell) = mpas_ocn_tracer_advection_vflux3( tracer_cur(k-2,iCell),tracer_cur(k-1,iCell), &
+ tracer_cur(k ,iCell),tracer_cur(k+1,iCell), &
+ w(k,iCell), coef_3rd_order )
+ tracer_max(k,iCell) = max(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell))
+ tracer_min(k,iCell) = min(tracer_cur(k-1,iCell),tracer_cur(k,iCell),tracer_cur(k+1,iCell))
+ end do
+
+ k = maxLevelCell(iCell)
+ verticalWeightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell))
+ verticalWeightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k, iCell) + verticalCellSize(k-1, iCell))
+ high_order_vert_flux(k,iCell) = w(k,iCell)*(verticalWeightK*tracer_cur(k,iCell)+verticalWeightKm1*tracer_cur(k-1,iCell))
+ tracer_max(k,iCell) = max(tracer_cur(k,iCell),tracer_cur(k-1,iCell))
+ tracer_min(k,iCell) = min(tracer_cur(k,iCell),tracer_cur(k-1,iCell))
+
+ ! pull tracer_min and tracer_max from the (horizontal) surrounding cells
+ do i = 1, nEdgesOnCell(iCell)
+ do k=1, maxLevelCell(cellsOnCell(i, iCell))
+ tracer_max(k,iCell) = max(tracer_max(k,iCell),tracer_cur(k, cellsOnCell(i,iCell)))
+ tracer_min(k,iCell) = min(tracer_min(k,iCell),tracer_cur(k, cellsOnCell(i,iCell)))
+ end do ! k loop
+ end do ! i loop over nEdgesOnCell
+ end do ! iCell Loop
+
+ ! Compute the high order horizontal flux
+ do iEdge = 1, nEdges
+ do i = 1, nAdvCellsForEdge(iEdge)
+ iCell = advCellsForEdge(i,iEdge)
+ do k = 1, maxLevelCell(iCell)
+ tracer_weight = lowOrderAdvectionMask(k, iEdge) * adv_coefs_2nd(i,iEdge) &
+ + highOrderAdvectionMask(k, iEdge) * (adv_coefs(i,iEdge) + coef_3rd_order*sign(1.,uh(k,iEdge))*adv_coefs_3rd(i,iEdge))
+
+ tracer_weight = uh(k,iEdge)*tracer_weight
+ high_order_horiz_flux(k,iEdge) = high_order_horiz_flux(k,iEdge) + tracer_weight* tracer_cur(k,iCell)
+ end do ! k loop
+ end do ! i loop over nAdvCellsForEdge
+ end do ! iEdge loop
+
+ ! low order upwind vertical flux (monotonic and diffused)
+ ! Remove low order flux from the high order flux.
+ ! Store left over high order flux in high_order_vert_flux array.
+ ! Upwind fluxes are accumulated in upwind_tendency
+ do iCell = 1, nCells
+ do k = 2, maxLevelCell(iCell)
+ ! dwj 02/03/12 Ocean and Atmosphere are different in vertical
+! flux_upwind = max(0.,w(k,iCell))*tracer_cur(k-1,iCell) + min(0.,w(k,iCell))*tracer_cur(k,iCell)
+ flux_upwind = min(0.,w(k,iCell))*tracer_cur(k-1,iCell) + max(0.,w(k,iCell))*tracer_cur(k,iCell)
+ upwind_tendency(k-1,iCell) = upwind_tendency(k-1,iCell) + flux_upwind
+ upwind_tendency(k ,iCell) = upwind_tendency(k ,iCell) - flux_upwind
+ high_order_vert_flux(k,iCell) = high_order_vert_flux(k,iCell) - flux_upwind
+ end do ! k loop
+
+ ! flux_incoming contains the total remaining high order flux into iCell
+ ! it is positive.
+ ! flux_outgoing contains the total remaining high order flux out of iCell
+ ! it is negative
+ do k = 1, maxLevelCell(iCell)
+ ! dwj 02/03/12 Ocean and Atmosphere are different in vertical
+! flux_incoming (k,iCell) = -(min(0.,high_order_vert_flux(k+1,iCell))-max(0.,high_order_vert_flux(k,iCell)))
+! flux_outgoing(k,iCell) = -(max(0.,high_order_vert_flux(k+1,iCell))-min(0.,high_order_vert_flux(k,iCell)))
+
+ flux_incoming (k, iCell) = max(0.0, high_order_vert_flux(k+1, iCell)) - min(0.0, high_order_vert_flux(k, iCell))
+ flux_outgoing(k, iCell) = min(0.0, high_order_vert_flux(k+1, iCell)) - max(0.0, high_order_vert_flux(k, iCell))
+ end do ! k Loop
+ end do ! iCell Loop
+
+ ! low order upwind horizontal flux (monotinc and diffused)
+ ! Remove low order flux from the high order flux
+ ! Store left over high order flux in high_order_horiz_flux array
+ ! Upwind fluxes are accumulated in upwind_tendency
+ do iEdge = 1, nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
+
+ do k = 1, maxLevelEdgeTop(iEdge)
+ flux_upwind = dvEdge(iEdge) * (max(0.,uh(k,iEdge))*tracer_cur(k,cell1) + min(0.,uh(k,iEdge))*tracer_cur(k,cell2))
+ high_order_horiz_flux(k,iEdge) = high_order_horiz_flux(k,iEdge) - flux_upwind
+
+ upwind_tendency(k,cell1) = upwind_tendency(k,cell1) - flux_upwind * invAreaCell1
+ upwind_tendency(k,cell2) = upwind_tendency(k,cell2) + flux_upwind * invAreaCell2
+
+ ! Accumulate remaining high order fluxes
+ flux_outgoing(k,cell1) = flux_outgoing(k,cell1) - max(0.,high_order_horiz_flux(k,iEdge)) * invAreaCell1
+ flux_incoming (k,cell1) = flux_incoming (k,cell1) - min(0.,high_order_horiz_flux(k,iEdge)) * invAreaCell1
+ flux_outgoing(k,cell2) = flux_outgoing(k,cell2) + min(0.,high_order_horiz_flux(k,iEdge)) * invAreaCell2
+ flux_incoming (k,cell2) = flux_incoming (k,cell2) + max(0.,high_order_horiz_flux(k,iEdge)) * invAreaCell2
+ end do ! k loop
+ end do ! iEdge loop
+
+ ! Build the factors for the FCT
+ ! Computed using the bounds that were computed previously, and the bounds on the newly updated value
+ ! Factors are placed in the flux_incoming and flux_outgoing arrays
+ do iCell = 1, nCells
+ do k = 1, maxLevelCell(iCell)
+ tracer_min_new = (tracer_cur(k,iCell)*h(k,iCell) + dt*(upwind_tendency(k,iCell)+flux_outgoing(k,iCell))) * inv_h_new(k,iCell)
+ tracer_max_new = (tracer_cur(k,iCell)*h(k,iCell) + dt*(upwind_tendency(k,iCell)+flux_incoming(k,iCell))) * inv_h_new(k,iCell)
+ tracer_upwind_new = (tracer_cur(k,iCell)*h(k,iCell) + dt*upwind_tendency(k,iCell)) * inv_h_new(k,iCell)
+
+ scale_factor = (tracer_max(k,iCell)-tracer_upwind_new)/(tracer_max_new-tracer_upwind_new+eps)
+ flux_incoming(k,iCell) = min( 1.0, max( 0.0, scale_factor) )
+
+ scale_factor = (tracer_upwind_new-tracer_min(k,iCell))/(tracer_upwind_new-tracer_min_new+eps)
+ flux_outgoing(k,iCell) = min( 1.0, max( 0.0, scale_factor) )
+ end do ! k loop
+ end do ! iCell loop
+
+ ! rescale the high order horizontal fluxes
+ do iEdge = 1, nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ do k = 1, maxLevelEdgeTop(iEdge)
+ flux = high_order_horiz_flux(k,iEdge)
+ flux = max(0.,flux) * min(flux_outgoing(k,cell1), flux_incoming(k,cell2)) &
+ + min(0.,flux) * min(flux_incoming(k,cell1), flux_outgoing(k,cell2))
+ high_order_horiz_flux(k,iEdge) = flux
+ end do ! k loop
+ end do ! iEdge loop
+
+ ! rescale the high order vertical flux
+ do iCell = 1, nCellsSolve
+ do k = 2, maxLevelCell(iCell)
+ flux = high_order_vert_flux(k,iCell)
+ ! dwj 02/03/12 Ocean and Atmosphere are different in vertical.
+! flux = max(0.,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell)) &
+! + min(0.,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell))
+ flux = max(0.,flux) * min(flux_outgoing(k ,iCell), flux_incoming(k-1,iCell)) &
+ + min(0.,flux) * min(flux_outgoing(k-1,iCell), flux_incoming(k ,iCell))
+ high_order_vert_flux(k,iCell) = flux
+ end do ! k loop
+ end do ! iCell loop
+
+ ! Accumulate the scaled high order horizontal tendencies
+ do iEdge = 1, nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
+ do k=1,maxLevelEdgeTop(iEdge)
+ tend(iTracer, k, cell1) = tend(iTracer, k, cell1) - high_order_horiz_flux(k, iEdge) * invAreaCell1
+ tend(iTracer, k, cell2) = tend(iTracer, k, cell2) + high_order_horiz_flux(k, iEdge) * invAreaCell2
+
+ if (config_check_monotonicity) then
+ !tracer_new holds a tendency for now.
+ tracer_new(k, cell1) = tracer_new(k, cell1) - high_order_horiz_flux(k, iEdge) * invAreaCell1
+ tracer_new(k, cell2) = tracer_new(k, cell2) + high_order_horiz_flux(k, iEdge) * invAreaCell2
+ end if
+ end do ! k loop
+ end do ! iEdge loop
+
+ ! Accumulate the scaled high order vertical tendencies, and the upwind tendencies
+ do iCell = 1, nCellsSolve
+ do k = 1,maxLevelCell(iCell)
+ tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell)
+
+ if (config_check_monotonicity) then
+ !tracer_new holds a tendency for now. Only for a check on monotonicity
+ tracer_new(k, iCell) = tracer_new(k, iCell) + (high_order_vert_flux(k+1, iCell) - high_order_vert_flux(k, iCell)) + upwind_tendency(k,iCell)
+
+ !tracer_new is now the new state of the tracer. Only for a check on monotonicity
+ tracer_new(k, iCell) = (tracer_cur(k, iCell)*h(k, iCell) + dt * tracer_new(k, iCell)) * inv_h_new(k, iCell)
+ end if
+ end do ! k loop
+ end do ! iCell loop
+
+ if (config_check_monotonicity) then
+ !build min and max bounds on old and new tracer for check on monotonicity.
+ cur_min = minval(tracer_cur(:,1:nCellsSolve))
+ cur_max = maxval(tracer_cur(:,1:nCellsSolve))
+ new_min = minval(tracer_new(:,1:nCellsSolve))
+ new_max = maxval(tracer_new(:,1:nCellsSolve))
+
+ !check monotonicity
+ if(new_min < cur_min-eps) then
+ write(*,*) 'Minimum out of bounds on tracer ', iTracer, cur_min, new_min
+ end if
+
+ if(new_max > cur_max+eps) then
+ write(*,*) 'Maximum out of bounds on tracer ', iTracer, cur_max, new_max
+ end if
+ end if
+ end do ! iTracer loop
+
+ deallocate(tracer_new)
+ deallocate(tracer_cur)
+ deallocate(upwind_tendency)
+ deallocate(inv_h_new)
+ deallocate(tracer_max)
+ deallocate(tracer_min)
+ deallocate(flux_incoming)
+ deallocate(flux_outgoing)
+ deallocate(high_order_horiz_flux)
+ deallocate(high_order_vert_flux)
+ end subroutine mpas_ocn_tracer_advection_mono_tend!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_mono_init
+!
+!> \brief MPAS ocean initialize monotonic tracer advection tendency with FCT
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine initializes the monotonic tracer advection tendencity using a FCT.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_mono_init(err)!{{{
+ integer, intent(inout) :: err !< Input: Error Flags
+
+ integer :: err_tmp
+
+ err = 0
+
+ if ( config_horiz_tracer_adv_order == 3) then
+ coef_3rd_order = config_coef_3rd_order
+ else if(config_horiz_tracer_adv_order == 2 .or. config_horiz_tracer_adv_order == 4) then
+ coef_3rd_order = 0.0
+ end if
+
+ end subroutine mpas_ocn_tracer_advection_mono_init!}}}
+
+end module mpas_ocn_tracer_advection_mono
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_std.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,100 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_std
+!
+!> \brief MPAS ocean tracer advection driver (non-monotonic/fct)
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains driver routine for tracer advection tendencies
+!> as well as the routines for setting up advection coefficients and
+!> initialization of the advection routines.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_std
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+ use mpas_timer
+
+ use mpas_ocn_tracer_advection_std_hadv
+ use mpas_ocn_tracer_advection_std_vadv
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_std_tend, &
+ mpas_ocn_tracer_advection_std_init
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_tend
+!
+!> \brief MPAS ocean standard tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine is the driver routine for the standard computation of
+!> tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_tend(tracers, uh, w, verticalCellSize, grid, tend)!{{{
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !
+ ! Input: s - current model state
+ ! grid - grid metadata
+ !
+ ! Output: tend - computed scalar tendencies
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: Tracer values
+ real (kind=RKIND), dimension(:,:), intent(in) :: uh !< Input: Thickness weighted horizontal velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical Velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of a cell
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ call mpas_timer_start("tracer-hadv", .false.)
+ call mpas_ocn_tracer_advection_std_hadv_tend(tracers, uh, grid, tend)
+ call mpas_timer_stop("tracer-hadv")
+ call mpas_timer_start("tracer-vadv", .false.)
+ call mpas_ocn_tracer_advection_std_vadv_tend(tracers, w, verticalCellSize, grid, tend)
+ call mpas_timer_stop("tracer-vadv")
+
+ end subroutine mpas_ocn_tracer_advection_std_tend!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_init
+!
+!> \brief MPAS ocean standard tracer advection initialization
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine is the driver routine for the initializtion of the standard
+!> tracer advection routines.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_init(err)!{{{
+ integer, intent(inout) :: err !< Input: Error Flags
+
+ integer :: err_tmp
+
+ err = 0
+
+ call mpas_ocn_tracer_advection_std_hadv_init(err_tmp)
+ err = ior(err, err_tmp)
+ call mpas_ocn_tracer_advection_std_vadv_init(err_tmp)
+ err = ior(err, err_tmp)
+
+ end subroutine mpas_ocn_tracer_advection_std_init!}}}
+
+end module mpas_ocn_tracer_advection_std
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_hadv.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_std_hadv.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_hadv.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_hadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,140 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_std_hadv
+!
+!> \brief MPAS ocean standard horizontal tracer advection (non-monotonic/fct)
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains routines for horizontal tracer advection tendencies
+!> and initialization of the horizontal advection routines.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_std_hadv
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+
+ use mpas_ocn_tracer_advection_helpers
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_std_hadv_tend, &
+ mpas_ocn_tracer_advection_std_hadv_init
+
+ real (kind=RKIND) :: coef_3rd_order
+
+ logical :: hadvOn
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_hadv_tend
+!
+!> \brief MPAS ocean standard horizontal tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the tendency for 3rd order horizontal advection of tracers.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_hadv_tend(tracers, uh, grid, tend)!{{{
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/output: Tracer tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: Tracer values
+ real (kind=RKIND), dimension(:,:), intent(in) :: uh !< Input: Thickness weighted horizontal velocity
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ integer :: i, iCell, iEdge, k, iTracer, cell1, cell2
+ real (kind=RKIND) :: flux, tracer_weight
+
+ real (kind=RKIND), dimension(:), pointer :: areaCell
+ integer, dimension(:,:), pointer :: cellsOnEdge
+
+ integer, dimension(:,:), pointer :: advCellsForEdge, highOrderAdvectionMask, lowOrderAdvectionMask
+ integer, dimension(:), pointer :: nAdvCellsForEdge
+ real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_2nd, adv_coefs_3rd
+ real (kind=RKIND), dimension(:,:), allocatable :: flux_arr
+ integer :: nVertLevels, num_tracers
+
+ if (.not. hadvOn) return
+
+ cellsOnEdge => grid % cellsOnEdge % array
+ areaCell => grid % areaCell % array
+
+ nAdvCellsForEdge => grid % nAdvCellsForEdge % array
+ advCellsForEdge => grid % advCellsForEdge % array
+ adv_coefs => grid % adv_coefs % array
+ adv_coefs_2nd => grid % adv_coefs_2nd % array
+ adv_coefs_3rd => grid % adv_coefs_3rd % array
+ highOrderAdvectionMask => grid % highOrderAdvectionMask % array
+ lowOrderAdvectionMask => grid % lowOrderAdvectionMask % array
+
+ nVertLevels = grid % nVertLevels
+ num_tracers = size(tracers, dim=1)
+
+ allocate(flux_arr(num_tracers, grid % nVertLevels))
+
+ ! horizontal flux divergence, accumulate in tracer_tend
+ do iEdge=1,grid%nEdges
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ if (cell1 <= grid%nCellsSolve .or. cell2 <= grid%nCellsSolve) then ! only for owned cells
+ flux_arr(:,:) = 0.
+ do i=1,nAdvCellsForEdge(iEdge)
+ iCell = advCellsForEdge(i,iEdge)
+ do k=1,grid % nVertLevels
+ tracer_weight = lowOrderAdvectionMask(k, iEdge) * adv_coefs_2nd(i,iEdge) &
+ + highOrderAdvectionMask(k, iEdge) * (adv_coefs(i,iEdge) + coef_3rd_order*sign(1.,uh(k,iEdge))*adv_coefs_3rd(i,iEdge))
+ do iTracer=1,num_tracers
+ flux_arr(iTracer,k) = flux_arr(iTracer,k) + tracer_weight* tracers(iTracer,k,iCell)
+ end do
+ end do
+ end do
+
+ do k=1,grid % nVertLevels
+ do iTracer=1,num_tracers
+ tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - uh(k,iEdge)*flux_arr(iTracer,k)/areaCell(cell1)
+ tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + uh(k,iEdge)*flux_arr(iTracer,k)/areaCell(cell2)
+ end do
+ end do
+ end if
+ end do
+
+ deallocate(flux_arr)
+
+ end subroutine mpas_ocn_tracer_advection_std_hadv_tend!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_hadv_init
+!
+!> \brief MPAS ocean standard horizontal tracer advection initialization
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine initializes the 3rd order standard horizontal advection of tracers
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_hadv_init(err)!{{{
+ integer, intent(inout) :: err !< Input/Output: Error flag
+
+ err = 0
+
+ hadvOn =.true.
+
+ if ( config_horiz_tracer_adv_order == 3) then
+ coef_3rd_order = config_coef_3rd_order
+ else if ( config_horiz_tracer_adv_order == 2 .or. config_horiz_tracer_adv_order == 4) then
+ coef_3rd_order = 0.0
+ end if
+ end subroutine mpas_ocn_tracer_advection_std_hadv_init!}}}
+
+end module mpas_ocn_tracer_advection_std_hadv
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_std_vadv.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,103 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_std_vadv
+!
+!> \brief MPAS ocean vertical tracer advection driver (non-monotonic/fct)
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains driver routines for vertical tracer advection tendencies
+!> and initialization of the advection routines.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_std_vadv
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+
+ use mpas_ocn_tracer_advection_std_vadv2
+ use mpas_ocn_tracer_advection_std_vadv3
+ use mpas_ocn_tracer_advection_std_vadv4
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_std_vadv_tend, &
+ mpas_ocn_tracer_advection_std_vadv_init
+
+ logical :: order2, order3, order4
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_vadv_tend
+!
+!> \brief MPAS ocean standard vertical tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine is the driver routine for the standard computation of
+!> vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_vadv_tend(tracers, w, verticalCellSize, grid, tend)!{{{
+
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer Tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: Tracer Values
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical Velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of cell
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ if(order2) then
+ call mpas_ocn_tracer_advection_std_vadv2_tend(tracers, w, verticalCellSize, grid, tend)
+ else if(order3) then
+ call mpas_ocn_tracer_advection_std_vadv3_tend(tracers, w, verticalCellSize, grid, tend)
+ else if(order4) then
+ call mpas_ocn_tracer_advection_std_vadv4_tend(tracers, w, verticalCellSize, grid, tend)
+ endif
+
+ end subroutine mpas_ocn_tracer_advection_std_vadv_tend!}}}
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_vadv_init
+!
+!> \brief MPAS ocean standard vertical tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine initializes the vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_vadv_init(err)!{{{
+ integer, intent(inout) :: err !< Input/Output: Error flag
+
+ err = 0
+
+ order2 = .false.
+ order3 = .false.
+ order4 = .false.
+
+ if (config_vert_tracer_adv_order == 2) then
+ order2 = .true.
+ else if (config_vert_tracer_adv_order == 3) then
+ order3 = .true.
+ else if (config_vert_tracer_adv_order == 4) then
+ order4 = .true.
+ else
+ print *, 'invalid value for config_tracer_vadv_order'
+ print *, 'options are 2, 3, or 4'
+ err = 1
+ endif
+
+ end subroutine mpas_ocn_tracer_advection_std_vadv_init!}}}
+
+end module mpas_ocn_tracer_advection_std_vadv
+
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv2.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_std_vadv2.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv2.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv2.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,96 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_std_vadv2
+!
+!> \brief MPAS ocean 2nd order vertical tracer advection driver (non-monotonic/fct)
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains routines for 2nd order vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_std_vadv2
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+
+ use mpas_ocn_tracer_advection_helpers
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_std_vadv2_tend
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_vadv2_tend
+!
+!> \brief MPAS ocean 2nd order standard vertical tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine is the driver routine for the 2nd order standard computation of
+!> vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_vadv2_tend(tracers, w, verticalCellSize, grid, tend)!{{{
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: tracer tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: Tracer values
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical Velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of cell
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ integer :: i, iCell, iEdge, k, iTracer, cell1, cell2
+ real (kind=RKIND) :: flux, tracer_edge, tracer_weight
+ real (kind=RKIND) :: tracer_weight_cell1, tracer_weight_cell2
+
+
+ real (kind=RKIND), dimension(:,:), allocatable :: vert_flux
+ real (kind=RKIND) :: weightK, weightKm1
+ integer :: nVertLevels, num_tracers
+ integer, dimension(:), pointer :: maxLevelCell
+
+ nVertLevels = grid % nVertLevels
+ num_tracers = size(tracers, dim=1)
+ maxLevelCell => grid % maxLevelCell % array
+
+ allocate(vert_flux(num_tracers, nVertLevels+1))
+
+ !
+ ! vertical flux divergence
+ !
+
+ ! zero fluxes at top and bottom
+
+ vert_flux(:,1) = 0.
+
+ do iCell=1,grid % nCellsSolve
+ do k = 2, maxLevelCell(iCell)
+ do iTracer=1,num_tracers
+ weightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ weightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ vert_flux(iTracer,k) = w(k,iCell)*(weightK*tracers(iTracer,k,iCell)+weightKm1*tracers(iTracer,k-1,iCell))
+ end do
+ end do
+
+ vert_flux(:,maxLevelCell(iCell)+1) = 0
+
+ do k=1,maxLevelCell(iCell)
+ do iTracer=1,num_tracers
+ tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + ( vert_flux(iTracer, k+1) - vert_flux(iTracer, k))
+ end do
+ end do
+ end do
+
+ deallocate(vert_flux)
+
+ end subroutine mpas_ocn_tracer_advection_std_vadv2_tend!}}}
+
+end module mpas_ocn_tracer_advection_std_vadv2
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv3.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_std_vadv3.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv3.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv3.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,106 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_std_vadv3
+!
+!> \brief MPAS ocean 3rd order vertical tracer advection driver (non-monotonic/fct)
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains routines for 3rd order vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_std_vadv3
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+
+ use mpas_ocn_tracer_advection_helpers
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_std_vadv3_tend
+
+ real (kind=RKIND) :: coef_3rd_order
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_vadv3_tend
+!
+!> \brief MPAS ocean 3rd order standard vertical tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the 3rd order vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_vadv3_tend(tracers, w, verticalCellSize, grid, tend)!{{{
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer Tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: Tracer Values
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical Velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of cell
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ integer :: i, iCell, iEdge, k, iTracer, cell1, cell2
+
+ real (kind=RKIND), dimension(:,:), allocatable :: vert_flux
+ real (kind=RKIND) :: weightK, weightKm1
+ integer :: nVertLevels, num_tracers
+ integer, dimension(:), pointer :: maxLevelCell
+
+ coef_3rd_order = config_coef_3rd_order
+
+ nVertLevels = grid % nVertLevels
+ num_tracers = size(tracers, dim=1)
+ maxLevelCell => grid % maxLevelCell % array
+
+ allocate(vert_flux(num_tracers, nVertLevels+1))
+
+ vert_flux(:,1) = 0.
+
+ do iCell=1,grid % nCellsSolve
+
+ k = 2
+ do iTracer=1,num_tracers
+ weightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ weightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ vert_flux(iTracer,k) = w(k,iCell)*(weightK*tracers(iTracer,k,iCell)+weightKm1*tracers(iTracer,k-1,iCell))
+ enddo
+
+ do k=3,maxLevelCell(iCell)-1
+ do iTracer=1,num_tracers
+ vert_flux(iTracer,k) = mpas_ocn_tracer_advection_vflux3( tracers(iTracer,k-2,iCell),tracers(iTracer,k-1,iCell), &
+ tracers(iTracer,k ,iCell),tracers(iTracer,k+1,iCell), &
+ w(k,iCell), coef_3rd_order )
+ end do
+ end do
+
+ k = maxLevelCell(iCell)
+
+ do iTracer=1,num_tracers
+ weightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ weightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ vert_flux(iTracer,k) = w(k,iCell)*(weightK*tracers(iTracer,k,iCell)+weightKm1*tracers(iTracer,k-1,iCell))
+ enddo
+
+ vert_Flux(:, maxLevelCell(iCell)+1) = 0.0
+
+ do k=1,maxLevelCell(iCell)
+ do iTracer=1,num_tracers
+ tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + (vert_flux(iTracer, k+1) - vert_flux(iTracer, k))
+ end do
+ end do
+ end do
+
+ deallocate(vert_flux)
+
+ end subroutine mpas_ocn_tracer_advection_std_vadv3_tend!}}}
+
+end module mpas_ocn_tracer_advection_std_vadv3
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv4.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_tracer_advection_std_vadv4.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv4.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_advection_std_vadv4.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,105 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_tracer_advection_std_vadv4
+!
+!> \brief MPAS ocean 4th order vertical tracer advection driver (non-monotonic/fct)
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This module contains routines for 4th order vertical tracer advection.
+!
+!-----------------------------------------------------------------------
+module mpas_ocn_tracer_advection_std_vadv4
+
+ use mpas_kind_types
+ use mpas_grid_types
+ use mpas_configure
+ use mpas_dmpar
+
+ use mpas_ocn_tracer_advection_helpers
+
+ implicit none
+ private
+ save
+
+ public :: mpas_ocn_tracer_advection_std_vadv4_tend
+
+ contains
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! routine mpas_ocn_tracer_advection_std_vadv4_tend
+!
+!> \brief MPAS ocean 4th order standard vertical tracer advection tendency
+!> \author Doug Jacobsen
+!> \date 03/09/12
+!> \version SVN:$Id:$
+!> \details
+!> This routine computes the 4th order vertical tracer advection tendencies.
+!
+!-----------------------------------------------------------------------
+ subroutine mpas_ocn_tracer_advection_std_vadv4_tend(tracers, w, verticalCellSize, grid, tend)!{{{
+ real (kind=RKIND), dimension(:,:,:), intent(inout) :: tend !< Input/Output: Tracer tendency
+ real (kind=RKIND), dimension(:,:,:), intent(in) :: tracers !< Input: Tracer Values
+ real (kind=RKIND), dimension(:,:), intent(in) :: w !< Input: Vertical Velocity
+ real (kind=RKIND), dimension(:,:), intent(in) :: verticalCellSize !< Input: Distance between vertical interfaces of cell
+ type (mesh_type), intent(in) :: grid !< Input: Grid information
+
+ integer :: i, iCell, iEdge, k, iTracer, cell1, cell2
+
+ real (kind=RKIND), dimension(:,:), allocatable :: vert_flux
+ real (kind=RKIND) :: weightK, weightKm1
+ integer :: nVertLevels, num_tracers
+ integer, dimension(:), pointer :: maxLevelCell
+
+ nVertLevels = grid % nVertLevels
+ num_tracers = size(tracers, dim=1)
+ maxLevelCell => grid % maxLevelCell % array
+
+ allocate(vert_flux(num_tracers, nVertLevels+1))
+
+ ! vertical flux divergence
+ !
+
+ ! zero fluxes at top and bottom
+
+ vert_flux(:,1) = 0.
+
+ do iCell=1,grid % nCellsSolve
+
+ k = 2
+ do iTracer=1,num_tracers
+ weightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ weightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ vert_flux(iTracer,k) = w(k,iCell)*(weightK*tracers(iTracer,k,iCell)+weightKm1*tracers(iTracer,k-1,iCell))
+ enddo
+ do k=3,nVertLevels-1
+ do iTracer=1,num_tracers
+ vert_flux(iTracer,k) = mpas_ocn_tracer_advection_vflux4( tracers(iTracer,k-2,iCell),tracers(iTracer,k-1,iCell), &
+ tracers(iTracer,k ,iCell),tracers(iTracer,k+1,iCell), w(k,iCell) )
+ end do
+ end do
+
+ k = maxLevelCell(iCell)
+ do iTracer=1,num_tracers
+ weightK = verticalCellSize(k-1, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ weightKm1 = verticalCellSize(k, iCell) / (verticalCellSize(k-1, iCell) + verticalCellSize(k, iCell))
+ vert_flux(iTracer,k) = w(k,iCell)*(weightK*tracers(iTracer,k,iCell)+weightKm1*tracers(iTracer,k-1,iCell))
+ enddo
+
+ vert_flux(:,maxLevelCell(iCell)+1) = 0.0
+
+ do k=1,maxLevelCell(iCell)
+ do iTracer=1,num_tracers
+ tend(iTracer, k, iCell) = tend(iTracer, k, iCell) + (vert_flux(iTracer, k+1) - vert_flux(iTracer, k))
+ end do
+ end do
+
+ end do
+
+ deallocate(vert_flux)
+
+ end subroutine mpas_ocn_tracer_advection_std_vadv4_tend!}}}
+
+end module mpas_ocn_tracer_advection_std_vadv4
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,6 +16,7 @@
use mpas_grid_types
use mpas_configure
+ use mpas_timer
use ocn_tracer_hadv2
use ocn_tracer_hadv3
@@ -46,7 +47,9 @@
!
!--------------------------------------------------------------------
+ type (timer_node), pointer :: hadv2Timer, hadv3Timer, hadv4Timer
+
!***********************************************************************
contains
@@ -122,9 +125,15 @@
!
!-----------------------------------------------------------------
+ call mpas_timer_start("hadv2", .false., hadv2Timer);
call ocn_tracer_hadv2_tend(grid, u, h_edge, tracers, tend, err1)
+ call mpas_timer_stop("hadv2", hadv2Timer);
+ call mpas_timer_start("hadv3", .false., hadv3Timer);
call ocn_tracer_hadv3_tend(grid, u, h_edge, tracers, tend, err2)
+ call mpas_timer_stop("hadv3", hadv3Timer);
+ call mpas_timer_start("hadv4", .false., hadv4Timer);
call ocn_tracer_hadv4_tend(grid, u, h_edge, tracers, tend, err3)
+ call mpas_timer_stop("hadv4", hadv4Timer);
err = ior(err1, ior(err2, err3))
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv2.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv2.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv2.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -111,7 +110,7 @@
integer, dimension(:), pointer :: maxLevelEdgeTop
integer, dimension(:,:), pointer :: cellsOnEdge
- real (kind=RKIND) :: flux, tracer_edge
+ real (kind=RKIND) :: flux, tracer_edge, invAreaCell1, invAreaCell2, r_tmp
real (kind=RKIND), dimension(:), pointer :: dvEdge, areaCell
@@ -127,8 +126,6 @@
if(.not.hadv2On) return
- call mpas_timer_start("compute_scalar_tend-horiz adv 2")
-
nEdges = grid % nEdges
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
@@ -139,17 +136,19 @@
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
do k=1,maxLevelEdgeTop(iEdge)
+ r_tmp = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge)
do iTracer=1,num_tracers
tracer_edge = 0.5 * (tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2))
- flux = u(k,iEdge) * dvEdge(iEdge) * h_edge(k,iEdge) * tracer_edge
- tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux/areaCell(cell1)
- tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ flux = r_tmp * tracer_edge
+ tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux * invAreaCell1
+ tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux * invAreaCell2
end do
end do
end do
-
- call mpas_timer_stop("compute_scalar_tend-horiz adv 2")
!--------------------------------------------------------------------
end subroutine ocn_tracer_hadv2_tend!}}}
@@ -183,7 +182,7 @@
err = 0
hadv2On = .false.
- if (config_tracer_adv_order == 2) then
+ if (config_horiz_tracer_adv_order == 2) then
hadv2On = .true.
end if
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv3.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv3.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv3.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -107,13 +106,15 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, nEdges, cell1, cell2, iTracer, num_tracers, i, k
+ integer :: iEdge, nEdges, cell1, cell2, iTracer, num_tracers, i, k, &
+ boundaryMask, velMask
integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell
integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell, &
- boundaryCell
+ cellMask, edgeMask
- real (kind=RKIND) :: flux, tracer_edge, d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND) :: flux, tracer_edge, d2fdx2_cell1, d2fdx2_cell2, &
+ invAreaCell1, invAreaCell2
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
@@ -134,7 +135,7 @@
num_tracers = size(tracers, dim=1)
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
nEdgesOnCell => grid % nEdgesOnCell % array
- boundaryCell => grid % boundaryCell % array
+ cellMask => grid % cellMask % array
cellsOnEdge => grid % cellsOnEdge % array
cellsOnCell => grid % cellsOnCell % array
dvEdge => grid % dvEdge % array
@@ -142,60 +143,51 @@
areaCell => grid % areaCell % array
deriv_two => grid % deriv_two % array
- call mpas_timer_start("compute_scalar_tend-horiz adv 3")
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
+
do k=1,maxLevelEdgeTop(iEdge)
d2fdx2_cell1 = 0.0
d2fdx2_cell2 = 0.0
+ boundaryMask = abs(transfer(cellMask(k,cell1) == 1 .and. cellMask(k,cell2) == 1,boundaryMask))
+
do iTracer=1,num_tracers
!-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1) * boundaryMask
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2) * boundaryMask
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+ !-- all edges of cell 1
+ do i=1,nEdgesOnCell(cell1) * boundaryMask
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell1))
+ end do
- !-- all edges of cell 1
- do i=1,nEdgesOnCell(cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell1))
- end do
+ !-- all edges of cell 2
+ do i=1,nEdgesOnCell(cell2) * boundaryMask
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell2))
+ end do
- !-- all edges of cell 2
- do i=1,nEdgesOnCell(cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell2))
- end do
- endif
+ velMask = 2*(abs(transfer(u(k,iEdge) <= 0, velMask))) - 1
+ flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
+ 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
+ -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
+ +velMask*(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- !-- if u > 0:
- if (u(k,iEdge) > 0) then
- flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
- 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- -(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- !-- else u <= 0:
- else
- flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
- 0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
- -(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. &
- +(dcEdge(iEdge) **2) * coef_3rd_order*(d2fdx2_cell1 - d2fdx2_cell2) / 12. )
- end if
-
!-- update tendency
- tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux/areaCell(cell1)
- tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux*invAreaCell1
+ tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux*invAreaCell2
enddo
end do
end do
- call mpas_timer_stop("compute_scalar_tend-horiz adv 3")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_hadv3_tend!}}}
@@ -229,11 +221,10 @@
err = 0
hadv3On = .false.
- if (config_tracer_adv_order == 3) then
+ if (config_horiz_tracer_adv_order == 3) then
hadv3On = .true.
- coef_3rd_order = 1.0
- if (config_monotonic) coef_3rd_order = 0.25
+ coef_3rd_order = config_coef_3rd_order
end if
!--------------------------------------------------------------------
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv4.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv4.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hadv4.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -106,12 +105,13 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, nEdges, cell1, cell2, iTracer, num_tracers, i, k
+ integer :: iEdge, nEdges, cell1, cell2, iTracer, num_tracers, i, k, &
+ boundaryMask
- integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell, boundaryCell
+ integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnCell
+ integer, dimension(:,:), pointer :: cellsOnEdge, cellsOnCell, cellMask
- real (kind=RKIND) :: flux, tracer_edge, d2fdx2_cell1, d2fdx2_cell2
+ real (kind=RKIND) :: flux, tracer_edge, d2fdx2_cell1, d2fdx2_cell2, invAreaCell1, invAreaCell2
real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell
real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two
@@ -131,7 +131,8 @@
nEdges = grid % nEdges
num_tracers = size(tracers, dim=1)
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
- boundaryCell => grid % boundaryCell % array
+ nEdgesOnCell => grid % nEdgesOnCell % array
+ cellMask => grid % cellMask % array
cellsOnEdge => grid % cellsOnEdge % array
cellsOnCell => grid % cellsOnCell % array
dvEdge => grid % dvEdge % array
@@ -139,51 +140,46 @@
areaCell => grid % areaCell % array
deriv_two => grid % deriv_two % array
- call mpas_timer_start("compute_scalar_tend-horiz adv 4")
-
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
+
do k=1,maxLevelEdgeTop(iEdge)
d2fdx2_cell1 = 0.0
d2fdx2_cell2 = 0.0
+ boundaryMask = abs(transfer(cellMask(k,cell1) == 1 .and. cellMask(k, cell2) == 1, boundaryMask))
+
do iTracer=1,num_tracers
+ d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1) * boundaryMask
+ d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2) * boundaryMask
- !-- if not a boundary cell
- if(boundaryCell(k,cell1).eq.0.and.boundaryCell(k,cell2).eq.0) then
+ !-- all edges of cell 1
+ do i=1,nEdgesOnCell(cell1) * boundaryMask
+ d2fdx2_cell1 = d2fdx2_cell1 + &
+ deriv_two(i+1,1,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell1))
+ end do
- d2fdx2_cell1 = deriv_two(1,1,iEdge) * tracers(iTracer,k,cell1)
- d2fdx2_cell2 = deriv_two(1,2,iEdge) * tracers(iTracer,k,cell2)
+ !-- all edges of cell 2
+ do i=1,nEdgesOnCell(cell2) * boundaryMask
+ d2fdx2_cell2 = d2fdx2_cell2 + &
+ deriv_two(i+1,2,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell2))
+ end do
- !-- all edges of cell 1
- do i=1, grid % nEdgesOnCell % array (cell1)
- d2fdx2_cell1 = d2fdx2_cell1 + &
- deriv_two(i+1,1,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell1))
- end do
-
- !-- all edges of cell 2
- do i=1, grid % nEdgesOnCell % array (cell2)
- d2fdx2_cell2 = d2fdx2_cell2 + &
- deriv_two(i+1,2,iEdge) * tracers(iTracer,k,cellsOnCell(i,cell2))
- end do
-
- endif
-
flux = dvEdge(iEdge) * u(k,iEdge) * h_edge(k,iEdge) * ( &
0.5*(tracers(iTracer,k,cell1) + tracers(iTracer,k,cell2)) &
-(dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12. )
!-- update tendency
- tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux/areaCell(cell1)
- tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux/areaCell(cell2)
+ tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux * invAreaCell1
+ tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux * invAreaCell2
enddo
end do
end do
- call mpas_timer_stop("compute_scalar_tend-horiz adv 4")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_hadv4_tend!}}}
@@ -217,7 +213,7 @@
err = 0
hadv4On = .false.
- if (config_tracer_adv_order == 4) then
+ if (config_horiz_tracer_adv_order == 4) then
hadv4On = .true.
end if
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -18,6 +18,7 @@
use mpas_grid_types
use mpas_configure
+ use mpas_timer
use ocn_tracer_hmix_del2
use ocn_tracer_hmix_del4
@@ -46,7 +47,9 @@
!
!--------------------------------------------------------------------
+ type (timer_node), pointer :: del2Timer, del4Timer
+
!***********************************************************************
contains
@@ -119,8 +122,12 @@
!
!-----------------------------------------------------------------
+ call mpas_timer_start("del2", .false., del2Timer)
call ocn_tracer_hmix_del2_tend(grid, h_edge, tracers, tend, err1)
+ call mpas_timer_stop("del2", del2Timer)
+ call mpas_timer_start("del4", .false., del4Timer)
call ocn_tracer_hmix_del4_tend(grid, h_edge, tracers, tend, err2)
+ call mpas_timer_stop("del4", del4Timer)
err = ior(err1, err2)
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix_del2.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix_del2.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -18,7 +18,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -114,10 +113,10 @@
integer, dimension(:,:), allocatable :: boundaryMask
integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: cellsOnEdge, boundaryEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask
real (kind=RKIND) :: invAreaCell1, invAreaCell2
- real (kind=RKIND) :: tracer_turb_flux, flux
+ real (kind=RKIND) :: tracer_turb_flux, flux, r_tmp
real (kind=RKIND), dimension(:), pointer :: areaCell, dvEdge, dcEdge
real (kind=RKIND), dimension(:), pointer :: meshScalingDel2
@@ -134,15 +133,13 @@
if (.not.del2On) return
- call mpas_timer_start("compute_scalar_tend-horiz diff 2")
-
nEdges = grid % nEdges
nVertLevels = grid % nVertLevels
num_tracers = size(tracers, dim=1)
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
- boundaryEdge => grid % boundaryEdge % array
+ edgeMask => grid % edgeMask % array
areaCell => grid % areaCell % array
dvEdge => grid % dvEdge % array
dcEdge => grid % dcEdge % array
@@ -151,36 +148,28 @@
!
! compute a boundary mask to enforce insulating boundary conditions in the horizontal
!
- allocate(boundaryMask(nVertLevels, nEdges+1))
- boundaryMask = 1.0
- where(boundaryEdge.eq.1) boundaryMask=0.0
-
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
invAreaCell1 = 1.0/areaCell(cell1)
invAreaCell2 = 1.0/areaCell(cell2)
+ r_tmp = meshScalingDel2(iEdge) * eddyDiff2 * dvEdge(iEdge) / dcEdge(iEdge)
+
do k=1,maxLevelEdgeTop(iEdge)
do iTracer=1,num_tracers
! \kappa_2 </font>
<font color="red">abla \phi on edge
- tracer_turb_flux = meshScalingDel2(iEdge) * eddyDiff2 &
- *( tracers(iTracer,k,cell2) &
- - tracers(iTracer,k,cell1))/dcEdge(iEdge)
+ tracer_turb_flux = tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)
! div(h \kappa_2 </font>
<font color="gray">abla \phi) at cell center
- flux = dvEdge (iEdge) * h_edge(k,iEdge) &
- * tracer_turb_flux * boundaryMask(k, iEdge)
+ flux = h_edge(k,iEdge) * tracer_turb_flux * edgeMask(k, iEdge) * r_tmp
+
tend(iTracer,k,cell1) = tend(iTracer,k,cell1) + flux * invAreaCell1
tend(iTracer,k,cell2) = tend(iTracer,k,cell2) - flux * invAreaCell2
end do
end do
end do
-
- deallocate(boundaryMask)
- call mpas_timer_stop("compute_scalar_tend-horiz diff 2")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_hmix_del2_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix_del4.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_hmix_del4.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -18,7 +18,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -45,7 +44,7 @@
!
!--------------------------------------------------------------------
- logical :: Del4On
+ logical :: del4On
real (kind=RKIND) :: eddyDiff4
@@ -111,12 +110,10 @@
integer :: iEdge, nEdges, num_tracers, nVertLevels, nCells
integer :: iTracer, k, iCell, cell1, cell2
- integer, dimension(:,:), allocatable :: boundaryMask
-
integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelCell
- integer, dimension(:,:), pointer :: boundaryEdge, cellsOnEdge
+ integer, dimension(:,:), pointer :: edgeMask, cellsOnEdge
- real (kind=RKIND) :: invAreaCell1, invAreaCell2, r, tracer_turb_flux, flux
+ real (kind=RKIND) :: invAreaCell1, invAreaCell2, tracer_turb_flux, flux, invdcEdge, r_tmp1, r_tmp2
real (kind=RKIND), dimension(:,:,:), allocatable :: delsq_tracer
@@ -133,10 +130,8 @@
err = 0
- if (.not.Del4On) return
+ if (.not.del4On) return
- call mpas_timer_start("compute_scalar_tend-horiz diff 4")
-
nEdges = grid % nEdges
nCells = grid % nCells
num_tracers = size(tracers, dim=1)
@@ -144,7 +139,6 @@
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
maxLevelCell => grid % maxLevelCell % array
- boundaryEdge => grid % boundaryEdge % array
cellsOnEdge => grid % cellsOnEdge % array
dcEdge => grid % dcEdge % array
@@ -152,67 +146,61 @@
areaCell => grid % areaCell % array
meshScalingDel4 => grid % meshScalingDel4 % array
- allocate(boundaryMask(nVertLevels, nEdges+1))
- boundaryMask = 1.0
- where(boundaryEdge.eq.1) boundaryMask=0.0
+ edgeMask => grid % edgeMask % array
allocate(delsq_tracer(num_tracers,nVertLevels, nCells+1))
- delsq_tracer(:,:,:) = 0.
+ delsq_tracer(:,:,:) = 0.0
! first del2: div(h </font>
<font color="red">abla \phi) at cell center
do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+ invdcEdge = 1.0 / dcEdge(iEdge)
+
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
+
do k=1,maxLevelEdgeTop(iEdge)
- do iTracer=1,num_tracers
- delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) &
- + dvEdge(iEdge)*h_edge(k,iEdge) &
- *(tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) &
- /dcEdge(iEdge) * boundaryMask(k,iEdge)
- delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) &
- - dvEdge(iEdge)*h_edge(k,iEdge) &
- *(tracers(iTracer,k,cell2) - tracers(iTracer,k,cell1)) &
- /dcEdge(iEdge) * boundaryMask(k,iEdge)
+ do iTracer=1,num_tracers * edgeMask(k, iEdge)
+
+ r_tmp1 = dvEdge(iEdge) * h_edge(k,iEdge) * invdcEdge
+
+ r_tmp2 = r_tmp1 * tracers(iTracer,k,cell2)
+ r_tmp1 = r_tmp1 * tracers(iTracer,k,cell1)
+
+ delsq_tracer(iTracer,k,cell1) = delsq_tracer(iTracer,k,cell1) + (r_tmp2 - r_tmp1) * invAreaCell1
+ delsq_tracer(iTracer,k,cell2) = delsq_tracer(iTracer,k,cell2) - (r_tmp2 - r_tmp1) * invAreaCell2
end do
end do
end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k=1,maxLevelCell(iCell)
- do iTracer=1,num_tracers
- delsq_tracer(iTracer,k,iCell) = delsq_tracer(iTracer,k,iCell) * r
- end do
- end do
- end do
-
! second del2: div(h </font>
<font color="gray">abla [delsq_tracer]) at cell center
do iEdge=1,grid % nEdges
cell1 = grid % cellsOnEdge % array(1,iEdge)
cell2 = grid % cellsOnEdge % array(2,iEdge)
+
invAreaCell1 = 1.0 / areaCell(cell1)
invAreaCell2 = 1.0 / areaCell(cell2)
+ invdcEdge = 1.0 / dcEdge(iEdge)
+
do k=1,maxLevelEdgeTop(iEdge)
- do iTracer=1,num_tracers
+ do iTracer=1,num_tracers * edgeMask(k,iEdge)
tracer_turb_flux = meshScalingDel4(iEdge) * eddyDiff4 &
- *( delsq_tracer(iTracer,k,cell2) &
- - delsq_tracer(iTracer,k,cell1))/dcEdge(iEdge)
+ * (delsq_tracer(iTracer,k,cell2) - delsq_tracer(iTracer,k,cell1)) &
+ * invdcEdge
+
flux = dvEdge (iEdge) * tracer_turb_flux
- tend(iTracer,k,cell1) = tend(iTracer,k,cell1) &
- - flux * invAreaCell1 * boundaryMask(k,iEdge)
- tend(iTracer,k,cell2) = tend(iTracer,k,cell2) &
- + flux * invAreaCell2 * boundaryMask(k,iEdge)
-
+ tend(iTracer,k,cell1) = tend(iTracer,k,cell1) - flux * invAreaCell1
+ tend(iTracer,k,cell2) = tend(iTracer,k,cell2) + flux * invAreaCell2
enddo
enddo
end do
deallocate(delsq_tracer)
- call mpas_timer_stop("compute_scalar_tend-horiz diff 4")
!--------------------------------------------------------------------
end subroutine ocn_tracer_hmix_del4_tend!}}}
@@ -244,10 +232,10 @@
integer, intent(out) :: err !< Output: error flag
err = 0
- Del4on = .false.
+ del4on = .false.
if ( config_h_tracer_eddy_diff4 > 0.0 ) then
- Del4On = .true.
+ del4On = .true.
eddyDiff4 = config_h_tracer_eddy_diff4
endif
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -70,7 +70,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -79,6 +79,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -122,10 +123,15 @@
err = 0
+ ! mrp 120202 efficiency note:
+ ! The following if statement is not needed, since wTop is set to
+ ! zero for isopycnal coordinates. This if statment saves flops
+ ! for isopycnal coordinates. However, if the loops are pushed
+ ! out, we could get rid of this if statement.
if(.not.vadvOn) return
- call ocn_tracer_vadv_stencil_tend(grid, wTop, tracers, tend, err1)
- call ocn_tracer_vadv_spline_tend(grid, wTop, tracers, tend, err2)
+ call ocn_tracer_vadv_stencil_tend(grid, h, wTop, tracers, tend, err1)
+ call ocn_tracer_vadv_spline_tend(grid, h, wTop, tracers, tend, err2)
err = ior(err1, err2)
@@ -166,7 +172,7 @@
err = 0
vadvOn = .false.
- if (config_vert_grid_type.eq.'zlevel') then
+ if (config_vert_grid_type.ne.'isopycnal') then
vadvOn = .true.
call ocn_tracer_vadv_stencil_init(err1)
call ocn_tracer_vadv_spline_init(err2)
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,6 +16,7 @@
use mpas_grid_types
use mpas_configure
+ use mpas_timer
use ocn_tracer_vadv_spline2
use ocn_tracer_vadv_spline3
@@ -45,6 +46,7 @@
!
!--------------------------------------------------------------------
+ type (timer_node), pointer :: spline2_timer, spline3_timer
logical :: splineOn
@@ -70,7 +72,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_spline_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_spline_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -79,6 +81,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -124,9 +127,14 @@
if(.not.splineOn) return
- call ocn_tracer_vadv_spline2_tend(grid, wTop, tracers, tend, err1)
- call ocn_tracer_vadv_spline3_tend(grid, wTop, tracers, tend, err2)
+ call mpas_timer_start("spline 2", .false., spline2_timer)
+ call ocn_tracer_vadv_spline2_tend(grid, h, wTop, tracers, tend, err1)
+ call mpas_timer_stop("spline 2", spline2_timer)
+ call mpas_timer_start("spline 3", .false., spline3_timer)
+ call ocn_tracer_vadv_spline3_tend(grid, h, wTop, tracers, tend, err2)
+ call mpas_timer_stop("spline 3", spline3_timer)
+
err = ior(err1, err2)
!--------------------------------------------------------------------
@@ -163,6 +171,8 @@
integer :: err1, err2
+ err = 0
+
splineOn = .false.
if(config_vert_tracer_adv.eq.'spline') then
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline2.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline2.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline2.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -64,7 +63,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_spline2_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_spline2_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -73,6 +72,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -108,8 +108,6 @@
integer, dimension(:), pointer :: maxLevelCell
- real (kind=RKIND), dimension(:), pointer :: hRatioZLevelK, hRatioZLevelKm1
-
real (kind=RKIND), dimension(:,:,:), allocatable :: tracerTop
!-----------------------------------------------------------------
@@ -125,29 +123,27 @@
if(.not.spline2On) return
! Compute tracerTop using linear interpolation.
- call mpas_timer_start("compute_scalar_tend-vert adv spline 2")
-
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
nVertLevels = grid % nVertLevels
num_tracers = size(tracers, 1)
maxLevelCell => grid % maxLevelCell % array
- hRatioZLevelK => grid % hRatioZLevelK % array
- hRatioZLevelKm1 => grid % hRatioZLevelKm1 % array
-
allocate(tracerTop(num_tracers,nVertLevels+1,nCells))
do iCell=1,nCellsSolve
+ tracerTop(:,1,iCell) = tracers(:,1,iCell)
do k=2,maxLevelCell(iCell)
do iTracer=1,num_tracers
- ! Note hRatio on the k side is multiplied by tracer at k-1
- ! and hRatio on the Km1 (k-1) side is mult. by tracer at k.
+ ! Note h on the k side is multiplied by tracer at k-1
+ ! and h on the Km1 (k-1) side is mult. by tracer at k.
tracerTop(iTracer,k,iCell) = &
- hRatioZLevelK(k) *tracers(iTracer,k-1,iCell) &
- + hRatioZLevelKm1(k)*tracers(iTracer,k ,iCell)
+ ( h(k ,iCell)*tracers(iTracer,k-1,iCell) &
+ + h(k-1,iCell)*tracers(iTracer,k ,iCell) ) &
+ / (h(k-1,iCell) + h(k,iCell))
end do
end do
+ tracerTop(:,maxLevelCell(iCell)+1,iCell) = tracers(:,maxLevelCell(iCell),iCell)
end do
do iCell=1,nCellsSolve
@@ -161,8 +157,6 @@
end do
deallocate(tracerTop)
-
- call mpas_timer_stop("compute_scalar_tend-vert adv spline 2")
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_spline2_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_spline3.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
use mpas_spline_interpolation
implicit none
@@ -65,7 +64,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_spline3_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_spline3_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -74,6 +73,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -109,11 +109,8 @@
integer, dimension(:), pointer :: maxLevelCell
- real (kind=RKIND), dimension(:), pointer :: hRatioZLevelK, &
- hRatioZLevelKm1, zTopZLevel, zMidZLevel
-
real (kind=RKIND), dimension(:), allocatable :: tracer2ndDer, &
- tracersIn, tracersOut, posZMidZLevel, posZTopZLevel
+ tracersIn, tracersOut, depthTop, depthMid
real (kind=RKIND), dimension(:,:,:), allocatable :: tracerTop
!-----------------------------------------------------------------
@@ -129,34 +126,30 @@
if(.not.spline3On) return
! Compute tracerTop using linear interpolation.
- call mpas_timer_start("compute_scalar_tend-vert adv spline 3")
-
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
nVertLevels = grid % nVertLevels
num_tracers = size(tracers, 1)
maxLevelCell => grid % maxLevelCell % array
- hRatioZLevelK => grid % hRatioZLevelK % array
- hRatioZLevelKm1 => grid % hRatioZLevelKm1 % array
- zMidZLevel => grid % zMidZLevel % array
- zTopZLevel => grid % zTopZLevel % array
-
allocate(tracerTop(num_tracers,nVertLevels+1,nCells))
! Compute tracerTop using cubic spline interpolation.
allocate(tracer2ndDer(nVertLevels))
allocate(tracersIn(nVertLevels),tracersOut(nVertLevels), &
- posZMidZLevel(nVertLevels), posZTopZLevel(nVertLevels-1))
+ depthMid(nVertLevels), depthTop(nVertLevels+1))
- ! For the ocean, zlevel coordinates are negative and decreasing,
- ! but spline functions assume increasing, so flip to positive.
+ do iCell=1,nCellsSolve
- posZMidZLevel = -zMidZLevel(1:nVertLevels)
- posZTopZLevel = -zTopZLevel(2:nVertLevels)
+ ! Here depth considers SSH to be depth=0. We don't need to
+ ! have true z-coordinate depths because it is just for interpolation.
+ depthTop(1) = 0.0
+ do k=1,maxLevelCell(iCell)
+ depthMid(k ) = depthTop(k) + 0.5*h(k,iCell)
+ depthTop(k+1) = depthTop(k) + h(k,iCell)
+ enddo
- do iCell=1,nCellsSolve
! mrp 110201 efficiency note: push tracer loop down
! into spline subroutines to improve efficiency
do iTracer=1,num_tracers
@@ -165,15 +158,16 @@
! subroutine call.
tracersIn(1:maxLevelCell(iCell))=tracers(iTracer,1:maxLevelCell(iCell),iCell)
- call mpas_cubic_spline_coefficients(posZMidZLevel, &
+ call mpas_cubic_spline_coefficients(depthMid, &
tracersIn, maxLevelCell(iCell), tracer2ndDer)
call mpas_interpolate_cubic_spline( &
- posZMidZLevel, tracersIn, tracer2ndDer, maxLevelCell(iCell), &
- posZTopZLevel, tracersOut, maxLevelCell(iCell)-1 )
+ depthMid, tracersIn, tracer2ndDer, maxLevelCell(iCell), &
+ depthTop(2:maxLevelCell(iCell)), tracersOut, maxLevelCell(iCell)-1 )
+ tracerTop(itracer,1,iCell) = tracers(iTracer,1,iCell)
tracerTop(iTracer,2:maxLevelCell(iCell),iCell) = tracersOut(1:maxLevelCell(iCell)-1)
-
+ tracerTop(itracer,maxLevelCell(iCell)+1,iCell) = tracers(iTracer,maxLevelCell(iCell),iCell)
end do
end do
@@ -188,10 +182,8 @@
end do
deallocate(tracer2ndDer)
- deallocate(tracersIn,tracersOut, posZMidZLevel, posZTopZLevel)
+ deallocate(tracersIn,tracersOut, depthMid, depthTop)
deallocate(tracerTop)
-
- call mpas_timer_stop("compute_scalar_tend-vert adv spline 3")
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_spline3_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,6 +16,7 @@
use mpas_grid_types
use mpas_configure
+ use mpas_timer
use ocn_tracer_vadv_stencil2
use ocn_tracer_vadv_stencil3
@@ -46,6 +47,8 @@
!
!--------------------------------------------------------------------
+ type (timer_node), pointer :: stencil2_timer, stencil3_timer, stencil4_timer
+
logical :: stencilOn
@@ -71,7 +74,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_stencil_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_stencil_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -80,6 +83,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -125,9 +129,15 @@
if(.not. stencilOn) return
+ call mpas_timer_start("stencil 2", .false., stencil2_timer)
call ocn_tracer_vadv_stencil2_tend(grid, wTop, tracers, tend, err1)
- call ocn_tracer_vadv_stencil3_tend(grid, wTop, tracers, tend, err1)
- call ocn_tracer_vadv_stencil4_tend(grid, wTop, tracers, tend, err1)
+ call mpas_timer_stop("stencil 2", stencil2_timer)
+ call mpas_timer_start("stencil 3", .false., stencil3_timer)
+ call ocn_tracer_vadv_stencil3_tend(grid, h, wTop, tracers, tend, err2)
+ call mpas_timer_stop("stencil 3", stencil3_timer)
+ call mpas_timer_start("stencil 4", .false., stencil4_timer)
+ call ocn_tracer_vadv_stencil4_tend(grid, h, wTop, tracers, tend, err3)
+ call mpas_timer_stop("stencil 4", stencil4_timer)
err = ior(err1, ior(err2, err3))
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil2.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil2.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil2.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -122,11 +121,8 @@
err = 0
- if(.not. stencil2On) return
+ if(.not.stencil2On) return
-
- call mpas_timer_start("compute_scalar_tend-vert adv stencil 2")
-
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
num_tracers = size(tracers, 1)
@@ -138,6 +134,7 @@
! Compute tracerTop using centered stencil, a simple average.
do iCell=1,nCellsSolve
+ tracerTop(:,1,iCell) = tracers(:,1,iCell)
do k=2,maxLevelCell(iCell)
do iTracer=1,num_tracers
tracerTop(iTracer,k,iCell) = &
@@ -145,6 +142,7 @@
+tracers(iTracer,k ,iCell))/2.0
end do
end do
+ tracerTop(:,maxLevelCell(iCell)+1,iCell) = tracers(:,maxLevelCell(iCell),iCell)
end do
do iCell=1,nCellsSolve
@@ -158,8 +156,6 @@
end do
deallocate(tracerTop)
- call mpas_timer_stop("compute_scalar_tend-vert adv stencil 2")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_stencil2_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil3.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil3.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil3.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -64,7 +63,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_stencil3_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_stencil3_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -73,6 +72,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -110,7 +110,6 @@
integer, dimension(:), pointer :: maxLevelCell
real (kind=RKIND) :: cSignWTop, flux3Coef
- real (kind=RKIND), dimension(:), pointer :: hRatioZLevelK, hRatioZLevelKm1
real (kind=RKIND), dimension(:,:,:), allocatable :: tracerTop
@@ -124,18 +123,14 @@
err = 0
- if(.not. stencil3On) return
+ if(.not.stencil3On) return
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
num_tracers = size(tracers, 1)
nVertLevels = grid % nVertLevels
maxLevelCell => grid % maxLevelCell % array
- hRatioZLevelK => grid % hRatioZLevelK % array
- hRatioZLevelKm1 => grid % hRatioZLevelKm1 % array
- call mpas_timer_start("compute_scalar_tend-vert adv stencil 3")
-
allocate(tracerTop(num_tracers,nVertLevels+1,nCells))
! Compute tracerTop using 3rd order stencil. This is the same
@@ -145,11 +140,13 @@
! namelist, if desired.
flux3Coef = 1.0
do iCell=1,nCellsSolve
+ tracerTop(:,1,iCell) = tracers(:,1,iCell)
k=2
do iTracer=1,num_tracers
- tracerTop(iTracer,k,iCell) = &
- hRatioZLevelK(k) *tracers(iTracer,k-1,iCell) &
- + hRatioZLevelKm1(k)*tracers(iTracer,k ,iCell)
+ tracerTop(iTracer,k,iCell) = &
+ ( h(k,iCell)*tracers(iTracer,k-1,iCell) &
+ + h(k-1,iCell)*tracers(iTracer,k ,iCell) ) &
+ / (h(k-1,iCell) + h(k,iCell))
end do
do k=3,maxLevelCell(iCell)-1
cSignWTop = sign(flux3Coef,wTop(k,iCell))
@@ -164,10 +161,12 @@
end do
k=maxLevelCell(iCell)
do iTracer=1,num_tracers
- tracerTop(iTracer,k,iCell) = &
- hRatioZLevelK(k) *tracers(iTracer,k-1,iCell) &
- + hRatioZLevelKm1(k)*tracers(iTracer,k ,iCell)
+ tracerTop(iTracer,k,iCell) = &
+ ( h(k,iCell)*tracers(iTracer,k-1,iCell) &
+ + h(k-1,iCell)*tracers(iTracer,k ,iCell) ) &
+ / (h(k-1,iCell) + h(k,iCell))
end do
+ tracerTop(:,maxLevelCell(iCell)+1,iCell) = tracers(:,maxLevelCell(iCell),iCell)
end do
do iCell=1,nCellsSolve
@@ -181,8 +180,6 @@
end do
deallocate(tracerTop)
- call mpas_timer_stop("compute_scalar_tend-vert adv stencil 3")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_stencil3_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil4.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil4.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_tracer_vadv_stencil4.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -64,7 +63,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_tracer_vadv_stencil4_tend(grid, wTop, tracers, tend, err)!{{{
+ subroutine ocn_tracer_vadv_stencil4_tend(grid, h, wTop, tracers, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -73,6 +72,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h, & !< Input: layer thickness
wTop !< Input: vertical tracer in top layer
real (kind=RKIND), dimension(:,:,:), intent(in) :: &
@@ -110,7 +110,6 @@
integer, dimension(:), pointer :: maxLevelCell
real (kind=RKIND) :: cSingWTop, flux3Coef
- real (kind=RKIND), dimension(:), pointer :: hRatioZLevelK, hRatioZLevelKm1
real (kind=RKIND), dimension(:,:,:), allocatable :: tracerTop
@@ -124,28 +123,26 @@
err = 0
- if(.not. Stencil4On) return
+ if(.not.Stencil4On) return
- call mpas_timer_start("compute_scalar_tend-vert adv stencil 4")
-
nCells = grid % nCells
nCellsSolve = grid % nCellsSolve
num_tracers = size(tracers, 1)
nVertLevels = grid % nVertLevels
maxLevelCell => grid % maxLevelCell % array
- hRatioZLevelK => grid % hRatioZLevelK % array
- hRatioZLevelKm1 => grid % hRatioZLevelKm1 % array
allocate(tracerTop(num_tracers,nVertLevels+1,nCells))
! Compute tracerTop using 4rd order stencil [-1 7 7 -1]
do iCell=1,nCellsSolve
+ tracerTop(:,1,iCell) = tracers(:,1,iCell)
k=2
do iTracer=1,num_tracers
- tracerTop(iTracer,k,iCell) = &
- hRatioZLevelK(k) *tracers(iTracer,k-1,iCell) &
- + hRatioZLevelKm1(k)*tracers(iTracer,k ,iCell)
+ tracerTop(iTracer,k,iCell) = &
+ ( h(k ,iCell)*tracers(iTracer,k-1,iCell) &
+ + h(k-1,iCell)*tracers(iTracer,k ,iCell) ) &
+ / (h(k-1,iCell) + h(k,iCell))
end do
do k=3,maxLevelCell(iCell)-1
do iTracer=1,num_tracers
@@ -159,10 +156,12 @@
end do
k=maxLevelCell(iCell)
do iTracer=1,num_tracers
- tracerTop(iTracer,k,iCell) = &
- hRatioZLevelK(k) *tracers(iTracer,k-1,iCell) &
- + hRatioZLevelKm1(k)*tracers(iTracer,k ,iCell)
+ tracerTop(iTracer,k,iCell) = &
+ ( h(k ,iCell)*tracers(iTracer,k-1,iCell) &
+ + h(k-1,iCell)*tracers(iTracer,k ,iCell) ) &
+ / (h(k-1,iCell) + h(k,iCell))
end do
+ tracerTop(:,maxLevelCell(iCell)+1,iCell) = tracers(:,maxLevelCell(iCell),iCell)
end do
do iCell=1,nCellsSolve
@@ -176,8 +175,6 @@
end do
deallocate(tracerTop)
- call mpas_timer_stop("compute_scalar_tend-vert adv stencil 4")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_vadv_stencil4_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_coriolis.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_coriolis.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_coriolis.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -62,7 +62,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_vel_coriolis_tend(grid, pv_edge, h_edge, u, ke, tend, err)!{{{
+ subroutine ocn_vel_coriolis_tend(grid, Vor_edge, h_edge, u, ke, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -71,7 +71,7 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
- pv_edge !< Input: Potential vorticity on edge
+ Vor_edge !< Input: Potential vorticity on edge
real (kind=RKIND), dimension(:,:), intent(in) :: &
h_edge !< Input: Thickness on edge
real (kind=RKIND), dimension(:,:), intent(in) :: &
@@ -106,13 +106,13 @@
!-----------------------------------------------------------------
integer, dimension(:), pointer :: maxLevelEdgeTop, nEdgesOnEdge
- integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnEdge, edgeMask
real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge
real (kind=RKIND), dimension(:), pointer :: dcEdge
integer :: j, k
integer :: cell1, cell2, nEdgesSolve, iEdge, eoe
- real (kind=RKIND) :: workpv, q
+ real (kind=RKIND) :: workpv, q, invLength
err = 0
@@ -123,24 +123,26 @@
weightsOnEdge => grid % weightsOnEdge % array
dcEdge => grid % dcEdge % array
+ edgeMask => grid % edgeMask % array
+
nEdgesSolve = grid % nEdgesSolve
do iEdge=1,grid % nEdgesSolve
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+ invLength = 1.0 / dcEdge(iEdgE)
+
do k=1,maxLevelEdgeTop(iEdge)
q = 0.0
do j = 1,nEdgesOnEdge(iEdge)
eoe = edgesOnEdge(j,iEdge)
- workpv = 0.5 * (pv_edge(k,iEdge) + pv_edge(k,eoe))
+ workpv = 0.5 * (Vor_edge(k,iEdge) + Vor_edge(k,eoe))
q = q + weightsOnEdge(j,iEdge) * u(k,eoe) * workpv * h_edge(k,eoe)
end do
- tend(k,iEdge) = tend(k,iEdge) &
- + q &
- - ( ke(k,cell2) - ke(k,cell1) ) / dcEdge(iEdge)
+ tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * (q - ( ke(k,cell2) - ke(k,cell1) ) * invLength )
end do
end do
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -19,6 +19,7 @@
use ocn_vel_forcing_windstress
use ocn_vel_forcing_bottomdrag
+ use ocn_vel_forcing_rayleigh
implicit none
private
@@ -114,7 +115,7 @@
!
!-----------------------------------------------------------------
- integer :: err1, err2
+ integer :: err1, err2, err3
!-----------------------------------------------------------------
!
@@ -126,8 +127,10 @@
call ocn_vel_forcing_windstress_tend(grid, u_src, h_edge, tend, err1)
call ocn_vel_forcing_bottomdrag_tend(grid, u, ke_edge, h_edge, tend, err2)
+ call ocn_vel_forcing_rayleigh_tend(grid, u, tend, err3)
err = ior(err1, err2)
+ err = ior(err, err3)
!--------------------------------------------------------------------
@@ -161,12 +164,14 @@
integer, intent(out) :: err !< Output: error flag
- integer :: err1, err2
+ integer :: err1, err2, err3
call ocn_vel_forcing_windstress_init(err1)
call ocn_vel_forcing_bottomdrag_init(err2)
+ call ocn_vel_forcing_rayleigh_init(err3)
err = ior(err1, err2)
+ err = ior(err, err3)
!--------------------------------------------------------------------
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_bottomdrag.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -109,6 +109,7 @@
integer :: iEdge, nEdgesSolve, k
integer, dimension(:), pointer :: maxLevelEdgeTop
+ integer, dimension(:,:), pointer :: edgeMask
!-----------------------------------------------------------------
!
@@ -124,27 +125,18 @@
nEdgesSolve = grid % nEdgesSolve
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ edgeMask => grid % edgeMask % array
do iEdge=1,grid % nEdgesSolve
- k = maxLevelEdgeTop(iEdge)
+ k = max(maxLevelEdgeTop(iEdge), 1)
- ! efficiency note: it would be nice to avoid this
- ! if within a do. This could be done with
- ! k = max(maxLevelEdgeTop(iEdge),1)
- ! and then tend_u(1,iEdge) is just not used for land cells.
+ ! bottom drag is the same as POP:
+ ! -c |u| u where c is unitless and 1.0e-3.
+ ! see POP Reference guide, section 3.4.4.
- if (k>0) then
- ! bottom drag is the same as POP:
- ! -c |u| u where c is unitless and 1.0e-3.
- ! see POP Reference guide, section 3.4.4.
+ tend(k,iEdge) = tend(k,iEdge)-edgeMask(k,iEdge)*(bottomDragCoef*u(k,iEdge)*sqrt(2.0*ke_edge(k,iEdge))/h_edge(k,iEdge))
- tend(k,iEdge) = tend(k,iEdge) &
- -bottomDragCoef*u(k,iEdge) &
- *sqrt(2.0*ke_edge(k,iEdge))/h_edge(k,iEdge)
-
- endif
-
enddo
Copied: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F (from rev 1731, trunk/mpas/src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_rayleigh.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,180 @@
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+!
+! ocn_vel_forcing_rayleigh
+!
+!> \brief MPAS ocean Rayleigh Friction (to be used to smooth "shocks" from cold starts)
+!> \author Todd Ringler
+!> \date 5 January 2012
+!> \version SVN:$Id:$
+!> \details
+!> This module contains the routine for computing
+!> tendencies based on linear Rayleigh friction.
+!
+!-----------------------------------------------------------------------
+
+module ocn_vel_forcing_rayleigh
+
+ use mpas_grid_types
+ use mpas_configure
+
+ implicit none
+ private
+ save
+
+ !--------------------------------------------------------------------
+ !
+ ! Public parameters
+ !
+ !--------------------------------------------------------------------
+
+ !--------------------------------------------------------------------
+ !
+ ! Public member functions
+ !
+ !--------------------------------------------------------------------
+
+ public :: ocn_vel_forcing_rayleigh_tend, &
+ ocn_vel_forcing_rayleigh_init
+
+ !--------------------------------------------------------------------
+ !
+ ! Private module variables
+ !
+ !--------------------------------------------------------------------
+
+ logical :: rayleighFrictionOn
+ real (kind=RKIND) :: rayleighDampingCoef
+
+
+!***********************************************************************
+
+contains
+
+!***********************************************************************
+!
+! ocn_vel_forcing_rayleigh_tend
+!
+!> \brief Computes tendency term from Rayleigh friction
+!> \author Todd Ringler
+!> \date 5 January 2012
+!> \version SVN:$Id$
+!> \details
+!> This routine computes the Rayleigh friction tendency for momentum
+!> based on current state.
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_vel_forcing_rayleigh_tend(grid, u, tend, err)!{{{
+
+ !-----------------------------------------------------------------
+ !
+ ! input variables
+ !
+ !-----------------------------------------------------------------
+
+ real (kind=RKIND), dimension(:,:), intent(in) :: &
+ u !< Input: velocity
+
+ type (mesh_type), intent(in) :: &
+ grid !< Input: grid information
+
+ !-----------------------------------------------------------------
+ !
+ ! input/output variables
+ !
+ !-----------------------------------------------------------------
+
+ real (kind=RKIND), dimension(:,:), intent(inout) :: &
+ tend !< Input/Output: velocity tendency
+
+ !-----------------------------------------------------------------
+ !
+ ! output variables
+ !
+ !-----------------------------------------------------------------
+
+ integer, intent(out) :: err !< Output: error flag
+
+ !-----------------------------------------------------------------
+ !
+ ! local variables
+ !
+ !-----------------------------------------------------------------
+
+ integer :: iEdge, nEdgesSolve, k
+ integer, dimension(:), pointer :: maxLevelEdgeTop
+
+ !-----------------------------------------------------------------
+ !
+ ! call relevant routines for computing tendencies
+ ! note that the user can choose multiple options and the
+ ! tendencies will be added together
+ !
+ !-----------------------------------------------------------------
+
+ err = 0
+
+ if(.not.rayleighFrictionOn) return
+
+ nEdgesSolve = grid % nEdgesSolve
+ maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+
+ do iEdge=1,nEdgesSolve
+ do k=1,maxLevelEdgeTop(iEdge)
+
+ tend(k,iEdge) = tend(k,iEdge) - rayleighDampingCoef * u(k,iEdge)
+
+ enddo
+ enddo
+
+
+ !--------------------------------------------------------------------
+
+ end subroutine ocn_vel_forcing_rayleigh_tend!}}}
+
+!***********************************************************************
+!
+! ocn_vel_forcing_rayleigh_init
+!
+!> \brief Initializes ocean Rayleigh friction
+!> \author Todd Ringler
+!> \date 5 January 2012
+!> \version SVN:$Id$
+!> \details
+!> This routine initializes quantities related to
+!> in the ocean.
+!
+!-----------------------------------------------------------------------
+
+ subroutine ocn_vel_forcing_rayleigh_init(err)!{{{
+
+ !--------------------------------------------------------------------
+
+ !-----------------------------------------------------------------
+ !
+ ! call individual init routines for each parameterization
+ !
+ !-----------------------------------------------------------------
+
+ integer, intent(out) :: err !< Output: error flag
+
+
+ err = 0
+
+ rayleighDampingCoef = 0.0
+
+ if (config_rayleigh_friction) then
+ rayleighFrictionOn = .true.
+ rayleighDampingCoef = config_rayleigh_damping_coeff
+ endif
+
+ !--------------------------------------------------------------------
+
+ end subroutine ocn_vel_forcing_rayleigh_init!}}}
+
+!***********************************************************************
+
+end module ocn_vel_forcing_rayleigh
+
+!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
+! vim: foldmethod=marker
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_windstress.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_windstress.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_forcing_windstress.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -106,8 +106,8 @@
integer :: iEdge, nEdgesSolve, k
integer, dimension(:), pointer :: maxLevelEdgeTop
+ integer, dimension(:,:), pointer :: edgeMask
-
!-----------------------------------------------------------------
!
! call relevant routines for computing tendencies
@@ -122,21 +122,19 @@
nEdgesSolve = grid % nEdgesSolve
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
+ edgeMask => grid % edgeMask % array
do iEdge=1,nEdgesSolve
- k = maxLevelEdgeTop(iEdge)
-
! efficiency note: it would be nice to avoid this
! if within a do. This could be done with
! k = max(maxLevelEdgeTop(iEdge),1)
! and then tend_u(1,iEdge) is just not used for land cells.
- if (k>0) then
+ do k = 1,min(maxLevelEdgeTop(iEdge),1)
! forcing in top layer only
- tend(1,iEdge) = tend(1,iEdge) &
- + u_src(1,iEdge)/rho_ref/h_edge(1,iEdge)
- endif
+ tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * (u_src(k,iEdge)/rho_ref/h_edge(k,iEdge))
+ enddo
enddo
@@ -171,13 +169,11 @@
integer, intent(out) :: err !< Output: error flag
-
windStressOn = .true.
rho_ref = 1000.0
err = 0
-
!--------------------------------------------------------------------
end subroutine ocn_vel_forcing_windstress_init!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -18,6 +18,7 @@
use mpas_grid_types
use mpas_configure
+ use mpas_timer
use ocn_vel_hmix_del2
use ocn_vel_hmix_del4
@@ -46,7 +47,9 @@
!
!--------------------------------------------------------------------
+ type (timer_node), pointer :: del2Timer, del4Timer
+
!***********************************************************************
contains
@@ -119,8 +122,12 @@
!
!-----------------------------------------------------------------
+ call mpas_timer_start("del2", .false., del2Timer)
call ocn_vel_hmix_del2_tend(grid, divergence, vorticity, tend, err1)
+ call mpas_timer_stop("del2", del2Timer)
+ call mpas_timer_start("del4", .false., del4Timer)
call ocn_vel_hmix_del4_tend(grid, divergence, vorticity, tend, err2)
+ call mpas_timer_stop("del4", del4Timer)
err = ior(err1, err2)
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix_del2.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix_del2.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -43,8 +42,7 @@
!
!--------------------------------------------------------------------
- logical :: &
- hmixDel2On !< local flag to determine whether del2 chosen
+ logical :: hmixDel2On !< integer flag to determine whether del2 chosen
real (kind=RKIND) :: &
eddyVisc2, &!< base eddy diffusivity for Laplacian
@@ -116,9 +114,9 @@
integer :: iEdge, nEdgesSolve, cell1, cell2, vertex1, vertex2
integer :: k
integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask
- real (kind=RKIND) :: u_diffusion
+ real (kind=RKIND) :: u_diffusion, invLength1, invLength2
real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, &
dcEdge, dvEdge
@@ -132,13 +130,12 @@
if(.not.hmixDel2On) return
- call mpas_timer_start("compute_tend_u-horiz mix-del2")
-
nEdgesSolve = grid % nEdgesSolve
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
verticesOnEdge => grid % verticesOnEdge % array
meshScalingDel2 => grid % meshScalingDel2 % array
+ edgeMask => grid % edgeMask % array
dcEdge => grid % dcEdge % array
dvEdge => grid % dvEdge % array
@@ -148,25 +145,26 @@
vertex1 = verticesOnEdge(1,iEdge)
vertex2 = verticesOnEdge(2,iEdge)
+ invLength1 = 1.0 / dcEdge(iEdge)
+ invLength2 = 1.0 / dvEdge(iEdge)
+
do k=1,maxLevelEdgeTop(iEdge)
! Here -( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
! is - </font>
<font color="black">abla vorticity pointing from vertex 2 to vertex 1, or equivalently
! + k \times </font>
<font color="gray">abla vorticity pointing from cell1 to cell2.
- u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
+ u_diffusion = ( divergence(k,cell2) - divergence(k,cell1) ) * invLength1 &
-viscVortCoef &
- *( vorticity(k,vertex2) - vorticity(k,vertex1) ) / dvEdge(iEdge)
+ *( vorticity(k,vertex2) - vorticity(k,vertex1) ) * invLength2
u_diffusion = meshScalingDel2(iEdge) * eddyVisc2 * u_diffusion
- tend(k,iEdge) = tend(k,iEdge) + u_diffusion
+ tend(k,iEdge) = tend(k,iEdge) + edgeMask(k, iEdge) * u_diffusion
end do
end do
- call mpas_timer_stop("compute_tend_u-horiz mix-del2")
-
!--------------------------------------------------------------------
end subroutine ocn_vel_hmix_del2_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix_del4.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_hmix_del4.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -16,7 +16,6 @@
use mpas_grid_types
use mpas_configure
- use mpas_timer
implicit none
private
@@ -43,8 +42,7 @@
!
!--------------------------------------------------------------------
- logical :: &
- hmixDel4On !< local flag to determine whether del4 chosen
+ logical :: hmixDel4On !< local flag to determine whether del4 chosen
real (kind=RKIND) :: &
eddyVisc4, &!< base eddy diffusivity for biharmonic
@@ -114,30 +112,30 @@
!
!-----------------------------------------------------------------
- integer :: iEdge, nEdges, cell1, cell2, vertex1, vertex2, k
+ integer :: iEdge, cell1, cell2, vertex1, vertex2, k
integer :: iCell, iVertex
- integer :: nVertices, nVertLevels, nCells
+ integer :: nVertices, nVertLevels, nCells, nEdges, nEdgesSolve
integer, dimension(:), pointer :: maxLevelEdgeTop, maxLevelVertexBot, &
maxLevelCell
- integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgeMask
- real (kind=RKIND) :: u_diffusion, r
+ real (kind=RKIND) :: u_diffusion, invAreaCell1, invAreaCell2, invAreaTri1, &
+ invAreaTri2, invDcEdge, invDvEdge, r_tmp, delsq_u
real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaTriangle, &
meshScalingDel4, areaCell
real (kind=RKIND), dimension(:,:), allocatable :: delsq_divergence, &
- delsq_u, delsq_circulation, delsq_vorticity
+ delsq_circulation, delsq_vorticity
err = 0
if(.not.hmixDel4On) return
- call mpas_timer_start("compute_tend-horiz mix-del4")
-
nCells = grid % nCells
nEdges = grid % nEdges
+ nEdgesSolve = grid % nEdgessolve
nVertices = grid % nVertices
nVertLevels = grid % nVertLevels
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
@@ -150,101 +148,70 @@
areaTriangle => grid % areaTriangle % array
areaCell => grid % areaCell % array
meshScalingDel4 => grid % meshScalingDel4 % array
+ edgeMask => grid % edgeMask % array
allocate(delsq_divergence(nVertLevels, nCells+1))
- allocate(delsq_u(nVertLevels, nEdges+1))
- allocate(delsq_circulation(nVertLevels, nVertices+1))
allocate(delsq_vorticity(nVertLevels, nVertices+1))
- delsq_u(:,:) = 0.0
+ delsq_vorticity(:,:) = 0.0
+ delsq_divergence(:,:) = 0.0
- ! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="red">abla vorticity
- do iEdge=1,grid % nEdges
+ do iEdge=1,nEdges
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
+
vertex1 = verticesOnEdge(1,iEdge)
vertex2 = verticesOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
+ invAreaTri1 = 1.0 / areaTriangle(vertex1)
+ invAreaTri2 = 1.0 / areaTriangle(vertex2)
- delsq_u(k,iEdge) = &
- ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -viscVortCoef &
- *( vorticity(k,vertex2) - vorticity(k,vertex1)) / dvEdge(iEdge)
+ invAreaCell1 = 1.0 / areaCell(cell1)
+ invAreaCell2 = 1.0 / areaCell(cell2)
- end do
- end do
+ invDcEdge = 1.0 / dcEdge(iEdge)
+ invDvEdge = 1.0 / dvEdge(iEdge)
- ! vorticity using </font>
<font color="red">abla^2 u
- delsq_circulation(:,:) = 0.0
- do iEdge=1,nEdges
- vertex1 = verticesOnEdge(1,iEdge)
- vertex2 = verticesOnEdge(2,iEdge)
do k=1,maxLevelEdgeTop(iEdge)
- delsq_circulation(k,vertex1) = delsq_circulation(k,vertex1) &
- - dcEdge(iEdge) * delsq_u(k,iEdge)
- delsq_circulation(k,vertex2) = delsq_circulation(k,vertex2) &
- + dcEdge(iEdge) * delsq_u(k,iEdge)
- end do
- end do
- do iVertex=1,nVertices
- r = 1.0 / areaTriangle(iVertex)
- do k=1,maxLevelVertexBot(iVertex)
- delsq_vorticity(k,iVertex) = delsq_circulation(k,iVertex) * r
- end do
- end do
+ ! Compute </font>
<font color="black">abla^2 u = </font>
<font color="black">abla divergence + k \times </font>
<font color="red">abla vorticity
+ delsq_u = ( divergence(k,cell2) - divergence(k,cell1) ) * invDcEdge &
+ -viscVortCoef *( vorticity(k,vertex2) - vorticity(k,vertex1)) * invDvEdge
- ! Divergence using </font>
<font color="red">abla^2 u
- delsq_divergence(:,:) = 0.0
- do iEdge=1,nEdges
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- delsq_divergence(k,cell1) = delsq_divergence(k,cell1) &
- + delsq_u(k,iEdge)*dvEdge(iEdge)
- delsq_divergence(k,cell2) = delsq_divergence(k,cell2) &
- - delsq_u(k,iEdge)*dvEdge(iEdge)
+ ! vorticity using </font>
<font color="blue">abla^2 u
+ r_tmp = dcEdge(iEdge) * delsq_u
+ delsq_vorticity(k,vertex1) = delsq_vorticity(k,vertex1) - r_tmp * invAreaTri1
+ delsq_vorticity(k,vertex2) = delsq_vorticity(k,vertex2) + r_tmp * invAreaTri2
+
+ ! Divergence using </font>
<font color="red">abla^2 u
+ r_tmp = dvEdge(iEdge) * delsq_u
+ delsq_divergence(k, cell1) = delsq_divergence(k,cell1) + r_tmp * invAreaCell1
+ delsq_divergence(k, cell2) = delsq_divergence(k,cell2) - r_tmp * invAreaCell2
end do
end do
- do iCell = 1,nCells
- r = 1.0 / areaCell(iCell)
- do k = 1,maxLevelCell(iCell)
- delsq_divergence(k,iCell) = delsq_divergence(k,iCell) * r
- end do
- end do
! Compute - \kappa </font>
<font color="black">abla^4 u
! as </font>
<font color="black">abla div(</font>
<font color="black">abla^2 u) + k \times </font>
<font color="black">abla ( k \cross curl(</font>
<font color="gray">abla^2 u) )
- do iEdge=1,grid % nEdgesSolve
+ do iEdge=1,nEdgesSolve
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
vertex1 = verticesOnEdge(1,iEdge)
vertex2 = verticesOnEdge(2,iEdge)
+ invDcEdge = 1.0 / dcEdge(iEdge)
+ invDvEdge = 1.0 / dvEdge(iEdge)
+ r_tmp = meshScalingDel4(iEdge) * eddyVisc4
+
do k=1,maxLevelEdgeTop(iEdge)
- delsq_u(k,iEdge) = &
- ( divergence(k,cell2) - divergence(k,cell1) ) / dcEdge(iEdge) &
- -( vorticity(k,vertex2) - vorticity(k,vertex1)) / dvEdge(iEdge)
+ u_diffusion = (delsq_divergence(k,cell2) - delsq_divergence(k,cell1)) * invDcEdge &
+ -viscVortCoef * (delsq_vorticity(k,vertex2) - delsq_vorticity(k,vertex1) ) * invDvEdge
- u_diffusion = ( delsq_divergence(k,cell2) &
- - delsq_divergence(k,cell1) ) / dcEdge(iEdge) &
- -viscVortCoef &
- *( delsq_vorticity(k,vertex2) &
- - delsq_vorticity(k,vertex1) ) / dvEdge(iEdge)
-
- u_diffusion = meshScalingDel4(iEdge) * eddyVisc4 * u_diffusion
-
- tend(k,iEdge) = tend(k,iEdge) - u_diffusion
+ tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * u_diffusion * r_tmp
end do
end do
deallocate(delsq_divergence)
- deallocate(delsq_u)
- deallocate(delsq_circulation)
deallocate(delsq_vorticity)
- call mpas_timer_stop("compute_tend-horiz mix-del4")
-
!--------------------------------------------------------------------
end subroutine ocn_vel_hmix_del4_tend!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_pressure_grad.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_pressure_grad.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_pressure_grad.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -17,6 +17,7 @@
use mpas_grid_types
use mpas_configure
+ use mpas_constants
implicit none
private
@@ -43,7 +44,7 @@
!
!--------------------------------------------------------------------
- real (kind=RKIND) :: rho0Inv
+ real (kind=RKIND) :: rho0Inv, grho0Inv
!***********************************************************************
@@ -64,7 +65,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_vel_pressure_grad_tend(grid, pressure, tend, err)!{{{
+ subroutine ocn_vel_pressure_grad_tend(grid, pressure, zMid, rho, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -73,7 +74,9 @@
!-----------------------------------------------------------------
real (kind=RKIND), dimension(:,:), intent(in) :: &
- pressure !< Input: Pressure field or Mongomery potential
+ pressure, & !< Input: Pressure field or Mongomery potential
+ zMid, & !< Input: z-coordinate at mid-depth of layer
+ rho !< Input: density
type (mesh_type), intent(in) :: &
grid !< Input: grid information
@@ -103,9 +106,10 @@
integer :: nEdgesSolve, iEdge, k, cell1, cell2
integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: cellsOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask
real (kind=RKIND), dimension(:), pointer :: dcEdge
+ real (kind=RKIND) :: invdcEdge
err = 0
@@ -113,31 +117,35 @@
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
dcEdge => grid % dcEdge % array
+ edgeMask => grid % edgeMask % array
- if (config_vert_grid_type.eq.'isopycnal') then
- do iEdge=1,nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
- tend(k,iEdge) = tend(k,iEdge) &
- - (pressure(k,cell2) - pressure(k,cell1))/dcEdge(iEdge)
- end do
- enddo
- elseif (config_vert_grid_type.eq.'zlevel') then
- do iEdge=1,nEdgesSolve
- cell1 = cellsOnEdge(1,iEdge)
- cell2 = cellsOnEdge(2,iEdge)
- do k=1,maxLevelEdgeTop(iEdge)
+ ! pressure for generalized coordinates
+ ! -1/rho_0 (grad p_k + rho g grad z_k^{mid})
+ ! For pure isopycnal coordinates, we are still using
+ ! grad(M), the gradient of Montgomery Potential, because
+ ! we have set rho0Inv=1 and grho0Inv=0 in the init routine,
+ ! and pressure is passed in as MontPot.
+
+ do iEdge=1,nEdgesSolve
+ cell1 = cellsOnEdge(1,iEdge)
+ cell2 = cellsOnEdge(2,iEdge)
+ invdcEdge = 1.0 / dcEdge(iEdge)
+
+ do k=1,maxLevelEdgeTop(iEdge)
tend(k,iEdge) = tend(k,iEdge) &
- - rho0Inv*( pressure(k,cell2) &
- - pressure(k,cell1) )/dcEdge(iEdge)
- end do
+ - edgeMask(k,iEdge) * rho0Inv*( pressure(k,cell2) &
+ - pressure(k,cell1) )* invdcEdge &
+ - edgeMask(k,iEdge) * grho0Inv* 0.5*(rho(k,cell1)+rho(k,cell2)) &
+ *( zMid(k,cell2) &
+ - zMid(k,cell1) )* invdcEdge
+
+ end do
- enddo
- endif
+ end do
+
!--------------------------------------------------------------------
end subroutine ocn_vel_pressure_grad_tend!}}}
@@ -178,12 +186,16 @@
err = 0
- if (config_vert_grid_type.eq.'isopycnal') then
+ if (config_pressure_type.eq.'MontgomeryPotential') then
rho0Inv = 1.0
- elseif (config_vert_grid_type.eq.'zlevel') then
+ grho0Inv = 0.0
+ else
rho0Inv = 1.0/config_rho0
+ grho0Inv = gravity/config_rho0
end if
+
+
!--------------------------------------------------------------------
end subroutine ocn_vel_pressure_grad_init!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_vadv.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_vadv.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vel_vadv.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -64,7 +64,7 @@
!
!-----------------------------------------------------------------------
- subroutine ocn_vel_vadv_tend(grid, u, wTop, tend, err)!{{{
+ subroutine ocn_vel_vadv_tend(grid, u, h_edge, wTop, tend, err)!{{{
!-----------------------------------------------------------------
!
@@ -75,6 +75,7 @@
real (kind=RKIND), dimension(:,:), intent(in) :: &
u !< Input: Horizontal velocity
real (kind=RKIND), dimension(:,:), intent(in) :: &
+ h_edge,&!< Input: thickness at edge
wTop !< Input: Vertical velocity on top layer
type (mesh_type), intent(in) :: &
@@ -106,12 +107,16 @@
integer :: iEdge, nEdgesSolve, cell1, cell2, k
integer :: nVertLevels
integer, dimension(:), pointer :: maxLevelEdgeTop
- integer, dimension(:,:), pointer :: cellsOnEdge
+ integer, dimension(:,:), pointer :: cellsOnEdge, edgeMask
- real :: wTopEdge
- real, dimension(:), allocatable :: w_dudzTopEdge
- real, dimension(:), pointer :: zMidZLevel
+ real (kind=RKIND) :: wTopEdge
+ real (kind=RKIND), dimension(:), allocatable :: w_dudzTopEdge
+ ! mrp 120202 efficiency note:
+ ! The following if statement is not needed, since wTop is set to
+ ! zero for isopycnal coordinates. This if statment saves flops
+ ! for isopycnal coordinates. However, if the loops are pushed
+ ! out, we could get rid of this if statement.
if(.not.velVadvOn) return
err = 0
@@ -120,10 +125,10 @@
nEdgesSolve = grid % nEdgesSolve
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
cellsOnEdge => grid % cellsOnEdge % array
- zMidZLevel => grid % zMidZLevel % array
+ edgeMask => grid % edgeMask % array
allocate(w_dudzTopEdge(nVertLevels+1))
- w_dudzTopEdge(1) = 0.0
+ w_dudzTopEdge = 0.0
do iEdge=1,nEdgesSolve
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
@@ -134,14 +139,13 @@
! compute dudz at vertical interface with first order derivative.
w_dudzTopEdge(k) = wTopEdge * (u(k-1,iEdge)-u(k,iEdge)) &
- / (zMidZLevel(k-1) - zMidZLevel(k))
+ / (0.5*(h_edge(k-1,iEdge) + h_edge(k,iEdge)))
end do
w_dudzTopEdge(maxLevelEdgeTop(iEdge)+1) = 0.0
! Average w*du/dz from vertical interface to vertical middle of cell
do k=1,maxLevelEdgeTop(iEdge)
- tend(k,iEdge) = tend(k,iEdge) &
- - 0.5 * (w_dudzTopEdge(k) + w_dudzTopEdge(k+1))
+ tend(k,iEdge) = tend(k,iEdge) - edgeMask(k, iEdge) * 0.5 * (w_dudzTopEdge(k) + w_dudzTopEdge(k+1))
enddo
enddo
deallocate(w_dudzTopEdge)
@@ -179,7 +183,7 @@
err = 0
velVadvOn = .false.
- if (config_vert_grid_type.eq.'zlevel') then
+ if (config_vert_grid_type.ne.'isopycnal') then
velVadvOn = .true.
end if
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -199,8 +199,6 @@
if(implicitOn) return
- call mpas_timer_start("compute_tend_u-explicit vert mix")
-
nEdgessolve = grid % nEdgesSolve
nVertLevels = grid % nVertLevels
maxLevelEdgeTop => grid % maxLevelEdgeTop % array
@@ -223,9 +221,6 @@
end do
deallocate(fluxVertTop)
-
- call mpas_timer_stop("compute_tend_u-explicit vert mix")
-
!--------------------------------------------------------------------
end subroutine ocn_vel_vmix_tend_explicit!}}}
@@ -319,7 +314,6 @@
! mrp 110315 efficiency note: for z-level, could precompute
! -2.0*dt/(h(k)_h(k+1))/h(k) in setup
! h_edge is computed in compute_solve_diag, and is not available yet.
- ! This could be removed if hZLevel used instead.
cell1 = cellsOnEdge(1,iEdge)
cell2 = cellsOnEdge(2,iEdge)
do k=1,maxLevelEdgeTop(iEdge)
@@ -347,6 +341,8 @@
end if
end do
+ deallocate(A,C,uTemp)
+
!--------------------------------------------------------------------
end subroutine ocn_vel_vmix_tend_implicit!}}}
@@ -418,8 +414,6 @@
if(implicitOn) return
- call mpas_timer_start("compute_scalar_tend-explicit vert diff")
-
nCellsSolve = grid % nCellsSolve
nVertLevels = grid % nVertLevels
num_tracers = size(tracers, dim=1)
@@ -454,9 +448,6 @@
!print '(a,50e12.2)', 'tend_tr ',tend_tr(3,1,1:maxLevelCell(iCell))
enddo ! iCell loop
deallocate(fluxVertTop)
-
- call mpas_timer_stop("compute_scalar_tend-explicit vert diff")
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_vmix_tend_explicit!}}}
@@ -558,9 +549,9 @@
tracers(:,1:maxLevelCell(iCell),iCell) = tracersTemp(:,1:maxLevelCell(iCell))
tracers(:,maxLevelCell(iCell)+1:nVertLevels,iCell) = -1e34
end do
+
deallocate(A,C,tracersTemp)
-
!--------------------------------------------------------------------
end subroutine ocn_tracer_vmix_tend_implicit!}}}
@@ -602,7 +593,7 @@
if(config_implicit_vertical_mix) then
explicitOn = .false.
- implicitOn =.true.
+ implicitOn = .true.
end if
call ocn_vmix_coefs_const_init(err1)
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix_coefs_rich.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix_coefs_rich.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -26,6 +26,8 @@
private
save
+ type (timer_node), pointer :: richEOSTimer
+
!--------------------------------------------------------------------
!
! Public parameters
@@ -139,8 +141,10 @@
rhoDisplaced => s % rhoDisplaced % array
tracers => s % tracers % array
+ call mpas_timer_start("eos rich", .false., richEOSTimer)
call ocn_equation_of_state_rho(s, grid, 0, 'relative', err)
call ocn_equation_of_state_rho(s, grid, 1, 'relative', err)
+ call mpas_timer_stop("eos rich", richEOSTimer)
call ocn_vmix_get_rich_numbers(grid, indexT, indexS, u, h, h_edge, &
rho, rhoDisplaced, tracers, RiTopOfEdge, RiTopOfCell, err1)
@@ -244,8 +248,6 @@
else
! for Ri<0 and explicit vertical mix,
! use maximum diffusion allowed by CFL criterion
- ! mrp 110324 efficiency note: for z-level, could use fixed
- ! grid array hMeanTopZLevel and compute maxdiff on startup.
vertViscTopOfEdge(k,iEdge) = &
((h_edge(k-1,iEdge)+h_edge(k,iEdge))/2.0)**2/config_dt/4.0
end if
@@ -353,8 +355,6 @@
else
! for Ri<0 and explicit vertical mix,
! use maximum diffusion allowed by CFL criterion
- ! mrp 110324 efficiency note: for z-level, could use fixed
- ! grid array hMeanTopZLevel and compute maxdiff on startup.
vertDiffTopOfCell(k,iCell) = &
((h(k-1,iCell)+h(k,iCell))/2.0)**2/config_dt/4.0
end if
@@ -440,7 +440,7 @@
err = 0
- if(.not.richViscOn .and. .not.richDiffOn) return
+ if((.not.richViscOn) .and. (.not.richDiffOn)) return
nVertLevels = grid % nVertLevels
nCells = grid % nCells
@@ -455,8 +455,8 @@
areaCell => grid % areaCell % array
allocate( &
- drhoTopOfCell(nVertLevels+1,nCells+1), drhoTopOfEdge(nVertLevels+1,nEdges+1), &
- du2TopOfCell(nVertLevels+1,nCells+1), du2TopOfEdge(nVertLevels+1,nEdges+1))
+ drhoTopOfCell(nVertLevels+1,nCells+1), drhoTopOfEdge(nVertLevels+1,nEdges), &
+ du2TopOfCell(nVertLevels+1,nCells+1), du2TopOfEdge(nVertLevels+1,nEdges))
! compute density of parcel displaced to next deeper z-level,
! in state % rhoDisplaced
Modified: branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_ocean/mpas_ocn_vmix_coefs_tanh.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -177,18 +177,22 @@
integer :: k, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: zTopZLevel
+ real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth
err = 0
if(.not.tanhViscOn) return
nVertLevels = grid % nVertLevels
- zTopZLevel => grid % zTopZLevel % array
+ referenceBottomDepth => grid % referenceBottomDepth % array
- do k=1,nVertLevels+1
- vertViscTopOfEdge(k,:) = -(config_max_visc_tanh-config_min_visc_tanh)/2.0 &
- *tanh(-(zTopZLevel(k)-config_ZMid_tanh) &
+ ! referenceBottomDepth is used here for simplicity. Using zMid and h, which
+ ! vary in time, would give the exact location of the top, but it
+ ! would only change the diffusion value very slightly.
+ vertViscTopOfEdge = 0.0
+ do k=2,nVertLevels
+ vertViscTopOfEdge(k,:) = -(config_max_visc_tanh-config_min_visc_tanh)/2.0 &
+ *tanh((referenceBottomDepth(k-1)+config_ZMid_tanh) &
/config_zWidth_tanh) &
+ (config_max_visc_tanh+config_min_visc_tanh)/2
end do
@@ -246,18 +250,22 @@
integer :: k, nVertLevels
- real (kind=RKIND), dimension(:), pointer :: zTopZLevel
+ real (kind=RKIND), dimension(:), pointer :: referenceBottomDepth
err = 0
if(.not.tanhDiffOn) return
nVertLevels = grid % nVertLevels
- zTopZLevel => grid % zTopZLevel % array
+ referenceBottomDepth => grid % referenceBottomDepth % array
- do k=1,nVertLevels+1
+ ! referenceBottomDepth is used here for simplicity. Using zMid and h, which
+ ! vary in time, would give the exact location of the top, but it
+ ! would only change the diffusion value very slightly.
+ vertDiffTopOfCell = 0.0
+ do k=2,nVertLevels
vertDiffTopOfCell(k,:) = -(config_max_diff_tanh-config_min_diff_tanh)/2.0 &
- *tanh(-(zTopZLevel(k)-config_ZMid_tanh) &
+ *tanh((referenceBottomDepth(k-1)+config_ZMid_tanh) &
/config_zWidth_tanh) &
+ (config_max_diff_tanh+config_min_diff_tanh)/2
end do
@@ -308,14 +316,6 @@
tanhDiffOn = .true.
endif
- if(tanhViscOn .or. tanhDiffOn) then
- if (config_vert_grid_type.ne.'zlevel') then
- write(0,*) 'Abort: config_vert_diff_type.eq.tanh may only', &
- ' use config_vert_grid_type of zlevel at this time'
- err = 1
- endif
- endif
-
!--------------------------------------------------------------------
end subroutine ocn_vmix_coefs_tanh_init!}}}
Modified: branches/ocean_projects/pio_trunk_merge/src/core_sw/Registry
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_sw/Registry 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_sw/Registry 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,10 +1,10 @@
-#
-# namelist type namelist_record name default_value
-#
+%
+% namelist type namelist_record name default_value
+%
namelist integer sw_model config_test_case 5
namelist character sw_model config_time_integration RK4
namelist real sw_model config_dt 172.8
-namelist integer sw_model config_calendar_type MPAS_360DAY
+namelist character sw_model config_calendar_type 360day
namelist character sw_model config_start_time 0000-01-01_00:00:00
namelist character sw_model config_stop_time none
namelist character sw_model config_run_duration none
@@ -32,9 +32,9 @@
namelist logical restart config_do_restart false
namelist character restart config_restart_interval none
-#
-# dim type name_in_file name_in_code
-#
+%
+% dim type name_in_file name_in_code
+%
dim nCells nCells
dim nEdges nEdges
dim maxEdges maxEdges
@@ -48,9 +48,9 @@
dim nVertLevels nVertLevels
dim nTracers nTracers
-#
-# var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
-#
+%
+% var persistence type name_in_file ( dims ) time_levs iro- name_in_code struct super-array array_class
+%
var persistent text xtime ( Time ) 2 ro xtime state - -
var persistent real latCell ( nCells ) 0 iro latCell mesh - -
@@ -106,37 +106,37 @@
var persistent real fCell ( nCells ) 0 iro fCell mesh - -
var persistent real h_s ( nCells ) 0 iro h_s mesh - -
-# Space needed for advection
+% Space needed for advection
var persistent real deriv_two ( FIFTEEN TWO nEdges ) 0 o deriv_two mesh - -
var persistent integer advCells ( TWENTYONE nCells ) 0 - advCells mesh - -
-# !! NOTE: the following arrays are needed to allow the use
-# !! of the module_advection.F w/o alteration
-# Space needed for deformation calculation weights
+% !! NOTE: the following arrays are needed to allow the use
+% !! of the module_advection.F w/o alteration
+% Space needed for deformation calculation weights
var persistent real defc_a ( maxEdges nCells ) 0 - defc_a mesh - -
var persistent real defc_b ( maxEdges nCells ) 0 - defc_b mesh - -
var persistent real kdiff ( nVertLevels nCells Time ) 0 - kdiff mesh - -
-# Arrays required for reconstruction of velocity field
+% Arrays required for reconstruction of velocity field
var persistent real coeffs_reconstruct ( R3 maxEdges nCells ) 0 - coeffs_reconstruct mesh - -
-# Boundary conditions: read from input, saved in restart and written to output
+% Boundary conditions: read from input, saved in restart and written to output
var persistent integer boundaryEdge ( nVertLevels nEdges ) 0 iro boundaryEdge mesh - -
var persistent integer boundaryVertex ( nVertLevels nVertices ) 0 iro boundaryVertex mesh - -
var persistent integer boundaryCell ( nVertLevels nCells ) 0 iro boundaryCell mesh - -
var persistent real u_src ( nVertLevels nEdges ) 0 iro u_src mesh - -
-# Prognostic variables: read from input, saved in restart, and written to output
+% Prognostic variables: read from input, saved in restart, and written to output
var persistent real u ( nVertLevels nEdges Time ) 2 iro u state - -
var persistent real h ( nVertLevels nCells Time ) 2 iro h state - -
var persistent real tracers ( nTracers nVertLevels nCells Time ) 2 iro tracers state - -
-# Tendency variables
+% Tendency variables
var persistent real tend_u ( nVertLevels nEdges Time ) 1 - u tend - -
var persistent real tend_h ( nVertLevels nCells Time ) 1 - h tend - -
var persistent real tend_tracers ( nTracers nVertLevels nCells Time ) 1 - tracers tend - -
-# Diagnostic fields: only written to output
+% Diagnostic fields: only written to output
var persistent real v ( nVertLevels nEdges Time ) 2 o v state - -
var persistent real divergence ( nVertLevels nCells Time ) 2 o divergence state - -
var persistent real vorticity ( nVertLevels nVertices Time ) 2 o vorticity state - -
@@ -152,7 +152,7 @@
var persistent real uReconstructZonal ( nVertLevels nCells Time ) 2 o uReconstructZonal state - -
var persistent real uReconstructMeridional ( nVertLevels nCells Time ) 2 o uReconstructMeridional state - -
-# Other diagnostic variables: neither read nor written to any files
+% Other diagnostic variables: neither read nor written to any files
var persistent real vh ( nVertLevels nEdges Time ) 2 - vh state - -
var persistent real circulation ( nVertLevels nVertices Time ) 2 - circulation state - -
var persistent real gradPVt ( nVertLevels nEdges Time ) 2 - gradPVt state - -
Modified: branches/ocean_projects/pio_trunk_merge/src/core_sw/mpas_sw_advection.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_sw/mpas_sw_advection.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_sw/mpas_sw_advection.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,6 @@
module sw_advection
+ use mpas_kind_types
use mpas_grid_types
use mpas_configure
use mpas_constants
@@ -117,7 +118,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -390,7 +391,7 @@
! Computes the angle between arcs AB and AC, given points A, B, and C
! Equation numbers w.r.t. http://mathworld.wolfram.com/SphericalTrigonometry.html
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
+ real (kind=RKIND) function sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz)
implicit none
@@ -410,9 +411,9 @@
real (kind=RKIND) :: s ! Semiperimeter of the triangle
real (kind=RKIND) :: sin_angle
- a = acos(max(min(bx*cx + by*cy + bz*cz,1.0),-1.0)) ! Eqn. (3)
- b = acos(max(min(ax*cx + ay*cy + az*cz,1.0),-1.0)) ! Eqn. (2)
- c = acos(max(min(ax*bx + ay*by + az*bz,1.0),-1.0)) ! Eqn. (1)
+ a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3)
+ b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2)
+ c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1)
ABx = bx - ax
ABy = by - ay
@@ -428,12 +429,12 @@
s = 0.5*(a + b + c)
! sin_angle = sqrt((sin(s-b)*sin(s-c))/(sin(b)*sin(c))) ! Eqn. (28)
- sin_angle = sqrt(min(1.,max(0.,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
+ sin_angle = sqrt(min(1.0_RKIND,max(0.0_RKIND,(sin(s-b)*sin(s-c))/(sin(b)*sin(c))))) ! Eqn. (28)
if ((Dx*ax + Dy*ay + Dz*az) >= 0.0) then
- sphere_angle = 2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = 2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
else
- sphere_angle = -2.0 * asin(max(min(sin_angle,1.0),-1.0))
+ sphere_angle = -2.0 * asin(max(min(sin_angle,1.0_RKIND),-1.0_RKIND))
end if
end function sphere_angle
@@ -445,7 +446,7 @@
! Computes the angle between vectors AB and AC, given points A, B, and C, and
! a vector (u,v,w) normal to the plane.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
+ real (kind=RKIND) function plane_angle(ax, ay, az, bx, by, bz, cx, cy, cz, u, v, w)
implicit none
@@ -480,9 +481,9 @@
cos_angle = (ABx*ACx + ABy*ACy + ABz*ACz) / (mAB * mAC)
if ((Dx*u + Dy*v + Dz*w) >= 0.0) then
- plane_angle = acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
else
- plane_angle = -acos(max(min(cos_angle,1.0),-1.0))
+ plane_angle = -acos(max(min(cos_angle,1.0_RKIND),-1.0_RKIND))
end if
end function plane_angle
@@ -495,7 +496,7 @@
! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the
! same sphere centered at the origin.
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- real function arc_length(ax, ay, az, bx, by, bz)
+ real (kind=RKIND) function arc_length(ax, ay, az, bx, by, bz)
implicit none
@@ -838,7 +839,7 @@
theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), &
xc(2), yc(2), zc(2), &
- 0., 0., 1. )
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND )
! angles from cell center to neighbor centers (thetav)
@@ -890,10 +891,10 @@
do i=2,n-1
ip1 = i+1
if (ip1 == n) ip1 = 1
- thetat(i) = plane_angle( 0.,0.,0., &
- xp(i)-xp(i-1), yp(i)-yp(i-1), 0., &
- xp(ip1)-xp(i), yp(ip1)-yp(i), 0., &
- 0., 0., 1.)
+ thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, &
+ xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, &
+ xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, &
+ 0.0_RKIND, 0.0_RKIND, 1.0_RKIND)
thetat(i) = thetat(i) + thetat(i-1)
end do
Modified: branches/ocean_projects/pio_trunk_merge/src/core_sw/mpas_sw_time_integration.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/core_sw/mpas_sw_time_integration.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/core_sw/mpas_sw_time_integration.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -123,10 +123,10 @@
block % parinfo % edgesToSend, block % parinfo % edgesToRecv)
if (config_h_mom_eddy_visc4 > 0.0) then
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % divergence % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % divergence % array(:,:), &
block % mesh % nVertLevels, block % mesh % nCells, &
block % parinfo % cellsToSend, block % parinfo % cellsToRecv)
- call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, block % state % time_levs(2) % state % vorticity % array(:,:), &
+ call mpas_dmpar_exch_halo_field2d_real(domain % dminfo, provis % vorticity % array(:,:), &
block % mesh % nVertLevels, block % mesh % nVertices, &
block % parinfo % verticesToSend, block % parinfo % verticesToRecv)
end if
Modified: branches/ocean_projects/pio_trunk_merge/src/external/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/external/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/external/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -3,7 +3,7 @@
all: esmf_time
esmf_time:
- ( cd esmf_time_f90; make FC="$(FC) $(FFLAGS)" CPP="$(CPP)" )
+ ( cd esmf_time_f90; $(MAKE) FC="$(FC) $(FFLAGS)" CPP="$(CPP)" )
clean:
- ( cd esmf_time_f90; make clean )
+ ( cd esmf_time_f90; $(MAKE) clean )
Modified: branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/ESMF_Calendar.F90
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/ESMF_Calendar.F90 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/ESMF_Calendar.F90 2012-03-28 22:32:39 UTC (rev 1732)
@@ -51,14 +51,23 @@
INTEGER, PARAMETER :: MONTHS_PER_YEAR = 12
- INTEGER, PARAMETER :: mday(MONTHS_PER_YEAR) &
+
+ INTEGER, PARAMETER :: daysPerMonthNoLeap(MONTHS_PER_YEAR) &
= (/31,28,31,30,31,30,31,31,30,31,30,31/)
- INTEGER, PARAMETER :: mdayleap(MONTHS_PER_YEAR) &
+ INTEGER, PARAMETER :: daysPerMonthLeap(MONTHS_PER_YEAR) &
= (/31,29,31,30,31,30,31,31,30,31,30,31/)
- INTEGER, DIMENSION(365) :: daym
- INTEGER, DIMENSION(366) :: daymleap
+ INTEGER, PARAMETER :: daysPerMonth360(MONTHS_PER_YEAR) &
+ = (/30,30,30,30,30,30,30,30,30,30,30,30/)
+
+ INTEGER, DIMENSION(MONTHS_PER_YEAR) :: mday
+ INTEGER, DIMENSION(MONTHS_PER_YEAR) :: mdayleap
+
+ INTEGER, DIMENSION(:), POINTER :: daym
+ INTEGER, DIMENSION(:), POINTER :: daymleap
+
INTEGER :: mdaycum(0:MONTHS_PER_YEAR)
INTEGER :: mdayleapcum(0:MONTHS_PER_YEAR)
+
TYPE(ESMF_BaseTime), TARGET :: monthbdys(0:MONTHS_PER_YEAR)
TYPE(ESMF_BaseTime), TARGET :: monthbdysleap(0:MONTHS_PER_YEAR)
@@ -69,7 +78,6 @@
! ! F90 "enum" type to match C++ ESMC_CalendarType enum
type ESMF_CalendarType
- private
integer :: caltype
end type
@@ -152,7 +160,10 @@
!
! !PUBLIC MEMBER FUNCTIONS:
public ESMF_CalendarCreate
+ public ESMF_CalendarDestroy
+ public ESMF_GetCalendarType
+
! Required inherited and overridden ESMF_Base class methods
public ESMF_CalendarInitialized ! Only in this implementation, intended
@@ -165,6 +176,14 @@
!==============================================================================
+
+
+ type(ESMF_CalendarType) function ESMF_GetCalendarType()
+ ESMF_GetCalendarType = defaultCal % Type
+ end function ESMF_GetCalendarType
+
+
+!==============================================================================
!BOP
! !IROUTINE: ESMF_CalendarCreate - Create a new ESMF Calendar of built-in type
@@ -210,50 +229,61 @@
type(ESMF_DaysPerYear) :: dayspy
if ( present(rc) ) rc = ESMF_FAILURE
-! Calendar type is hard-coded. Use ESMF library if more flexibility is
-! needed.
-#ifdef NO_LEAP_CALENDAR
- if ( calendartype%caltype /= ESMF_CAL_NOLEAP%caltype ) then
+
+ if ( calendartype % caltype == ESMF_CAL_GREGORIAN % caltype ) then
+ ESMF_CalendarCreate % Type = ESMF_CAL_GREGORIAN
+ mday = daysPerMonthNoLeap
+ mdayleap = daysPerMonthLeap
+ allocate(daym(365))
+ allocate(daymleap(366))
+ else if ( calendartype % caltype == ESMF_CAL_NOLEAP % caltype ) then
+ ESMF_CalendarCreate % Type = ESMF_CAL_NOLEAP
+ mday = daysPerMonthNoLeap
+ mdayleap = daysPerMonthNoLeap
+ allocate(daym(365))
+ allocate(daymleap(365))
+ else if ( calendartype % caltype == ESMF_CAL_360DAY % caltype ) then
+ ESMF_CalendarCreate % Type = ESMF_CAL_360DAY
+ mday = daysPerMonth360
+ mdayleap = daysPerMonth360
+ allocate(daym(360))
+ allocate(daymleap(360))
+ else
write(6,*) 'Not a valid calendar type for this implementation'
- write(6,*) 'This implementation only allows ESMF_CAL_NOLEAP'
- write(6,*) 'calender type set to = ', calendartype%caltype
- write(6,*) 'NO_LEAP calendar type is = ', ESMF_CAL_NOLEAP%caltype
+ write(6,*) 'The current implementation only supports ESMF_CAL_NOLEAP, ESMF_CAL_GREGORIAN, ESMF_CAL_360DAY'
return
end if
- ESMF_CalendarCreate%Type = ESMF_CAL_NOLEAP
-#else
- if ( calendartype%caltype /= ESMF_CAL_GREGORIAN%caltype ) then
- write(6,*) 'Not a valid calendar type for this implementation'
- write(6,*) 'This implementation only allows ESMF_CAL_GREGORIAN'
- write(6,*) 'calender type set to = ', calendartype%caltype
- write(6,*) 'GREGORIAN calendar type is = ', ESMF_CAL_GREGORIAN%caltype
- return
- end if
- ESMF_CalendarCreate%Type = ESMF_CAL_GREGORIAN
-#endif
-! This is a bug on some systems -- need initial value set by compiler at
-! startup.
-! However, note that some older compilers do not support compile-time
-! initialization of data members of Fortran derived data types. For example,
-! PGI 5.x compilers do not support this F95 feature. See
-! NO_DT_COMPONENT_INIT.
- ESMF_CalendarCreate%Set = .true.
- ESMF_CalendarCreate%SecondsPerDay = SECONDS_PER_DAY
-! DaysPerYear and SecondsPerYear are incorrect for Gregorian calendars...
- dayspy%D = size(daym)
-!TBH: TODO: Replace DaysPerYear and SecondsPerYear with methods
-!TBH: TODO: since they only make sense for the NO_LEAP calendar!
- ESMF_CalendarCreate%DaysPerYear = dayspy
- ESMF_CalendarCreate%SecondsPerYear = ESMF_CalendarCreate%SecondsPerDay &
- * dayspy%D
-!TBH: TODO: use mdayleap for leap-year calendar
- ESMF_CalendarCreate%DaysPerMonth(:) = mday(:)
+ ESMF_CalendarCreate % Set = .true.
+ ESMF_CalendarCreate % DaysPerMonth(:) = mday(:)
+ ESMF_CalendarCreate % SecondsPerDay = SECONDS_PER_DAY
+
+!TBH: TODO: Replace DaysPerYear and SecondsPerYear with methods
+!TBH: TODO: since they only make sense for the NO_LEAP calendar!
+ dayspy % D = size(daym)
+ ESMF_CalendarCreate % DaysPerYear = dayspy
+ ESMF_CalendarCreate % SecondsPerYear = ESMF_CalendarCreate % SecondsPerDay * dayspy % D
+
if ( present(rc) ) rc = ESMF_SUCCESS
- end function ESMF_CalendarCreate
+ end function ESMF_CalendarCreate
+ subroutine ESMF_CalendarDestroy(rc)
+
+ integer, intent(out), optional :: rc
+
+ if ( present(rc) ) rc = ESMF_FAILURE
+
+ deallocate(daym)
+ deallocate(daymleap)
+
+ if ( present(rc) ) rc = ESMF_SUCCESS
+
+ end subroutine ESMF_CalendarDestroy
+
+
+
!==============================================================================
!BOP
! !IROUTINE: ESMF_CalendarInitialized - check if calendar was created
Modified: branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/ESMF_Stubs.F90
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/ESMF_Stubs.F90 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/ESMF_Stubs.F90 2012-03-28 22:32:39 UTC (rev 1732)
@@ -91,6 +91,8 @@
! NOOP
SUBROUTINE ESMF_Finalize( rc )
USE esmf_basemod
+ USE esmf_calendarmod
+
INTEGER, INTENT( OUT), OPTIONAL :: rc
#if (defined SPMD) || (defined COUP_CSM)
#include <mpif.h>
@@ -98,6 +100,8 @@
LOGICAL :: flag
INTEGER :: ier
+ CALL ESMF_CalendarDestroy()
+
IF ( PRESENT( rc ) ) rc = ESMF_SUCCESS
#if (defined SPMD) || (defined COUP_CSM)
CALL MPI_Finalized( flag, ier )
Modified: branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/Meat.F90
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/Meat.F90 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/external/esmf_time_f90/Meat.F90 2012-03-28 22:32:39 UTC (rev 1732)
@@ -169,26 +169,34 @@
! added from share/module_date_time in WRF.
FUNCTION nfeb ( year ) RESULT (num_days)
+ USE ESMF_CalendarMod
+
! Compute the number of days in February for the given year
IMPLICIT NONE
INTEGER :: year
INTEGER :: num_days
-! TBH: TODO: Replace this hack with run-time decision based on
-! TBH: TODO: passed-in calendar.
-#ifdef NO_LEAP_CALENDAR
- num_days = 28 ! By default, February has 28 days ...
-#else
- num_days = 28 ! By default, February has 28 days ...
- IF (MOD(year,4).eq.0) THEN
- num_days = 29 ! But every four years, it has 29 days ...
- IF (MOD(year,100).eq.0) THEN
- num_days = 28 ! Except every 100 years, when it has 28 days ...
- IF (MOD(year,400).eq.0) THEN
- num_days = 29 ! Except every 400 years, when it has 29 days.
+
+ type(ESMF_CalendarType) :: calendarType
+
+ calendarType = ESMF_GetCalendarType()
+
+ IF (calendarType % caltype == ESMF_CAL_NOLEAP % caltype) then
+ num_days = 28
+ ELSE IF (calendarType % caltype == ESMF_CAL_360DAY % caltype) then
+ num_days = 30
+ ELSE
+ num_days = 28 ! By default, February has 28 days ...
+ IF (MOD(year,4).eq.0) THEN
+ num_days = 29 ! But every four years, it has 29 days ...
+ IF (MOD(year,100).eq.0) THEN
+ num_days = 28 ! Except every 100 years, when it has 28 days ...
+ IF (MOD(year,400).eq.0) THEN
+ num_days = 29 ! Except every 400 years, when it has 29 days.
+ END IF
END IF
END IF
END IF
-#endif
+
END FUNCTION nfeb
@@ -206,6 +214,8 @@
#else
IF ( nfeb( year ) .EQ. 29 ) THEN
num_diy = 366
+ ELSE IF ( nfeb( year ) .EQ. 30 ) THEN
+ num_diy = 360
ELSE
num_diy = 365
ENDIF
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/Makefile
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/Makefile 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/Makefile 2012-03-28 22:32:39 UTC (rev 1732)
@@ -4,7 +4,8 @@
ZOLTANOBJ = mpas_zoltan_interface.o
endif
-OBJS = mpas_framework.o \
+OBJS = mpas_kind_types.o \
+ mpas_framework.o \
mpas_timer.o \
mpas_timekeeping.o \
mpas_configure.o \
@@ -28,10 +29,18 @@
mpas_configure.o: mpas_dmpar.o
+mpas_constants.o: mpas_kind_types.o
+
mpas_grid_types.o: mpas_dmpar.o
-mpas_dmpar.o: mpas_sort.o streams.o
+mpas_dmpar.o: mpas_sort.o streams.o mpas_kind_types.o
+mpas_sort.o: mpas_kind_types.o
+
+mpas_timekeeping.o: mpas_kind_types.o
+
+mpas_timer.o: mpas_kind_types.o
+
mpas_block_decomp.o: mpas_grid_types.o mpas_hash.o mpas_configure.o
mpas_io_input.o: mpas_grid_types.o mpas_dmpar.o mpas_block_decomp.o mpas_sort.o mpas_configure.o mpas_timekeeping.o $(ZOLTANOBJ)
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_configure.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_configure.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_configure.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -13,7 +13,7 @@
type (dm_info), intent(in) :: dminfo
- integer :: funit
+ integer :: funit, ierr
#include "config_namelist_defs.inc"
@@ -23,10 +23,12 @@
#include "config_set_defaults.inc"
if (dminfo % my_proc_id == IO_NODE) then
+ write(0,*) 'Reading namelist.input'
open(funit,file='namelist.input',status='old',form='formatted')
#include "config_namelist_reads.inc"
close(funit)
+ write(0,*) ' '
end if
#include "config_bcast_namelist.inc"
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_constants.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_constants.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_constants.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,7 @@
module mpas_constants
+ use mpas_kind_types
+
real (kind=RKIND), parameter :: pii = 3.141592653589793
real (kind=RKIND), parameter :: a = 6371229.0
real (kind=RKIND), parameter :: omega = 7.29212e-5
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_dmpar.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_dmpar.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_dmpar.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,15 +1,16 @@
module mpas_dmpar
+ use mpas_kind_types
use mpas_sort
#ifdef _MPI
include 'mpif.h'
integer, parameter :: MPI_INTEGERKIND = MPI_INTEGER
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ integer, parameter :: MPI_REALKIND = MPI_REAL
+#else
integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION
-#else
- integer, parameter :: MPI_REALKIND = MPI_REAL
#endif
#endif
@@ -19,6 +20,7 @@
type dm_info
integer :: nprocs, my_proc_id, comm, info
+ logical :: using_external_comm
end type dm_info
@@ -45,23 +47,30 @@
contains
- subroutine mpas_dmpar_init(dminfo)
+ subroutine mpas_dmpar_init(dminfo, mpi_comm)
implicit none
type (dm_info), intent(inout) :: dminfo
+ integer, intent(in), optional :: mpi_comm ! Optional: externally-supplied MPI communicator
#ifdef _MPI
integer :: mpi_rank, mpi_size
integer :: mpi_ierr
+ if (present(mpi_comm)) then
+ dminfo % comm = mpi_comm
+ dminfo % using_external_comm = .true.
+ else
+ call MPI_Init(mpi_ierr)
+ dminfo % comm = MPI_COMM_WORLD
+ dminfo % using_external_comm = .false.
+ end if
+
! Find out our rank and the total number of processors
- call MPI_Init(mpi_ierr)
- call MPI_Comm_rank(MPI_COMM_WORLD, mpi_rank, mpi_ierr)
- call MPI_Comm_size(MPI_COMM_WORLD, mpi_size, mpi_ierr)
+ call MPI_Comm_rank(dminfo % comm, mpi_rank, mpi_ierr)
+ call MPI_Comm_size(dminfo % comm, mpi_size, mpi_ierr)
- dminfo % comm = MPI_COMM_WORLD
-
dminfo % nprocs = mpi_size
dminfo % my_proc_id = mpi_rank
@@ -75,6 +84,7 @@
dminfo % comm = 0
dminfo % my_proc_id = IO_NODE
dminfo % nprocs = 1
+ dminfo % using_external_comm = .false.
#endif
end subroutine mpas_dmpar_init
@@ -89,7 +99,9 @@
#ifdef _MPI
integer :: mpi_ierr
- call MPI_Finalize(mpi_ierr)
+ if (.not. dminfo % using_external_comm) then
+ call MPI_Finalize(mpi_ierr)
+ end if
#endif
end subroutine mpas_dmpar_finalize
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_io_input.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_io_input.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_io_input.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1228,10 +1228,10 @@
#include "input_field0dreal.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
#endif
end subroutine mpas_io_input_field0d_real
@@ -1263,10 +1263,10 @@
#include "input_field1dreal.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % array)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % array)
#endif
end subroutine mpas_io_input_field1d_real
@@ -1292,10 +1292,10 @@
#include "input_field2dreal.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
#endif
end subroutine mpas_io_input_field2d_real
@@ -1323,10 +1323,10 @@
#include "input_field3dreal.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
#endif
end subroutine mpas_io_input_field3d_real
@@ -1350,10 +1350,10 @@
#include "input_field0dreal_time.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start1, count1, field % scalar)
#endif
end subroutine mpas_io_input_field0d_real_time
@@ -1379,10 +1379,10 @@
#include "input_field1dreal_time.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start2, count2, field % array)
#endif
end subroutine mpas_io_input_field1d_real_time
@@ -1410,10 +1410,10 @@
#include "input_field2dreal_time.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start3, count3, field % array)
#endif
end subroutine mpas_io_input_field2d_real_time
@@ -1443,10 +1443,10 @@
#include "input_field3dreal_time.inc"
-#if (RKIND == 8)
+#if SINGLE_PRECISION
+ nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start4, count4, field % array)
+#else
nferr = nf_get_vara_double(input_obj % rd_ncid, varID, start4, count4, field % array)
-#else
- nferr = nf_get_vara_real(input_obj % rd_ncid, varID, start4, count4, field % array)
#endif
end subroutine mpas_io_input_field3d_real_time
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_io_output.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_io_output.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_io_output.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -522,10 +522,10 @@
#include "output_field0dreal.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -551,10 +551,10 @@
#include "output_field1dreal.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, VarID, start1, count1, field % array)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, VarID, start1, count1, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, VarID, start1, count1, field % array)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -582,10 +582,10 @@
#include "output_field2dreal.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -615,10 +615,10 @@
#include "output_field3dreal.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -644,10 +644,10 @@
#include "output_field0dreal_time.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start1, count1, field % scalar)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start1, count1, field % scalar)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -675,10 +675,10 @@
#include "output_field1dreal_time.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start2, count2, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start2, count2, field % array)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -708,10 +708,10 @@
#include "output_field2dreal_time.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start3, count3, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start3, count3, field % array)
#endif
nferr = nf_sync(output_obj % wr_ncid)
@@ -743,10 +743,10 @@
#include "output_field3dreal_time.inc"
-#if (RKIND == 8)
+#ifdef SINGLE_PRECISION
+ nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start4, count4, field % array)
+#else
nferr = nf_put_vara_double(output_obj % wr_ncid, varID, start4, count4, field % array)
-#else
- nferr = nf_put_vara_real(output_obj % wr_ncid, varID, start4, count4, field % array)
#endif
nferr = nf_sync(output_obj % wr_ncid)
Copied: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_kind_types.F (from rev 1731, trunk/mpas/src/framework/mpas_kind_types.F)
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_kind_types.F (rev 0)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_kind_types.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -0,0 +1,15 @@
+module mpas_kind_types
+
+#ifdef SINGLE_PRECISION
+ integer, parameter :: RKIND = selected_real_kind(6)
+#else
+ integer, parameter :: RKIND = selected_real_kind(12)
+#endif
+
+ contains
+
+ subroutine dummy_kinds()
+
+ end subroutine dummy_kinds
+
+end module mpas_kind_types
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_sort.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_sort.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_sort.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,7 @@
module mpas_sort
+ use mpas_kind_types
+
interface quicksort
module procedure mpas_quicksort_int
module procedure mpas_quicksort_real
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_timekeeping.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_timekeeping.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_timekeeping.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,6 @@
module mpas_timekeeping
+ use mpas_kind_types
use ESMF_BaseMod
use ESMF_Stubs
use ESMF_CalendarMod
@@ -113,15 +114,16 @@
implicit none
- integer, intent(in) :: calendar
+ character (len=*), intent(in) :: calendar
- TheCalendar = calendar
-
- if (TheCalendar == MPAS_GREGORIAN) then
+ if (trim(calendar) == 'gregorian') then
+ TheCalendar = MPAS_GREGORIAN
call ESMF_Initialize(defaultCalendar=ESMF_CAL_GREGORIAN)
- else if (TheCalendar == MPAS_GREGORIAN_NOLEAP) then
+ else if (trim(calendar) == 'gregorian_noleap') then
+ TheCalendar = MPAS_GREGORIAN_NOLEAP
call ESMF_Initialize(defaultCalendar=ESMF_CAL_NOLEAP)
- else if (TheCalendar == MPAS_360DAY) then
+ else if (trim(calendar) == '360day') then
+ TheCalendar = MPAS_360DAY
call ESMF_Initialize(defaultCalendar=ESMF_CAL_360DAY)
else
write(0,*) 'ERROR: mpas_timekeeping_init: Invalid calendar type'
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/mpas_timer.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/mpas_timer.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/mpas_timer.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,8 @@
module mpas_timer
+ use mpas_grid_types
+ use mpas_dmpar
+
implicit none
save
! private
@@ -8,9 +11,9 @@
include 'f90papi.h'
#endif
-#ifdef _MPI
- include 'mpif.h'
-#endif
+!#ifdef _MPI
+! include 'mpif.h'
+!#endif
type timer_node
character (len=72) :: timer_name
@@ -18,15 +21,19 @@
integer :: levels, calls
real (kind=RKIND) :: start_time, end_time, total_time
real (kind=RKIND) :: max_time, min_time, avg_time
+ real (kind=RKIND) :: efficiency
type (timer_node), pointer :: next
end type timer_node
type (timer_node), pointer :: all_timers
- integer :: levels
+ integer :: levels, synced
+ type (dm_info), pointer :: domain_info
+
public :: mpas_timer_start, &
mpas_timer_stop, &
- mpas_timer_write
+ mpas_timer_write, &
+ mpas_timer_init
contains
@@ -85,6 +92,7 @@
current%min_time = 100000000.0
current%avg_time = 0.0
current%calls = 0
+ current%efficiency = 0.0
else
current => timer_ptr
endif
@@ -112,6 +120,7 @@
current%min_time = 100000000.0
current%avg_time = 0.0
current%calls = 0
+ current%efficiency = 0.0
endif
if((timer_added .or. timer_found) .and. (.not.current%running)) then
@@ -230,6 +239,10 @@
total_found = .false.
+ if(associated(domain_info) .and. synced == 0) then
+ call mpas_timer_sync()
+ endif
+
if(present(timer_ptr) .and. (.not.present(total_ptr))) then
print *,'timer_write :: timer_ptr valid, but total_ptr is not assigned.'
stop
@@ -251,7 +264,7 @@
percent = timer_ptr%total_time/total_ptr%total_time
endif
- write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5, f8.2)') timer_ptr%levels, tname(1:timer_ptr%levels)//timer_ptr%timer_name, timer_ptr%total_time, timer_ptr%calls, timer_ptr%min_time, timer_ptr%max_time, timer_ptr%avg_time, percent
+ write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5, 2f8.2)') timer_ptr%levels, tname(1:timer_ptr%levels)//timer_ptr%timer_name, timer_ptr%total_time, timer_ptr%calls, timer_ptr%min_time, timer_ptr%max_time, timer_ptr%avg_time, percent, timer_ptr%efficiency
return
endif
@@ -271,7 +284,7 @@
stop
end if
- write(*,'(3x, a10, 24x, a15, a10, a13, a15, a15, a15)') 'timer_name', 'total', 'calls', 'min', 'max', 'avg', 'percent'
+ write(*,'(3x, a10, 24x, a15, a10, a13, a15, a15, a12, a12)') 'timer_name', 'total', 'calls', 'min', 'max', 'avg', 'percent', 'efficiency'
write(*,'(i2, 1x, a35, f15.5, i10, 3f15.5)') total%levels, total%timer_name, total%total_time, total%calls, total%min_time, total%max_time, total%avg_time
current => all_timers
@@ -290,6 +303,57 @@
end subroutine mpas_timer_write!}}}
+ subroutine mpas_timer_init(domain)!{{{
+ type (domain_type), intent(in), optional :: domain
+
+ if( present(domain) ) then
+ domain_info => domain % dminfo
+ endif
+
+ synced = 0
+
+ end subroutine mpas_timer_init!}}}
+
+ subroutine mpas_timer_sync()!{{{
+ type (timer_node), pointer :: current
+ real (kind=RKIND) :: all_total_time, all_max_time, all_min_time, all_ave_time
+
+ current => all_timers
+
+ sync_timers: do while(associated(current))
+ all_total_time = 0.0
+ all_ave_time = 0.0
+ all_max_time = 0.0
+ all_min_time = 0.0
+
+ call mpas_dmpar_max_real(domain_info, current % total_time, all_total_time)
+ call mpas_dmpar_sum_real(domain_info, current % total_time, all_ave_time)
+
+ all_ave_time = all_ave_time / domain_info % nprocs
+
+ current % total_time = all_total_time
+
+#ifdef _MPI
+ current % efficiency = all_ave_time / all_total_time
+#else
+ current % efficiency = 1.0
+#endif
+
+ current % avg_time = current % total_time / current % calls
+
+ call mpas_dmpar_max_real(domain_info, current % max_time, all_max_time)
+ current % max_time = all_max_time
+
+ call mpas_dmpar_min_real(domain_info, current % min_time, all_min_time)
+ current % min_time = all_min_time
+
+ current => current % next
+ end do sync_timers
+
+ synced = 1
+
+ end subroutine mpas_timer_sync!}}}
+
end module mpas_timer
! vim: foldmethod=marker et ts=2
Modified: branches/ocean_projects/pio_trunk_merge/src/framework/streams.c
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/framework/streams.c 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/framework/streams.c 2012-03-28 22:32:39 UTC (rev 1732)
@@ -18,6 +18,37 @@
{
char fname[128];
+#ifndef MPAS_DEBUG
+ if(*id == 0){
+ sprintf(fname, "log.%4.4i.err", *id);
+ fd_err = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
+ if (dup2(fd_err, 2) < 0) {
+ printf("Error duplicating STDERR</font>
<font color="blue">");
+ return;
+ }
+
+ sprintf(fname, "log.%4.4i.out", *id);
+ fd_out = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
+ if (dup2(fd_out, 1) < 0) {
+ printf("Error duplicating STDOUT</font>
<font color="blue">");
+ return;
+ }
+ } else {
+ sprintf(fname, "/dev/null", *id);
+ fd_err = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
+ if (dup2(fd_err, 2) < 0) {
+ printf("Error duplicating STDERR</font>
<font color="blue">");
+ return;
+ }
+
+ sprintf(fname, "/dev/null", *id);
+ fd_out = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
+ if (dup2(fd_out, 1) < 0) {
+ printf("Error duplicating STDOUT</font>
<font color="gray">");
+ return;
+ }
+ }
+#else
sprintf(fname, "log.%4.4i.err", *id);
fd_err = open(fname,O_CREAT|O_WRONLY|O_TRUNC,0644);
if (dup2(fd_err, 2) < 0) {
@@ -31,6 +62,7 @@
printf("Error duplicating STDOUT</font>
<font color="gray">");
return;
}
+#endif
}
void close_streams()
Modified: branches/ocean_projects/pio_trunk_merge/src/operators/mpas_spline_interpolation.F
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/operators/mpas_spline_interpolation.F 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/operators/mpas_spline_interpolation.F 2012-03-28 22:32:39 UTC (rev 1732)
@@ -1,5 +1,7 @@
module mpas_spline_interpolation
+ use mpas_kind_types
+
implicit none
private
Modified: branches/ocean_projects/pio_trunk_merge/src/registry/gen_inc.c
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/registry/gen_inc.c 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/registry/gen_inc.c 2012-03-28 22:32:39 UTC (rev 1732)
@@ -125,7 +125,15 @@
nls_ptr = nls;
while (nls_ptr) {
if (!dict_search(dictionary, nls_ptr->record)) {
- fortprintf(fd, " read(funit,%s)</font>
<font color="blue">", nls_ptr->record);
+ fortprintf(fd, " read(funit,%s,iostat=ierr)</font>
<font color="blue">", nls_ptr->record);
+ fortprintf(fd, " if (ierr > 0) then</font>
<font color="blue">");
+ fortprintf(fd, " write(0,*) \'Error while reading namelist record &%s\'</font>
<font color="blue">",nls_ptr->record);
+ fortprintf(fd, " call mpas_dmpar_abort(dminfo)</font>
<font color="blue">");
+ fortprintf(fd, " else if (ierr < 0) then</font>
<font color="blue">");
+ fortprintf(fd, " write(0,*) \'Namelist record &%s not found; using default values for this namelist\'\'s variables\'</font>
<font color="blue">",nls_ptr->record);
+ fortprintf(fd, " rewind(funit)</font>
<font color="blue">");
+ fortprintf(fd, " end if</font>
<font color="gray">");
+
dict_insert(dictionary, nls_ptr->record);
}
nls_ptr = nls_ptr->next;
Modified: branches/ocean_projects/pio_trunk_merge/src/registry/parse.c
===================================================================
--- branches/ocean_projects/pio_trunk_merge/src/registry/parse.c 2012-03-28 22:11:47 UTC (rev 1731)
+++ branches/ocean_projects/pio_trunk_merge/src/registry/parse.c 2012-03-28 22:32:39 UTC (rev 1732)
@@ -19,23 +19,21 @@
struct group_list * groups;
if (argc != 2) {
- fprintf(stderr,"</font>
<font color="black">Usage: %s filename</font>
<font color="black"></font>
<font color="red">", argv[0]);
- return 1;
+ fprintf(stderr,"Reading registry file from standard input</font>
<font color="red">");
+ regfile = stdin;
}
-
- if (regfile = fopen(argv[1], "r")) {
- nls = NULL;
- dims = NULL;
- vars = NULL;
- if (parse_reg(regfile, &nls, &dims, &vars, &groups)) {
- return 1;
- }
- }
- else {
+ else if (!(regfile = fopen(argv[1], "r"))) {
fprintf(stderr,"</font>
<font color="black">Error: Could not open file %s for reading.</font>
<font color="black"></font>
<font color="gray">", argv[1]);
return 1;
}
+ nls = NULL;
+ dims = NULL;
+ vars = NULL;
+ if (parse_reg(regfile, &nls, &dims, &vars, &groups)) {
+ return 1;
+ }
+
sort_vars(vars);
sort_group_vars(groups);
@@ -244,6 +242,7 @@
dimlist_ptr = dimlist_ptr->next;
}
}
+ fprintf(stdout,"</font>
<font color="gray">");
}
nls_ptr = *nls;
@@ -274,18 +273,19 @@
do { c = getc(regfile); } while (((char)c == ' ' || (char)c == '</font>
<font color="red">' || (char)c == '\t') && c != EOF);
- while ((char)c == '#') {
+ while ((char)c == '%') {
do { c = getc(regfile); } while ((char)c != '</font>
<font color="black">' && c != EOF);
do { c = getc(regfile); } while (((char)c == ' ' || (char)c == '</font>
<font color="red">' || (char)c == '\t') && c != EOF);
};
- while((char)c != ' ' && (char)c != '</font>
<font color="blue">' && (char)c != '\t' && c != EOF && (char)c != '#') {
+ while((char)c != ' ' && (char)c != '</font>
<font color="red">' && (char)c != '\t' && c != EOF && (char)c != '%') {
word[i++] = (char)c;
c = (char)getc(regfile);
}
word[i] = '\0';
- if ((char)c == '#') do { c = getc(regfile); } while ((char)c != '</font>
<font color="blue">' && c != EOF);
+ if ((char)c == '%') do { c = getc(regfile); } while ((char)c != '</font>
<font color="blue">' && c != EOF);
+ fprintf(stdout,"%s ",word);
return c;
}
</font>
</pre>