diff --git a/Makefile b/Makefile index 9b84f0c012..4d5f20edfb 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,43 @@ MODEL_FORMULATION = +ifneq "${MPAS_SHELL}" "" + SHELL = ${MPAS_SHELL} +endif dummy: ( $(MAKE) error ) -xlf: +gnu: # BUILDTARGET GNU Fortran, C, and C++ compilers + ( $(MAKE) all \ + "FC_PARALLEL = mpif90" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpicxx" \ + "FC_SERIAL = gfortran" \ + "CC_SERIAL = gcc" \ + "CXX_SERIAL = g++" \ + "FFLAGS_PROMOTION = -fdefault-real-8 -fdefault-double-8" \ + "FFLAGS_OPT = -std=f2008 -O3 -ffree-line-length-none -fconvert=big-endian -ffree-form" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "FFLAGS_DEBUG = -g -ffree-line-length-none -fconvert=big-endian -ffree-form -fcheck=all -fbacktrace -ffpe-trap=invalid,zero,overflow" \ + "CFLAGS_DEBUG = -g" \ + "CXXFLAGS_DEBUG = -g" \ + "LDFLAGS_DEBUG = -g" \ + "FFLAGS_OMP = -fopenmp" \ + "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fPIC" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +xlf: # BUILDTARGET IBM XL compilers ( $(MAKE) all \ "FC_PARALLEL = mpifort" \ "CC_PARALLEL = mpicc" \ @@ -23,13 +56,45 @@ xlf: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "PICFLAG = -qpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) - -ftn: + +xlf-summit-omp-offload: # BUILDTARGET IBM XL compilers w/OpenMP offloading on ORNL Summit + ( $(MAKE) all \ + "FC_PARALLEL = mpif90" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpiCC" \ + "FC_SERIAL = xlf90_r" \ + "CC_SERIAL = xlc_r" \ + "CXX_SERIAL = xlc++_r" \ + "FFLAGS_PROMOTION = -qrealsize=8" \ + "FFLAGS_OPT = -g -qfullpath -qmaxmem=-1 -qphsinfo -qzerosize -qfree=f90 -qxlf2003=polymorphic -qspillsize=2500 -qextname=flush -O2 -qstrict -Q" \ + "CFLAGS_OPT = -g -qfullpath -qmaxmem=-1 -qphsinfo -O3" \ + "CXXFLAGS_OPT = -g -qfullpath -qmaxmem=-1 -qphsinfo -O3" \ + "LDFLAGS_OPT = -Wl,--relax -Wl,--allow-multiple-definition -qsmp -qoffload -lcudart -L$(CUDA_DIR)/lib64" \ + "FFLAGS_GPU = -qsmp -qoffload" \ + "LDFLAGS_GPU = -qsmp -qoffload -lcudart -L$(CUDA_DIR)/lib64" \ + "FFLAGS_DEBUG = -O0 -g -qinitauto=7FF7FFFF -qflttrap=ov:zero:inv:en" \ + "CFLAGS_DEBUG = -O0 -g" \ + "CXXFLAGS_DEBUG = -O0 -g" \ + "LDFLAGS_DEBUG = -O0 -g" \ + "FFLAGS_OMP = -qsmp=omp" \ + "CFLAGS_OMP = -qsmp=omp" \ + "PICFLAG = -qpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENMP_OFFLOAD = $(OPENMP_OFFLOAD)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DFORTRAN_SAME -DCPRIBM -DLINUX" ) + +ftn: # BUILDTARGET Cray compilers ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -44,13 +109,17 @@ ftn: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -titan-cray: +titan-cray: # BUILDTARGET (deprecated) Cray compilers with options for ORNL Titan ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -62,13 +131,44 @@ titan-cray: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -pgi: +nvhpc: # BUILDTARGET NVIDIA HPC SDK + ( $(MAKE) all \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = nvfortran" \ + "CC_SERIAL = nvc" \ + "CXX_SERIAL = nvc++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -gopt -O4 -byteswapio -Mfree" \ + "CFLAGS_OPT = -gopt -O3" \ + "CXXFLAGS_OPT = -gopt -O3" \ + "LDFLAGS_OPT = -gopt -O3" \ + "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ + "CFLAGS_DEBUG = -O0 -g -traceback" \ + "CXXFLAGS_DEBUG = -O0 -g -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "FFLAGS_OMP = -mp" \ + "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC = -Mnofma -acc -gpu=cc70,cc80 -Minfo=accel" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) + +pgi: # BUILDTARGET PGI compiler suite ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -87,13 +187,48 @@ pgi: "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC = -Mnofma -acc -Minfo=accel" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) + +pgi-summit: # BUILDTARGET PGI compiler suite w/OpenACC options for ORNL Summit + ( $(MAKE) all \ + "FC_PARALLEL = mpif90" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpicxx" \ + "FC_SERIAL = pgf90" \ + "CC_SERIAL = pgcc" \ + "CXX_SERIAL = pgc++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -g -O3 -byteswapio -Mfree" \ + "CFLAGS_OPT = -O3 " \ + "CXXFLAGS_OPT = -O3 " \ + "LDFLAGS_OPT = -O3 " \ + "FFLAGS_ACC = -acc -Minfo=accel -ta=tesla:cc70,cc60,deepcopy,nollvm " \ + "CFLAGS_ACC = -acc -Minfo=accel -ta=tesla:cc70,cc60,deepcopy,nollvm " \ + "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ + "CFLAGS_DEBUG = -O0 -g -traceback" \ + "CXXFLAGS_DEBUG = -O0 -g -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "FFLAGS_OMP = -mp" \ + "CFLAGS_OMP = -mp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = -DpgiFortran -D_MPI -DUNDERSCORE" ) -pgi-nersc: +pgi-nersc: # BUILDTARGET (deprecated) PGI compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -108,13 +243,14 @@ pgi-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) -pgi-llnl: +pgi-llnl: # BUILDTARGET (deprecated) PGI compilers on LLNL machines ( $(MAKE) all \ "FC_PARALLEL = mpipgf90" \ "CC_PARALLEL = pgcc" \ @@ -129,13 +265,14 @@ pgi-llnl: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) -ifort: +ifort: # BUILDTARGET Intel Fortran, C, and C++ compiler suite ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -148,19 +285,21 @@ ifort: "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -ifort-scorep: +ifort-scorep: # BUILDTARGET Intel compiler suite with ScoreP profiling library ( $(MAKE) all \ "FC_PARALLEL = scorep --compiler mpif90" \ "CC_PARALLEL = scorep --compiler mpicc" \ @@ -173,19 +312,20 @@ ifort-scorep: "CFLAGS_OPT = -O3 -g" \ "CXXFLAGS_OPT = -O3 -g" \ "LDFLAGS_OPT = -O3 -g" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -ifort-gcc: +ifort-gcc: # BUILDTARGET Intel Fortran compiler and GNU C/C++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -198,19 +338,47 @@ ifort-gcc: "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g" \ "CXXFLAGS_DEBUG = -g" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -gfortran: +intel-mpi: # BUILDTARGET Intel compiler suite with Intel MPI library + ( $(MAKE) all \ + "FC_PARALLEL = mpiifort" \ + "CC_PARALLEL = mpiicc" \ + "CXX_PARALLEL = mpiicpc" \ + "FC_SERIAL = ifort" \ + "CC_SERIAL = icc" \ + "CXX_SERIAL = icpc" \ + "FFLAGS_PROMOTION = -real-size 64" \ + "FFLAGS_OPT = -O3 -convert big_endian -free -align array64byte" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "CFLAGS_DEBUG = -g -traceback" \ + "CXXFLAGS_DEBUG = -g -traceback" \ + "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ + "FFLAGS_OMP = -qopenmp" \ + "CFLAGS_OMP = -qopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +gfortran: # BUILDTARGET GNU Fortran, C, and C++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -229,13 +397,18 @@ gfortran: "LDFLAGS_DEBUG = -g" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fPIC" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -gfortran-clang: +gfortran-clang: # BUILDTARGET GNU Fortran compiler with LLVM clang/clang++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc -cc=clang" \ @@ -254,13 +427,14 @@ gfortran-clang: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -g95: +g95: # BUILDTARGET (deprecated) G95 Fortran compiler with GNU C/C++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -275,13 +449,14 @@ g95: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -pathscale-nersc: +pathscale-nersc: # BUILDTARGET (deprecated) Pathscale compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -296,13 +471,14 @@ pathscale-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -cray-nersc: +cray-nersc: # BUILDTARGET (deprecated) Cray compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -317,13 +493,14 @@ cray-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -gnu-nersc: +gnu-nersc: # BUILDTARGET (deprecated) GNU compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -340,13 +517,14 @@ gnu-nersc: "CFLAGS_DEBUG = -g -m64" \ "CXXFLAGS_DEBUG = -g -m64" \ "LDFLAGS_DEBUG = -g -m64" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "SERIAL = $(SERIAL)" \ "USE_PAPI = $(USE_PAPI)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" ) -intel-nersc: +intel-nersc: # BUILDTARGET (deprecated) Intel compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -361,17 +539,18 @@ intel-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ - "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -free -CU -CB -check all -gen-interfaces -warn interfaces -traceback" \ + "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -free -check all -gen-interfaces -warn interfaces -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -traceback" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -bluegene: +bluegene: # BUILDTARGET (deprecated) IBM XL compilers on BlueGene/Q systems ( $(MAKE) all \ "FC_PARALLEL = mpixlf95_r" \ "CC_PARALLEL = mpixlc_r" \ @@ -390,13 +569,14 @@ bluegene: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -llvm: +llvm: # BUILDTARGET LLVM flang, clang, and clang++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpifort" \ "CC_PARALLEL = mpicc" \ @@ -415,6 +595,59 @@ llvm: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -fopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +nag: # BUILDTARGET NAG Fortran compiler and GNU C/C++ compilers + ( $(MAKE) all \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = nagfor" \ + "CC_SERIAL = gcc" \ + "CXX_SERIAL = g++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -free -mismatch -O3 -convert=big_ieee" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "FFLAGS_DEBUG = -free -mismatch -O0 -g -C -convert=big_ieee" \ + "CFLAGS_DEBUG = -O0 -g -Wall -pedantic" \ + "CXXFLAGS_DEBUG = -O0 -g -Wall -pedantic" \ + "LDFLAGS_DEBUG = -O0 -g -C" \ + "FFLAGS_OMP = -qsmp=omp" \ + "CFLAGS_OMP = -qsmp=omp" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -DNAG_COMPILER" ) + +cray: # BUILDTARGET Cray Programming Environment + ( $(MAKE) all \ + "FC_PARALLEL = ftn" \ + "CC_PARALLEL = cc" \ + "CXX_PARALLEL = CC" \ + "FC_SERIAL = ftn" \ + "CC_SERIAL = cc" \ + "CXX_SERIAL = CC" \ + "FFLAGS_PROMOTION = -sreal64" \ + "FFLAGS_OPT = -Ofast -ffree" \ + "CFLAGS_OPT = -Ofast" \ + "CXXFLAGS_OPT = -Ofast" \ + "LDFLAGS_OPT = -Ofast -hbyteswapio" \ + "FFLAGS_DEBUG = -eD -O0 -ffree" \ + "CFLAGS_DEBUG = -O0 -g -Weverything" \ + "CXXFLAGS_DEBUG = -O0 -g -Weverything" \ + "LDFLAGS_DEBUG = -eD -O0 -hbyteswapio" \ + "FFLAGS_OMP = -homp" \ + "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ @@ -425,13 +658,7 @@ CPPINCLUDES = FCINCLUDES = LIBS = -# -# If user has indicated a PIO2 library, define USE_PIO2 pre-processor macro -# -ifeq "$(USE_PIO2)" "true" - override CPPFLAGS += -DUSE_PIO2 -endif - +ifneq "$(PIO)" "" # # Regardless of PIO library version, look for a lib subdirectory of PIO path # NB: PIO_LIB is used later, so we don't just set LIBS directly @@ -477,18 +704,29 @@ ifneq ($(wildcard $(PIO_LIB)/libgptl\.*), ) LIBS += -lgptl endif +else # Not using PIO, using SMIOL + LIBS += -L$(PWD)/src/external/SMIOL -lsmiolf -lsmiol + FCINCLUDES += -I$(PWD)/src/external/SMIOL +endif + ifneq "$(NETCDF)" "" +ifneq ($(wildcard $(NETCDF)/lib), ) + NETCDFLIBLOC = lib +endif +ifneq ($(wildcard $(NETCDF)/lib64), ) + NETCDFLIBLOC = lib64 +endif CPPINCLUDES += -I$(NETCDF)/include FCINCLUDES += -I$(NETCDF)/include - LIBS += -L$(NETCDF)/lib + LIBS += -L$(NETCDF)/$(NETCDFLIBLOC) NCLIB = -lnetcdf NCLIBF = -lnetcdff - ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4 + ifneq ($(wildcard $(NETCDF)/$(NETCDFLIBLOC)/libnetcdff.*), ) # CHECK FOR NETCDF4 LIBS += $(NCLIBF) endif # CHECK FOR NETCDF4 ifneq "$(NETCDFF)" "" FCINCLUDES += -I$(NETCDFF)/include - LIBS += -L$(NETCDFF)/lib + LIBS += -L$(NETCDFF)/$(NETCDFLIBLOC) LIBS += $(NCLIBF) endif LIBS += $(NCLIB) @@ -496,9 +734,21 @@ endif ifneq "$(PNETCDF)" "" +ifneq ($(wildcard $(PNETCDF)/lib), ) + PNETCDFLIBLOC = lib +endif +ifneq ($(wildcard $(PNETCDF)/lib64), ) + PNETCDFLIBLOC = lib64 +endif CPPINCLUDES += -I$(PNETCDF)/include FCINCLUDES += -I$(PNETCDF)/include - LIBS += -L$(PNETCDF)/lib -lpnetcdf + LIBS += -L$(PNETCDF)/$(PNETCDFLIBLOC) -lpnetcdf +endif + +ifneq "$(LAPACK)" "" + LIBS += -L$(LAPACK) + LIBS += -llapack + LIBS += -lblas endif RM = rm -f @@ -565,6 +815,22 @@ ifeq "$(OPENMP)" "true" LDFLAGS += $(FFLAGS_OMP) endif #OPENMP IF +ifeq "$(OPENACC)" "true" + FFLAGS += $(FFLAGS_ACC) + CFLAGS += $(CFLAGS_ACC) + CXXFLAGS += $(CFLAGS_ACC) + override CPPFLAGS += "-DMPAS_OPENACC" + LDFLAGS += $(FFLAGS_ACC) +endif #OPENACC IF + +ifeq "$(OPENMP_OFFLOAD)" "true" + FFLAGS += $(FFLAGS_GPU) + CFLAGS += $(FFLAGS_GPU) + CXXFLAGS += $(FFLAGS_GPU) + override CPPFLAGS += "-DMPAS_OPENMP_OFFLOAD" + LDFLAGS += $(LDFLAGS_GPU) +endif #OPENMP_OFFLOAD IF + ifeq "$(PRECISION)" "single" CFLAGS += "-DSINGLE_PRECISION" CXXFLAGS += "-DSINGLE_PRECISION" @@ -584,11 +850,22 @@ else # USE_PAPI IF PAPI_MESSAGE="Papi libraries are off." endif # USE_PAPI IF -ifeq "$(USE_PIO2)" "true" - PIO_MESSAGE="Using the PIO 2 library." -else # USE_PIO2 IF - PIO_MESSAGE="Using the PIO 1.x library." -endif # USE_PIO2 IF +# Only if this Makefile was invoked from a compiler target should we check that PICFLAG is set +ifneq "$(FC_SERIAL)" "" +ifeq "$(SHAREDLIB)" "true" +ifneq "$(PICFLAG)" "" + FFLAGS += $(PICFLAG) + CFLAGS += $(PICFLAG) + CXXFLAGS += $(PICFLAG) + LDFLAGS += $(PICFLAG) + SHAREDLIB_MESSAGE="Position-independent code was generated." +else +$(error Position-independent code was requested but PIC flags are not available. Please add PIC flags for the '$(BUILD_TARGET)' target) +endif +else + SHAREDLIB_MESSAGE="Position-dependent code was generated." +endif +endif ifdef TIMER_LIB ifeq "$(TIMER_LIB)" "tau" @@ -638,6 +915,18 @@ else OPENMP_MESSAGE="MPAS was built without OpenMP support." endif +ifeq "$(OPENMP_OFFLOAD)" "true" + OPENMP_OFFLOAD_MESSAGE="MPAS was built with OpenMP-offload GPU support enabled." +else + OPENMP_OFFLOAD_MESSAGE="MPAS was built without OpenMP-offload GPU support." +endif + +ifeq "$(OPENACC)" "true" + OPENACC_MESSAGE="MPAS was built with OpenACC accelerator support enabled." +else + OPENACC_MESSAGE="MPAS was built without OpenACC accelerator support." +endif + ifneq ($(wildcard .mpas_core_*), ) # CHECK FOR BUILT CORE ifneq ($(wildcard .mpas_core_$(CORE)), ) # CHECK FOR SAME CORE AS ATTEMPTED BUILD. @@ -702,6 +991,8 @@ ifdef MPAS_EXTERNAL_CPPFLAGS endif #################################################### +override CPPFLAGS += -DMPAS_BUILD_TARGET=$(BUILD_TARGET) + ifeq ($(wildcard src/core_$(CORE)), ) # CHECK FOR EXISTENCE OF CORE DIRECTORY all: core_error @@ -739,47 +1030,212 @@ ifeq "$(OPENMP)" "true" endif -pio_test: +openacc_test: +ifeq "$(OPENACC)" "true" @# - @# Create two test programs: one that should work with PIO1 and a second that should work with PIO2 + @# First ensure that both FFLAGS_ACC and CFLAGS_ACC are not blank + @# If these are not set for a target, then OpenACC most likely cannot compile @# - @echo "program pio1; use pio; use pionfatt_mod; integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET; integer, parameter :: MPAS_INT_FILLVAL = NF_FILL_INT; end program" > pio1.f90 - @echo "program pio2; use pio; integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET_KIND; integer, parameter :: MPAS_INT_FILLVAL = PIO_FILL_INT; end program" > pio2.f90 + @echo "Checking if FFLAGS_ACC and CFLAGS_ACC are defined for [$(BUILD_TARGET)]..." + @( if ([ -z "$(FFLAGS_ACC)" ] && [ -z "$(CFLAGS_ACC)" ]); then \ + echo "*********************************************************"; \ + echo "ERROR: OPENACC=true was specified, but [$(BUILD_TARGET)] build target does not seem to support OpenACC:"; \ + echo " FFLAGS_ACC and CFLAGS_ACC are both undefined for [$(BUILD_TARGET)] in the top-level Makefile."; \ + echo "Please set these variables to appropriate OpenACC compilation flags in the [$(BUILD_TARGET)] target to enable OpenACC support."; \ + echo "*********************************************************"; exit 1; \ + else \ + echo "=> FFLAGS_ACC or CFLAGS_ACC are defined"; \ + fi ) @# - @# See whether either of the test programs can be compiled + @# Create test C and Fortran programs that look for OpenACC header file and parallelize a loop @# - @echo "Checking for a usable PIO library..." - @($(FC) pio1.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o pio1.out &> /dev/null && echo "=> PIO 1 detected") || \ - ($(FC) pio2.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o pio2.out &> /dev/null && echo "=> PIO 2 detected") || \ - (echo "************ ERROR ************"; \ - echo "Failed to compile a PIO test program"; \ - echo "Please ensure the PIO environment variable is set to the PIO installation directory"; \ - echo "************ ERROR ************"; \ - rm -rf pio[12].f90 pio[12].out; exit 1) - - @rm -rf pio[12].out + @printf "#include \n\ + &int main(){\n\ + & int n_devs=acc_get_num_devices( acc_device_default );\n\ + & int i,n=0;\n\ + & #pragma acc kernels\n\ + & for (i=0; i<10; i++)\n\ + & n=n+i;\n\ + & return 0;\n\ + &}\n" | sed 's/^ *&//' > openacc.c + @printf "program openacc\n\ + & use openacc\n\ + & integer :: i,n=0,n_devs=0\n\ + & n_devs=acc_get_num_devices( acc_device_default )\n\ + & !\$$acc kernels\n\ + & do i=0,10\n\ + & n=n+i\n\ + & end do\n\ + & !\$$acc end kernels\n\ + &end program\n" | sed 's/^ *&//' > openacc.f90 @# - @# Check that what the user has specified agrees with the PIO library version that was detected + @# See whether the test programs can be compiled + @# + @echo "Checking [$(BUILD_TARGET)] compilers for OpenACC support..." + @( $(SCC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out > openacc_c.log 2>&1; \ + if [ $$? -eq 0 ]; then \ + echo "=> $(SCC) can compile test OpenACC program"; \ + else \ + echo "*********************************************************"; \ + echo "ERROR: Test OpenACC C program could not be compiled by $(SCC)."; \ + echo "Following compilation command failed with errors:" ; \ + echo "$(SCC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out"; \ + echo ""; \ + echo "Test program openacc.c and output openacc_c.log have been left"; \ + echo "in the top-level MPAS directory for further debugging"; \ + echo "*********************************************************"; \ + rm -f openacc.f90 openacc_[cf].out openacc_f.log; exit 1; \ + fi ) + @( $(CC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out > openacc_c.log 2>&1; \ + if [ $$? -eq 0 ] ; then \ + echo "=> $(CC) can compile test OpenACC program"; \ + else \ + echo "*********************************************************"; \ + echo "ERROR: Test OpenACC C program could not be compiled by $(CC)."; \ + echo "Following compilation command failed with errors:" ; \ + echo "$(CC) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out"; \ + echo ""; \ + echo "Test program openacc.c and output openacc_c.log have been left"; \ + echo "in the top-level MPAS directory for further debugging"; \ + echo "*********************************************************"; \ + rm -f openacc.f90 openacc_[cf].out openacc_f.log; exit 1; \ + fi ) + @( $(CXX) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out > openacc_c.log 2>&1; \ + if [ $$? -eq 0 ] ; then \ + echo "=> $(CXX) can compile test OpenACC program"; \ + else \ + echo "*********************************************************"; \ + echo "ERROR: Test OpenACC C program could not be compiled by $(CXX)."; \ + echo "Following compilation command failed with errors:" ; \ + echo "$(CXX) openacc.c $(CPPINCLUDES) $(CFLAGS) $(LDFLAGS) $(LIBS) -o openacc_c.out"; \ + echo ""; \ + echo "Test program openacc.c and output openacc_c.log have been left"; \ + echo "in the top-level MPAS directory for further debugging"; \ + echo "*********************************************************"; \ + rm -f openacc.f90 openacc_[cf].out openacc_f.log; exit 1; \ + fi ) + @( $(SFC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out > openacc_f.log 2>&1; \ + if [ $$? -eq 0 ] ; then \ + echo "=> $(SFC) can compile test OpenACC program"; \ + else \ + echo "*********************************************************"; \ + echo "ERROR: Test OpenACC Fortran program could not be compiled by $(SFC)."; \ + echo "Following compilation command failed with errors:" ; \ + echo "$(SFC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out"; \ + echo ""; \ + echo "Test program openacc.f90 and output openacc_f.log have been left"; \ + echo "in the top-level MPAS directory for further debugging"; \ + echo "*********************************************************"; \ + rm -f openacc.c openacc_[cf].out openacc_c.log; exit 1; \ + fi ) + @( $(FC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out > openacc_f.log 2>&1; \ + if [ $$? -eq 0 ] ; then \ + echo "=> $(FC) can compile test OpenACC program"; \ + else \ + echo "*********************************************************"; \ + echo "ERROR: Test OpenACC Fortran program could not be compiled by $(FC)."; \ + echo "Following compilation command failed with errors:" ; \ + echo "$(FC) openacc.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o openacc_f.out"; \ + echo ""; \ + echo "Test program openacc.f90 and output openacc_f.log have been left"; \ + echo "in the top-level MPAS directory for further debugging"; \ + echo "*********************************************************"; \ + rm -f openacc.c openacc_[cf].out openacc_c.log; exit 1; \ + fi ) + + @rm -f openacc.c openacc.f90 openacc_[cf].out openacc_[cf].log +endif # OPENACC eq true + + +pio_test: openmp_test openacc_test + @# + @# PIO_VERS will be set to: + @# 0 if no working PIO library was detected (and .piotest.log will contain error messages) + @# 1 if a PIO 1.x library was detected + @# 2 if a PIO 2.x library was detected + @# + $(info Checking for a working PIO library...) +ifneq "$(USE_PIO2)" "" + $(info *** Note: The USE_PIO2 option has been deprecated and will be ignored.) +endif + $(eval PIO_VERS := $(shell $\ + rm -f .piotest.log; $\ + printf "program pio1\n$\ + & use pio\n$\ + & use pionfatt_mod\n$\ + & integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET\n$\ + & integer, parameter :: MPAS_INT_FILLVAL = NF_FILL_INT\n$\ + & type (Var_desc_t) :: field_desc\n$\ + & integer (kind=MPAS_IO_OFFSET_KIND) :: frame_number\n$\ + & call PIO_setframe(field_desc, frame_number)\n$\ + end program\n" | sed 's/&/ /' > pio1.f90; $\ + $\ + printf "program pio2\n$\ + & use pio\n$\ + & integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET_KIND\n$\ + & integer, parameter :: MPAS_INT_FILLVAL = PIO_FILL_INT\n$\ + & type (file_desc_t) :: pio_file\n$\ + & type (Var_desc_t) :: field_desc\n$\ + & integer (kind=MPAS_IO_OFFSET_KIND) :: frame_number\n$\ + & call PIO_setframe(pio_file, field_desc, frame_number)\n$\ + end program\n" | sed 's/&/ /' > pio2.f90; $\ + $\ + $(FC) pio1.f90 -o pio1.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) > /dev/null 2>&1; $\ + pio1_status=$$?; $\ + $\ + $(FC) pio2.f90 -o pio2.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) > /dev/null 2>&1; $\ + pio2_status=$$?; $\ + $\ + if [ $$pio1_status -ne 0 -a $$pio2_status -ne 0 ]; then $\ + printf "0"; $\ + printf "*********************************************************\n" > .piotest.log; $\ + printf "ERROR: Could not detect a working PIO library!\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "Both of the following commands to compile a test program\n" >> .piotest.log; $\ + printf "failed with errors:\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "$(FC) pio1.f90 -o pio1.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS)\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "$(FC) pio2.f90 -o pio2.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS)\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "The pio1.f90 and pio2.f90 test programs have been left in\n" >> .piotest.log; $\ + printf "the top-level MPAS directory for further debugging.\n" >> .piotest.log; $\ + printf "*********************************************************\n" >> .piotest.log; $\ + elif [ $$pio1_status -eq 0 ]; then $\ + printf "1"; $\ + rm -f pio[12].f90 pio[12].x; $\ + elif [ $$pio2_status -eq 0 ]; then $\ + printf "2"; $\ + rm -f pio[12].f90 pio[12].x; $\ + fi $\ + )) + $(if $(findstring 1,$(PIO_VERS)), $(eval IO_MESSAGE = "Using the PIO 1.x library."), ) + $(if $(findstring 1,$(PIO_VERS)), $(info PIO 1.x detected.)) + $(if $(findstring 2,$(PIO_VERS)), $(eval override CPPFLAGS += -DUSE_PIO2), ) + $(if $(findstring 2,$(PIO_VERS)), $(eval IO_MESSAGE = "Using the PIO 2.x library."), ) + $(if $(findstring 2,$(PIO_VERS)), $(info PIO 2.x detected.)) + @# + @# A .piotest.log file exists iff no working PIO library was detected @# -ifeq "$(USE_PIO2)" "true" - @($(FC) pio2.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o pio2.out &> /dev/null) || \ - (echo "************ ERROR ************"; \ - echo "PIO 1 was detected, but USE_PIO2=true was specified in the make command"; \ - echo "************ ERROR ************"; \ - rm -rf pio[12].f90 pio[12].out; exit 1) + @if [ -f .piotest.log ]; then \ + cat .piotest.log; \ + rm -f .piotest.log; \ + exit 1; \ + fi + +ifneq "$(PIO)" "" +MAIN_DEPS = openmp_test openacc_test pio_test +override CPPFLAGS += "-DMPAS_PIO_SUPPORT" else - @($(FC) pio1.f90 $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) -o pio1.out &> /dev/null) || \ - (echo "************ ERROR ************"; \ - echo "PIO 2 was detected. Please specify USE_PIO2=true in the make command"; \ - echo "************ ERROR ************"; \ - rm -rf pio[12].f90 pio[12].out; exit 1) +MAIN_DEPS = openmp_test openacc_test +IO_MESSAGE = "Using the SMIOL library." +override CPPFLAGS += "-DMPAS_SMIOL_SUPPORT" endif - @rm -rf pio[12].f90 pio[12].out -mpas_main: openmp_test pio_test +mpas_main: $(MAIN_DEPS) ifeq "$(AUTOCLEAN)" "true" $(RM) .mpas_core_* endif @@ -815,12 +1271,15 @@ endif @echo $(PAPI_MESSAGE) @echo $(TAU_MESSAGE) @echo $(OPENMP_MESSAGE) + @echo $(OPENMP_OFFLOAD_MESSAGE) + @echo $(OPENACC_MESSAGE) + @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) endif @echo $(GEN_F90_MESSAGE) @echo $(TIMER_MESSAGE) - @echo $(PIO_MESSAGE) + @echo $(IO_MESSAGE) @echo "*******************************************************************************" clean: cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" @@ -876,11 +1335,8 @@ errmsg: @echo "" @echo "Usage: $(MAKE) target CORE=[core] [options]" @echo "" - @echo "Example targets:" - @echo " ifort" - @echo " gfortran" - @echo " xlf" - @echo " pgi" + @echo "Available Targets:" + @grep BUILDTARGET Makefile | grep -v grep | sed -e 's/#[[:blank:]]*BUILDTARGET[[:blank:]]*/#/' | sed -e 's/:[[:blank:]]*#/:#/' | sed -e 's/://' | awk 'BEGIN {FS="#"}{printf (" %-15s - %s\n", $$1, $$2)}' @echo "" @echo "Availabe Cores:" @cd src; ls -d core_* | grep ".*" | sed "s/core_/ /g" @@ -896,8 +1352,9 @@ errmsg: @echo " TIMER_LIB=gptl - Uses gptl for the timer interface instead of the native interface" @echo " TIMER_LIB=tau - Uses TAU for the timer interface instead of the native interface" @echo " OPENMP=true - builds and links with OpenMP flags. Default is to not use OpenMP." - @echo " USE_PIO2=true - links with the PIO 2 library. Default is to use the PIO 1.x library." + @echo " OPENACC=true - builds and links with OpenACC flags. Default is to not use OpenACC." @echo " PRECISION=single - builds with default single-precision real kind. Default is to use double-precision." + @echo " SHAREDLIB=true - generate position-independent code suitable for use in a shared library. Default is false." @echo "" @echo "Ensure that NETCDF, PNETCDF, PIO, and PAPI (if USE_PAPI=true) are environment variables" @echo "that point to the absolute paths for the libraries." diff --git a/README.md b/README.md index 819b62c321..4b67663698 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v7.3 +MPAS-v8.0.0 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for @@ -43,14 +43,17 @@ only described below the src directory. MPAS-Model ├── src - │   ├── registry -- Code for building Registry.xml parser (Shared) │   ├── driver -- Main driver for MPAS in stand-alone mode (Shared) │   ├── external -- External software for MPAS (Shared) │   ├── framework -- MPAS Framework (Includes DDT Descriptions, and shared routines. Shared) │   ├── operators -- MPAS Opeartors (Includes Operators for MPAS meshes. Shared) - │   ├── inc -- Empty directory for include files that Registry generates (Shared) + │   ├── tools -- Empty directory for include files that Registry generates (Shared) + │   │  ├── registry -- Code for building Registry.xml parser (Shared) + │  │  └── input_gen -- Code for generating streams and namelist files (Shared) │   └── core_* -- Individual model cores. - └────── testing_and_setup -- tools for setting up configurations and tests cases (Shared) + │   └── inc -- Empty directory for include files that Registry generates + ├── testing_and_setup -- Tools for setting up configurations and test cases (Shared) + └── default_inputs -- Copies of default stream and namelists files (Shared) Model cores are typically developed independently. For information about building and running a particular core, please refer to that core's user's diff --git a/azure-pipelines.yml b/azure-pipelines.yml new file mode 100644 index 0000000000..c586773f9e --- /dev/null +++ b/azure-pipelines.yml @@ -0,0 +1,141 @@ +trigger: + branches: + include: + - master + - develop + - ocean/develop + - lanice/develop + - ocean/coastal + tags: + include: + - '*' +pr: + branches: + include: + - master + - develop + - ocean/develop + - lanice/develop + - ocean/coastal + +jobs: +- job: + displayName: docs + pool: + vmImage: 'ubuntu-16.04' + strategy: + matrix: + Python38: + python.version: '3.8' + + steps: + - bash: echo "##vso[task.prependpath]$CONDA/bin" + displayName: Add conda to PATH + + - bash: | + set -e + eval "$(conda shell.bash hook)" + conda config --add channels conda-forge + conda config --set channel_priority strict + displayName: Configure conda + + - bash: | + set -e + eval "$(conda shell.bash hook)" + conda create -y -n docs python=$PYTHON_VERSION sphinx mock sphinx_rtd_theme m2r + displayName: Create docs environment + + - bash: | + set -e + eval "$(conda shell.bash hook)" + conda activate docs + + echo "source branch: $(Build.SourceBranch)" + echo "repository: $(Build.Repository.Name)" + + tag=$(git describe --tags $(git rev-list --tags --max-count=1)) + echo "tag: $tag" + + REPO_PATH=$PWD + + if [[ "$(Build.SourceBranch)" == refs/tags/* ]]; then + echo "this is a tag build" + export DOCS_VERSION="$tag" + deploy=True + run=True + elif [[ "$(Build.SourceBranch)" == refs/heads/* ]]; then + branch="$(Build.SourceBranchName)" + echo "this is a merge build of $branch" + deploy=True + elif [[ "$(Build.SourceBranch)" == refs/pull/*/merge ]]; then + branch="$(System.PullRequest.TargetBranch)" + echo "this is a pull request into $branch" + deploy=False + fi + + if [ -n ${branch} ]; then + echo "This build is for branch $branch" + if [[ ${branch} == "master" ]]; then + export DOCS_VERSION="stable" + run=True + elif [[ ${branch} == "develop" ]]; then + export DOCS_VERSION="latest" + run=True + elif [[ ${branch} == "ocean/develop" ]]; then + export DOCS_VERSION="latest ocean" + run=True + elif [[ ${branch} == "ocean/coastal" ]]; then + export DOCS_VERSION="latest coastal" + run=True + elif [[ ${branch} == "landice/develop" ]]; then + export DOCS_VERSION="latest landice" + run=True + else + echo "We don't build docs for $branch" + deploy=False + run=False + fi + fi + + if [[ "${run}" == "False" ]]; then + echo "Not building docs for branch ${branch}" + exit 0 + fi + + echo "Docs version: $DOCS_VERSION" + echo "Deploy to gh-pages? $deploy" + cd docs || exit 1 + make html + + cd "$REPO_PATH" || exit 1 + + if [[ "$deploy" == "False" ]]; then + exit 0 + fi + + PUBLICATION_BRANCH=gh-pages + DOCS_PATH="${DOCS_VERSION// /_}" + # Checkout the branch + pushd $HOME || exit 1 + git clone --branch=$PUBLICATION_BRANCH https://$(GitHubToken)@github.com/$(Build.Repository.Name) publish + cd publish || exit 1 + + # Update pages + if [[ -d "$DOCS_PATH" ]]; then + git rm -rf "$DOCS_PATH" > /dev/null + fi + mkdir "$DOCS_PATH" + cp -r "$REPO_PATH"/docs/_build/html/* "$DOCS_PATH" + # Commit and push latest version + git add . + if git diff-index --quiet HEAD; then + echo "No changes in the docs." + else + git config --local user.name "Azure Pipelines" + git config --local user.email "azuredevops@microsoft.com" + git commit -m "[skip ci] Update $DOCS_VERSION" + git push -fq origin $PUBLICATION_BRANCH + fi + popd || exit 1 + displayName: build and deploy docs + diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000000..19e1d4f711 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,20 @@ +# Minimal makefile for Sphinx documentation +# + +# You can set these variables from the command line. +SPHINXOPTS = +SPHINXBUILD = sphinx-build +SPHINXPROJ = mpas_model +SOURCEDIR = . +BUILDDIR = _build + +# Put it first so that "make" without argument is like "make help". +help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) + +.PHONY: help Makefile + +# Catch-all target: route all unknown targets to Sphinx using the new +# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). +%: Makefile + @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) diff --git a/docs/conf.py b/docs/conf.py new file mode 100644 index 0000000000..5d13fca7dd --- /dev/null +++ b/docs/conf.py @@ -0,0 +1,182 @@ +# -*- coding: utf-8 -*- +# +# MPAS-Model documentation build configuration file, created by +# sphinx-quickstart on Sat Mar 25 14:39:11 2017. +# +# This file is execfile()d with the current directory set to its +# containing dir. +# +# Note that not all possible configuration values are present in this +# autogenerated file. +# +# All configuration values have a default; values that are commented out +# serve to show the default. + +import os + +# -- General configuration ------------------------------------------------ + +# If your documentation needs a minimal Sphinx version, state it here. +# +# needs_sphinx = '1.0' + +# Add any Sphinx extension module names here, as strings. They can be +# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom +# ones. +extensions = ['sphinx.ext.autodoc', + 'sphinx.ext.autosummary', + 'sphinx.ext.intersphinx', + 'sphinx.ext.mathjax', + 'sphinx.ext.viewcode', + 'sphinx.ext.napoleon'] + +autosummary_generate = True + +# Otherwise, the Return parameter list looks different from the Parameters list +napoleon_use_rtype = False +# Otherwise, the Attributes parameter list looks different from the Parameters +# list +napoleon_use_ivar = True + +# Add any paths that contain templates here, relative to this directory. +templates_path = ['_templates'] + +# The suffix(es) of source filenames. +# You can specify multiple suffix as a list of string: +# +source_suffix = ['.rst'] +# source_suffix = '.rst' + +# The master toctree document. +master_doc = 'index' + +# General information about the project. +project = u'MPAS-Model' +copyright = u'Copyright (c) 2013-2020, Los Alamos National Security, LLC (LANS) (Ocean: LA-CC-13-047;' \ + u'Land Ice: LA-CC-13-117) and the University Corporation for Atmospheric Research (UCAR).' +author = u'Xylar Asay-Davis, Doug Jacobsen, Michael Duda, Mark Petersen, ' \ + u'Matt Hoffman, Adridan Turner, Philip Wolfram' + +# The version info for the project you're documenting, acts as replacement for +# |version| and |release|, also used in various other places throughout the +# built documents. +if 'DOCS_VERSION' in os.environ: + version = os.environ.get('DOCS_VERSION') + release = version +else: + # The short X.Y.Z version. + version = '7.0' + # The full version, including alpha/beta/rc tags. + release = '7.0' + +# The language for content autogenerated by Sphinx. Refer to documentation +# for a list of supported languages. +# +# This is also used if you do content translation via gettext catalogs. +# Usually you set "language" from the command line for these cases. +language = None + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +# This patterns also effect to html_static_path and html_extra_path +exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store', + 'design_docs/template.md'] + +# The name of the Pygments (syntax highlighting) style to use. +pygments_style = 'sphinx' + +# If true, `todo` and `todoList` produce output, else they produce nothing. +todo_include_todos = False + + +# -- Options for HTML output ---------------------------------------------- + +# The theme to use for HTML and HTML Help pages. See the documentation for +# a list of builtin themes. +# + +# on_rtd is whether we are on readthedocs.org, this line of code grabbed from +# docs.readthedocs.org +on_rtd = os.environ.get('READTHEDOCS', None) == 'True' + +if not on_rtd: # only import and set the theme if we're building docs locally + import sphinx_rtd_theme + html_theme = 'sphinx_rtd_theme' + html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] + +# Theme options are theme-specific and customize the look and feel of a theme +# further. For a list of options available for each theme, see the +# documentation. +# +# html_theme_options = {} + +# Add any paths that contain custom static files (such as style sheets) here, +# relative to this directory. They are copied after the builtin static files, +# so a file named "default.css" will overwrite the builtin "default.css". +html_static_path = ['_static'] + + +# -- Options for HTMLHelp output ------------------------------------------ + +# Output file base name for HTML help builder. +htmlhelp_basename = 'mpas_model_doc' + + +# -- Options for LaTeX output --------------------------------------------- + +latex_elements = { + # The paper size ('letterpaper' or 'a4paper'). + # + # 'papersize': 'letterpaper', + + # The font size ('10pt', '11pt' or '12pt'). + # + # 'pointsize': '10pt', + + # Additional stuff for the LaTeX preamble. + # + # 'preamble': '', + + # Latex figure (float) alignment + # + # 'figure_align': 'htbp', +} + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, +# author, documentclass [howto, manual, or own class]). +latex_documents = [ + (master_doc, 'mpas_model.tex', u'MPAS-Model Documentation', + author, 'manual'), +] + + +# -- Options for manual page output --------------------------------------- + +# One entry per manual page. List of tuples +# (source start file, name, description, authors, manual section). +man_pages = [ + (master_doc, 'mpas_model', u'MPAS-Model Documentation', + [author], 1) +] + + +# -- Options for Texinfo output ------------------------------------------- + +# Grouping the document tree into Texinfo files. List of tuples +# (source start file, target name, title, author, +# dir menu entry, description, category) +texinfo_documents = [ + (master_doc, 'mpas_model', u'MPAS-Model Documentation', + author, 'MPAS-Model', 'One line description of project.', + 'Miscellaneous'), +] + +# Example configuration for intersphinx: refer to the Python standard library. +intersphinx_mapping = { + 'python': ('https://docs.python.org/', None), + 'numpy': ('http://docs.scipy.org/doc/numpy/', None), + 'xarray': ('http://xarray.pydata.org/en/stable/', None)} + + +github_doc_root = 'https://github.com/rtfd/recommonmark/tree/master/doc/' diff --git a/docs/index.rst b/docs/index.rst new file mode 100644 index 0000000000..c7fd593a96 --- /dev/null +++ b/docs/index.rst @@ -0,0 +1,23 @@ +MPAS-Model +========== + +The Model for Prediction Across Scales (MPAS) is a collaborative project for +developing atmosphere, ocean, and other earth-system simulation components for +use in climate, regional climate, and weather studies. The primary development +partners are the climate modeling group at Los Alamos National Laboratory +(COSIM) and the National Center for Atmospheric Research. Both primary +partners are responsible for the MPAS framework, operators, and tools common to +the applications; LANL has primary responsibility for the ocean, sea-ice and +land-ice models, and NCAR has primary responsibility for the atmospheric model. + +The MPAS framework facilitates the rapid development and prototyping of models +by providing infrastructure typically required by model developers, including +high-level data types, communication routines, and I/O routines. By using MPAS, +developers can leverage pre-existing code and focus more on development of + +.. toctree:: + :titlesonly: + + ocean/index + + diff --git a/docs/ocean/design_docs/index.rst b/docs/ocean/design_docs/index.rst new file mode 100644 index 0000000000..3f845b901f --- /dev/null +++ b/docs/ocean/design_docs/index.rst @@ -0,0 +1,9 @@ +Design Docs +=========== + +Design document describing new capabilities added to MPAS-Ocean. + +.. toctree:: + :titlesonly: + + time-varying-wind diff --git a/docs/ocean/index.rst b/docs/ocean/index.rst new file mode 100644 index 0000000000..d5f9bf70ea --- /dev/null +++ b/docs/ocean/index.rst @@ -0,0 +1,7 @@ +MPAS-Ocean +========== + +.. toctree:: + :titlesonly: + + design_docs/index diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt new file mode 100644 index 0000000000..41375a53d2 --- /dev/null +++ b/src/CMakeLists.txt @@ -0,0 +1,97 @@ +# +# This is the interface between E3SM's new CMake-based build system and MPAS. +# +# The following CMake variables are expected to be defined: +# * CORES : A list of CORES to build, comma-separated (e.g. "ocean,seaice,landice") +# * Whatever CIME settings are setting to correctly resolve the ${CASEROOT}/Macros.cmake file +# - COMPILER, DEBUG, MPILIB, MACH, OS +# + +# Source CIME-generated Macros +include(${CASEROOT}/Macros.cmake) +# Load machine/compiler specific settings +set(COMPILER_SPECIFIC_DEPENDS ${CASEROOT}/Depends.${COMPILER}.cmake) +set(MACHINE_SPECIFIC_DEPENDS ${CASEROOT}/Depends.${MACH}.cmake) +set(PLATFORM_SPECIFIC_DEPENDS ${CASEROOT}/Depends.${MACH}.${COMPILER}.cmake) +set(TRY_TO_LOAD ${COMPILER_SPECIFIC_DEPENDS} ${MACHINE_SPECIFIC_DEPENDS} ${PLATFORM_SPECIFIC_DEPENDS}) +foreach(ITEM IN LISTS TRY_TO_LOAD) + if (EXISTS ${ITEM}) + include(${ITEM}) + endif() +endforeach() + +# +# General setup +# + +if (USE_ESMF_LIB) + set(ESMFDIR "esmf") +else() + set(ESMFDIR "noesmf") +endif() + +set(CMAKE_C_COMPILER ${MPICC}) +set(CMAKE_CXX_COMPILER ${MPICXX}) +set(CMAKE_Fortran_COMPILER ${MPIFC}) +set(CMAKE_EXE_LINKER_FLAGS "${LDFLAGS}") +set(CMAKE_VERBOSE_MAKEFILE TRUE) + +# Set up CPPDEFS +set(FILE_OFFSET "-DOFFSET64BIT") +if (CPPDEFS) + separate_arguments(CPPDEFS UNIX_COMMAND "${CPPDEFS}") +endif() +list(APPEND CPPDEFS "-DMPAS_NO_LOG_REDIRECT" "-DUSE_PIO2" "-DMPAS_NO_ESMF_INIT" "-DMPAS_ESM_SHR_CONST" "-DMPAS_PERF_MOD_TIMERS" "${MODEL_FORMULATION}" "${FILE_OFFSET}" "${ZOLTAN_DEFINE}" "-D_MPI" "-DMPAS_NAMELIST_SUFFIX=${NAMELIST_SUFFIX}" "-DMPAS_EXE_NAME=${EXE_NAME}") +if (DEBUG) + list(APPEND CPPDEFS "-DMPAS_DEBUG") +endif() +if (compile_threaded) + list(APPEND CPPDEFS "-DMPAS_OPENMP") +endif() + +set(INCLUDES "${INSTALL_SHAREDPATH}/include" "${INSTALL_SHAREDPATH}/${COMP_INTERFACE}/${ESMFDIR}/${NINST_VALUE}/csm_share" "${INSTALL_SHAREDPATH}/pio" "${PNETCDF_PATH}/include" "${CMAKE_CURRENT_SOURCE_DIR}/external/ezxml" "${CMAKE_BINARY_DIR}/framework" "${CMAKE_BINARY_DIR}/operators") +if (NETCDF_PATH) + list(APPEND INCLUDES ${NETCDF_PATH}/include) +else() + if (NETCDF_C_PATH) + list(APPEND INCLUDES ${NETCDF_C_PATH}/include) + endif() + if (NETCDF_FORTRAN_PATH) + list(APPEND INCLUDES ${NETCDF_FORTRAN_PATH}/include) + endif() +endif() + +if (USE_KOKKOS) + include(${INSTALL_SHAREDPATH}/kokkos_generated_settings.cmake) + string (REPLACE ";" " " KOKKOS_CXXFLAGS_STR "${KOKKOS_CXXFLAGS}") + set(CXXFLAGS "${CXXFLAGS} ${KOKKOS_CXXFLAGS_STR}") +endif() + +set(CMAKE_Fortran_FLAGS "${FFLAGS}") +set(CMAKE_C_FLAGS "${CFLAGS}") +set(CMAKE_CXX_FLAGS "${CXXFLAGS}") + +# Include custom cmake libraries used for mpas +include(${CMAKE_CURRENT_SOURCE_DIR}/cmake_utils.cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/build_core.cmake) + +# Add tools +add_subdirectory(tools) + +# Gather sources that are needed for all cores into "common" library + +set(COMMON_RAW_SOURCES external/ezxml/ezxml.c) +include(${CMAKE_CURRENT_SOURCE_DIR}/framework/framework.cmake) +include(${CMAKE_CURRENT_SOURCE_DIR}/operators/operators.cmake) + +add_library(common OBJECT) +target_compile_definitions(common PRIVATE ${CPPDEFS}) +target_include_directories(common PRIVATE ${INCLUDES}) + +genf90_targets("${COMMON_RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "" "") +target_sources(common PRIVATE ${SOURCES}) + +# Build cores! +foreach(CORE IN LISTS CORES) + build_core(${CORE}) +endforeach() diff --git a/src/Makefile.in.E3SM b/src/Makefile.in.E3SM index 1988564a83..dabf51adac 100644 --- a/src/Makefile.in.E3SM +++ b/src/Makefile.in.E3SM @@ -14,6 +14,10 @@ endif # End duplicated logic include $(CASEROOT)/Macros.make +# Load machine/compiler specific settings +-include $(CASEROOT)/Depends.$(COMPILER) +-include $(CASEROOT)/Depends.$(MACH) +-include $(CASEROOT)/Depends.$(MACH).$(COMPILER) ifneq ($(wildcard core_$(CORE)/build_options.mk), ) # Check for build_options.mk include core_$(CORE)/build_options.mk @@ -46,9 +50,9 @@ NETCDF=$(NETCDF_PATH) PNETCDF=$(PNETCDF_PATH) PIO=$(INSTALL_SHAREDPATH)/pio FILE_OFFSET = -DOFFSET64BIT -override CFLAGS += -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS -override FFLAGS += -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS -override CPPFLAGS += $(CPPDEFS) $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE) -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -D_MPI -DMPAS_NAMELIST_SUFFIX=$(NAMELIST_SUFFIX) -DMPAS_EXE_NAME=$(EXE_NAME) -DMPAS_PERF_MOD_TIMERS +override CFLAGS += -DMPAS_NO_LOG_REDIRECT -DUSE_PIO2 -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS +override FFLAGS += -DMPAS_NO_LOG_REDIRECT -DUSE_PIO2 -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS +override CPPFLAGS += $(CPPDEFS) $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE) -DMPAS_NO_LOG_REDIRECT -DUSE_PIO2 -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -D_MPI -DMPAS_NAMELIST_SUFFIX=$(NAMELIST_SUFFIX) -DMPAS_EXE_NAME=$(EXE_NAME) -DMPAS_PERF_MOD_TIMERS override CPPINCLUDES += -I$(EXEROOT)/$(COMPONENT)/source/inc -I$(INSTALL_SHAREDPATH)/include -I$(INSTALL_SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include override FCINCLUDES += -I$(EXEROOT)/$(COMPONENT)/source/inc -I$(INSTALL_SHAREDPATH)/include -I$(INSTALL_SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include LIBS += -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -L$(LIBROOT) -L$(INSTALL_SHAREDPATH)/lib -lpio -lpnetcdf -lnetcdf diff --git a/src/build_core.cmake b/src/build_core.cmake new file mode 100644 index 0000000000..c2c36464cb --- /dev/null +++ b/src/build_core.cmake @@ -0,0 +1,67 @@ +function(build_core CORE) + set(EXE_NAME ${CORE}_model) + set(NAMELIST_SUFFIX ${CORE}) + + # Map the ESM component corresponding to each MPAS core + if (CORE STREQUAL "ocean") + set(COMPONENT "ocn") + elseif(CORE STREQUAL "landice") + set(COMPONENT "glc") + elseif(CORE STREQUAL "seaice") + set(COMPONENT "ice") + else() + message(FATAL_ERROR "Unrecognized core: ${CORE}") + endif() + + # Gather sources + set(CORE_BLDDIR ${CMAKE_BINARY_DIR}/core_${CORE}) + if (NOT EXISTS ${CORE_BLDDIR}) + file(MAKE_DIRECTORY ${CORE_BLDDIR}) + endif() + + set(CORE_INPUT_DIR ${CORE_BLDDIR}/default_inputs) + if (NOT EXISTS ${CORE_INPUT_DIR}) + file(MAKE_DIRECTORY ${CORE_INPUT_DIR}) + endif() + + # Provides us RAW_SOURCES, CPPDEFS, and INCLUDES + include(${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/${CORE}.cmake) + + add_library(${COMPONENT}) + target_compile_definitions(${COMPONENT} PRIVATE ${CPPDEFS}) + target_include_directories(${COMPONENT} PRIVATE ${INCLUDES}) + + # Make .inc files + add_custom_command ( + OUTPUT ${CORE_BLDDIR}/Registry_processed.xml + COMMAND cpp -P -traditional ${CPPDEFS} -Uvector + ${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/Registry.xml > Registry_processed.xml + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/core_${CORE}/Registry.xml + WORKING_DIRECTORY ${CORE_BLDDIR} + ) + + set(INC_DIR ${CORE_BLDDIR}/inc) + if (NOT EXISTS ${INC_DIR}) + file(MAKE_DIRECTORY ${INC_DIR}) + endif() + + add_custom_command( + OUTPUT ${INC_DIR}/core_variables.inc + COMMAND ${CMAKE_BINARY_DIR}/mpas-source/src/tools/parse < ${CORE_BLDDIR}/Registry_processed.xml + DEPENDS parse ${CORE_BLDDIR}/Registry_processed.xml + WORKING_DIRECTORY ${INC_DIR} + ) + + # Disable qsmp for some files + if (FFLAGS MATCHES ".*-qsmp.*") + foreach(DISABLE_QSMP_FILE IN LISTS DISABLE_QSMP) + get_filename_component(SOURCE_EXT ${DISABLE_QSMP_FILE} EXT) + string(REPLACE "${SOURCE_EXT}" ".f90" SOURCE_F90 ${DISABLE_QSMP_FILE}) + set_property(SOURCE ${CMAKE_BINARY_DIR}/${SOURCE_F90} APPEND_STRING PROPERTY COMPILE_FLAGS " -qnosmp") + endforeach() + endif() + + genf90_targets("${RAW_SOURCES}" "${INCLUDES}" "${CPPDEFS}" "${NO_PREPROCESS}" "${INC_DIR}") + target_sources(${COMPONENT} PRIVATE ${SOURCES} $) + +endfunction(build_core) diff --git a/src/cmake_utils.cmake b/src/cmake_utils.cmake new file mode 100644 index 0000000000..c3a25f238d --- /dev/null +++ b/src/cmake_utils.cmake @@ -0,0 +1,74 @@ +# Function for handling nl and st gen +function(handle_st_nl_gen NL_GEN_ARGS ST_GEN_ARGS CORE_INPUT_DIR_ARG CORE_BLDDIR_ARG) + foreach(NL_GEN_ARG IN LISTS NL_GEN_ARGS) + separate_arguments(ITEMS UNIX_COMMAND "${NL_GEN_ARG}") + list(GET ITEMS 0 ITEM) + list(APPEND INPUTS ${ITEM}) + add_custom_command( + OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} + COMMAND ${CMAKE_BINARY_DIR}/tools/namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${NL_GEN_ARG} + DEPENDS namelist_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml + WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} + ) + endforeach() + + foreach(ST_GEN_ARG IN LISTS ST_GEN_ARGS) + separate_arguments(ITEMS UNIX_COMMAND "${ST_GEN_ARG}") + list(GET ITEMS 0 ITEM) + list(APPEND INPUTS ${ITEM}) + add_custom_command( + OUTPUT ${CORE_INPUT_DIR_ARG}/${ITEM} + COMMAND ${CMAKE_BINARY_DIR}/tools/streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml ${ST_GEN_ARG} + DEPENDS streams_gen ${CORE_BLDDIR_ARG}/Registry_processed.xml + WORKING_DIRECTORY ${CORE_INPUT_DIR_ARG} + ) + endforeach() + + foreach(INPUT IN LISTS INPUTS) + add_custom_command( + OUTPUT ${CORE_BLDDIR_ARG}/${INPUT} + COMMAND ${CMAKE_COMMAND} -E copy ${CORE_INPUT_DIR_ARG}/${INPUT} ${CORE_BLDDIR_ARG}/${INPUT} + DEPENDS ${CORE_INPUT_DIR_ARG}/${INPUT} + WORKING_DIRECTORY ${CORE_BLDDIR_ARG} + ) + endforeach() +endfunction() + +# Function for generating f90 file targets, will add to parent's SOURCES var +function(genf90_targets RAW_SOURCES_ARG INCLUDES_ARG CPPDEFS_ARG NO_PREPROCESS_ARG CORE_INC_DIR_ARG) + # Add -I to includes so that they can used for cpp command + foreach(ITEM IN LISTS INCLUDES_ARG) + list(APPEND INCLUDES_I "-I${ITEM}") + endforeach() + + # Run all .F files through cpp to generate the f90 file + foreach(RAW_SOURCE_FILE IN LISTS RAW_SOURCES_ARG) + get_filename_component(SOURCE_EXT ${RAW_SOURCE_FILE} EXT) + if ( (SOURCE_EXT STREQUAL ".F" OR SOURCE_EXT STREQUAL ".F90") AND NOT RAW_SOURCE_FILE IN_LIST NO_PREPROCESS_ARG) + string(REPLACE "${SOURCE_EXT}" ".f90" SOURCE_F90 ${RAW_SOURCE_FILE}) + get_filename_component(DIR_RELATIVE ${SOURCE_F90} DIRECTORY) + set(DIR_ABSOLUTE ${CMAKE_BINARY_DIR}/${DIR_RELATIVE}) + if (NOT EXISTS ${DIR_ABSOLUTE}) + file(MAKE_DIRECTORY ${DIR_ABSOLUTE}) + endif() + if (CORE_INC_DIR_ARG) + add_custom_command ( + OUTPUT ${CMAKE_BINARY_DIR}/${SOURCE_F90} + COMMAND cpp -P -traditional ${CPPDEFS_ARG} ${INCLUDES_I} -Uvector + ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} > ${CMAKE_BINARY_DIR}/${SOURCE_F90} + DEPENDS ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} ${CORE_INC_DIR_ARG}/core_variables.inc) + else() + add_custom_command ( + OUTPUT ${CMAKE_BINARY_DIR}/${SOURCE_F90} + COMMAND cpp -P -traditional ${CPPDEFS_ARG} ${INCLUDES_I} -Uvector + ${CMAKE_CURRENT_SOURCE_DIR}/${RAW_SOURCE_FILE} > ${CMAKE_BINARY_DIR}/${SOURCE_F90}) + endif() + list(APPEND LOCAL_SOURCES ${CMAKE_BINARY_DIR}/${SOURCE_F90}) + else() + list(APPEND LOCAL_SOURCES ${RAW_SOURCE_FILE}) + endif() + endforeach() + + set(SOURCES ${LOCAL_SOURCES} PARENT_SCOPE) + +endfunction(genf90_targets) diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 0909d55952..c03e2fc3d0 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -1,25 +1,33 @@ .SUFFIXES: .F .o +# +# To build a dycore-only MPAS-Atmosphere model, comment-out or delete +# the definition of PHYSICS, below +# PHYSICS=-DDO_PHYSICS -#PHYSICS= + + +ifdef PHYSICS + PHYSCORE = physcore + PHYS_OBJS = libphys/*.o +endif OBJS = mpas_atm_core.o \ mpas_atm_core_interface.o \ mpas_atm_dimensions.o \ mpas_atm_threading.o -all: physcore dycore diagcore atmcore utilities +all: $(PHYSCORE) dycore diagcore atmcore utilities core_reg: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $(PHYSICS) Registry.xml > Registry_processed.xml core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi ( cd default_inputs; $(NL_GEN) ../Registry_processed.xml namelist.atmosphere in_defaults=true ) ( cd default_inputs; $(ST_GEN) ../Registry_processed.xml streams.atmosphere stream_list.atmosphere. listed ) -gen_includes: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml +gen_includes: core_reg (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) @@ -34,17 +42,17 @@ physcore: mpas_atm_dimensions.o ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*TBL .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) -dycore: mpas_atm_dimensions.o physcore +dycore: mpas_atm_dimensions.o $(PHYSCORE) ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) -diagcore: physcore dycore - ( cd diagnostics; $(MAKE) all ) +diagcore: $(PHYSCORE) dycore + ( cd diagnostics; $(MAKE) all PHYSICS="$(PHYSICS)" ) -utilities: physcore - ( cd utils; $(MAKE) all ) +utilities: $(PHYSCORE) + ( cd utils; $(MAKE) all PHYSICS="$(PHYSICS)" ) -atmcore: physcore dycore diagcore $(OBJS) - ar -ru libdycore.a $(OBJS) dynamics/*.o libphys/*.o diagnostics/*.o +atmcore: $(PHYSCORE) dycore diagcore $(OBJS) + ar -ru libdycore.a $(OBJS) dynamics/*.o $(PHYS_OBJS) diagnostics/*.o mpas_atm_core_interface.o: mpas_atm_core.o diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 42f47d5e78..c01e9e3db7 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -32,6 +32,8 @@ description="The number of atmospheric layers"/> + +#ifdef DO_PHYSICS +#endif @@ -104,32 +107,32 @@ description="When config_split_dynamics_transport = T, the number of RK steps per transport step" possible_values="Positive integer values"/> - - - - - - @@ -139,10 +142,10 @@ description="Formulation of horizontal mixing" possible_values="`2d_fixed' or `2d_smagorinsky'"/> - + possible_values="Positive real values. A zero value implies that the length scale is prescribed by the nominalMinDc value in the input file."/> - - - - - - - @@ -194,7 +197,7 @@ description="Whether to advect scalar fields" possible_values=".true. or .false."/> - @@ -243,6 +246,11 @@ units="-" description="Number of halo layers for fields" possible_values="Integer values, typically 2 or 3; DO NOT CHANGE"/> + + @@ -261,6 +269,11 @@ description="Coefficient for scaling the 2nd-order horizontal mixing in the mpas_cam absorbing layer" possible_values="0 $\leq$ config_mpas_cam_coef $\leq$ 1, standard value is 0.2"/> + + @@ -370,6 +383,13 @@ possible_values=".true. or .false."/> + + + + @@ -442,6 +462,7 @@ + @@ -466,6 +487,10 @@ +#ifdef MPAS_CAM_DYCORE + + +#endif @@ -478,6 +503,8 @@ + +#ifdef DO_PHYSICS @@ -520,6 +547,7 @@ +#endif - - - - + @@ -598,17 +623,12 @@ +#ifdef MPAS_CAM_DYCORE + + +#endif - - - - - - - - - @@ -619,8 +639,6 @@ - - @@ -635,6 +653,15 @@ + +#ifdef DO_PHYSICS + + + + + + + @@ -758,7 +785,6 @@ - @@ -801,8 +827,6 @@ - - @@ -847,6 +871,7 @@ +#endif + +#ifdef DO_PHYSICS @@ -928,7 +955,6 @@ - @@ -969,6 +995,7 @@ +#endif - - - - - - - - - - - - + + + + + + + + + + + + + + + + @@ -1049,6 +1080,21 @@ +#ifdef DO_PHYSICS + + + + + + + + + + + + +#endif + @@ -1069,6 +1115,7 @@ +#ifdef DO_PHYSICS @@ -1076,6 +1123,7 @@ +#endif +#ifdef DO_PHYSICS +#endif + + @@ -1370,6 +1423,14 @@ +#ifdef MPAS_CAM_DYCORE + + + +#endif + @@ -1430,6 +1491,11 @@ + + + + +#ifndef MPAS_CAM_DYCORE @@ -1462,7 +1528,9 @@ description="Rain number concentration" packages="mp_thompson_in"/> +#endif +#ifdef DO_PHYSICS @@ -1501,6 +1569,7 @@ description="Volcanic (VOLC) aerosol concentration"/> +#endif @@ -1580,6 +1649,9 @@ + + @@ -1698,9 +1770,6 @@ - - @@ -1743,6 +1812,11 @@ + + + + +#ifndef MPAS_CAM_DYCORE +#endif @@ -1835,6 +1910,12 @@ + + + + @@ -1842,6 +1923,7 @@ +#ifdef DO_PHYSICS + + + + + + @@ -2781,9 +2872,6 @@ - - @@ -2858,9 +2946,32 @@ description="ocean mixed layer integrated v (meridional velocity)"/> +#endif + + + + + + + + + + + +#ifdef DO_PHYSICS @@ -2958,10 +3069,12 @@ description="tendency of potential temperature due to short wave radiation"/> + description="tendency of potential temperature due to long wave radiation"/> +#endif +#ifdef DO_PHYSICS +#endif diff --git a/src/core_atmosphere/diagnostics/Makefile b/src/core_atmosphere/diagnostics/Makefile index 9d83d39c6b..614bc1c137 100644 --- a/src/core_atmosphere/diagnostics/Makefile +++ b/src/core_atmosphere/diagnostics/Makefile @@ -5,18 +5,21 @@ # DIAGNOSTIC_MODULES = \ mpas_atm_diagnostic_template.o \ - isobaric_diagnostics.o \ - convective_diagnostics.o \ - pv_diagnostics.o \ - soundings.o \ + mpas_isobaric_diagnostics.o \ + mpas_cloud_diagnostics.o \ + mpas_convective_diagnostics.o \ + mpas_pv_diagnostics.o \ + mpas_soundings.o \ -isobaric_diagnostics.o: mpas_atm_diagnostics_utils.o +mpas_isobaric_diagnostics.o: mpas_atm_diagnostics_utils.o -convective_diagnostics.o: mpas_atm_diagnostics_utils.o +mpas_cloud_diagnostics.o: mpas_atm_diagnostics_utils.o -pv_diagnostics.o: mpas_atm_diagnostics_utils.o +mpas_convective_diagnostics.o: mpas_atm_diagnostics_utils.o -soundings.o: +mpas_pv_diagnostics.o: mpas_atm_diagnostics_utils.o + +mpas_soundings.o: ################### Generally no need to modify below here ################### @@ -24,7 +27,7 @@ soundings.o: OBJS = mpas_atm_diagnostics_manager.o mpas_atm_diagnostics_utils.o -all: $(DIAGNOSTIC_MODULS) $(OBJS) +all: $(DIAGNOSTIC_MODULES) $(OBJS) mpas_atm_diagnostics_manager.o: mpas_atm_diagnostics_utils.o $(DIAGNOSTIC_MODULES) diff --git a/src/core_atmosphere/diagnostics/README b/src/core_atmosphere/diagnostics/README index e7ed654859..89fdfa66e7 100644 --- a/src/core_atmosphere/diagnostics/README +++ b/src/core_atmosphere/diagnostics/README @@ -9,7 +9,8 @@ generally required to implement a diagnostic. Registry_diagnostics.xml. 2) Create a new module for the diagnostic; the "mpas_atm_diagnostic_template.F" - module file may be used as a template. + module file may be used as a template. By convention, the file and module + names are expected to begin with "mpas_". 3) Add calls to the diagnostic's "setup", "update", "compute", "reset", and "cleanup" routines in the main diagnostic driver. Note that some diagnostics diff --git a/src/core_atmosphere/diagnostics/Registry_cloud.xml b/src/core_atmosphere/diagnostics/Registry_cloud.xml new file mode 100644 index 0000000000..54728477de --- /dev/null +++ b/src/core_atmosphere/diagnostics/Registry_cloud.xml @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml index 8d2b815842..b9e7dc5682 100644 --- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml +++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml @@ -7,6 +7,9 @@ #include "Registry_isobaric.xml" + +#include "Registry_cloud.xml" + #include "Registry_convective.xml" diff --git a/src/core_atmosphere/diagnostics/Registry_isobaric.xml b/src/core_atmosphere/diagnostics/Registry_isobaric.xml index daa758706b..853be6cde3 100644 --- a/src/core_atmosphere/diagnostics/Registry_isobaric.xml +++ b/src/core_atmosphere/diagnostics/Registry_isobaric.xml @@ -16,6 +16,12 @@ + + + + @@ -34,6 +40,12 @@ + + + + @@ -52,6 +64,12 @@ + + + + @@ -70,6 +88,12 @@ + + + + @@ -88,6 +112,12 @@ + + + + @@ -106,6 +136,12 @@ + + + + @@ -124,6 +160,12 @@ + + + + @@ -142,6 +184,12 @@ + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index 28dc7f5138..d776ec2a15 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -20,6 +20,10 @@ + + +#ifdef DO_PHYSICS @@ -32,9 +36,6 @@ - - @@ -58,9 +59,7 @@ - - +#endif diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F index 85c4876633..e1b13133ee 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F @@ -5,7 +5,7 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -module diagnostic_template +module mpas_diagnostic_template use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type @@ -134,4 +134,4 @@ subroutine diagnostic_template_cleanup() end subroutine diagnostic_template_cleanup -end module diagnostic_template +end module mpas_diagnostic_template diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F index 4af098ce1b..fb57411d1d 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F @@ -32,11 +32,12 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) use mpas_atm_diagnostics_utils, only : mpas_atm_diag_utils_init use mpas_derived_types, only : MPAS_streamManager_type, MPAS_pool_type, MPAS_clock_type, dm_info - use diagnostic_template, only : diagnostic_template_setup - use isobaric_diagnostics, only : isobaric_diagnostics_setup - use convective_diagnostics, only : convective_diagnostics_setup - use pv_diagnostics, only : pv_diagnostics_setup - use soundings, only : soundings_setup + use mpas_diagnostic_template, only : diagnostic_template_setup + use mpas_isobaric_diagnostics, only : isobaric_diagnostics_setup + use mpas_cloud_diagnostics, only : cloud_diagnostics_setup + use mpas_convective_diagnostics, only : convective_diagnostics_setup + use mpas_pv_diagnostics, only : pv_diagnostics_setup + use mpas_soundings, only : soundings_setup implicit none @@ -54,6 +55,7 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) call diagnostic_template_setup(configs, structs, clock) call isobaric_diagnostics_setup(structs, clock) + call cloud_diagnostics_setup(structs, clock) call convective_diagnostics_setup(structs, clock) call pv_diagnostics_setup(structs, clock) call soundings_setup(configs, structs, clock, dminfo) @@ -73,8 +75,8 @@ end subroutine mpas_atm_diag_setup !----------------------------------------------------------------------- subroutine mpas_atm_diag_update() - use diagnostic_template, only : diagnostic_template_update - use convective_diagnostics, only : convective_diagnostics_update + use mpas_diagnostic_template, only : diagnostic_template_update + use mpas_convective_diagnostics, only : convective_diagnostics_update implicit none @@ -97,17 +99,19 @@ end subroutine mpas_atm_diag_update !----------------------------------------------------------------------- subroutine mpas_atm_diag_compute() - use diagnostic_template, only : diagnostic_template_compute - use isobaric_diagnostics, only : isobaric_diagnostics_compute - use convective_diagnostics, only : convective_diagnostics_compute - use pv_diagnostics, only : pv_diagnostics_compute - use soundings, only : soundings_compute + use mpas_diagnostic_template, only : diagnostic_template_compute + use mpas_isobaric_diagnostics, only : isobaric_diagnostics_compute + use mpas_cloud_diagnostics, only : cloud_diagnostics_compute + use mpas_convective_diagnostics, only : convective_diagnostics_compute + use mpas_pv_diagnostics, only : pv_diagnostics_compute + use mpas_soundings, only : soundings_compute implicit none call diagnostic_template_compute() call isobaric_diagnostics_compute() + call cloud_diagnostics_compute() call convective_diagnostics_compute() call pv_diagnostics_compute() call soundings_compute() @@ -127,8 +131,8 @@ end subroutine mpas_atm_diag_compute !----------------------------------------------------------------------- subroutine mpas_atm_diag_reset() - use diagnostic_template, only : diagnostic_template_reset - use convective_diagnostics, only : convective_diagnostics_reset + use mpas_diagnostic_template, only : diagnostic_template_reset + use mpas_convective_diagnostics, only : convective_diagnostics_reset implicit none @@ -152,8 +156,8 @@ end subroutine mpas_atm_diag_reset subroutine mpas_atm_diag_cleanup() use mpas_atm_diagnostics_utils, only : mpas_atm_diag_utils_finalize - use diagnostic_template, only : diagnostic_template_cleanup - use soundings, only : soundings_cleanup + use mpas_diagnostic_template, only : diagnostic_template_cleanup + use mpas_soundings, only : soundings_cleanup implicit none diff --git a/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F new file mode 100644 index 0000000000..b4de3b3e75 --- /dev/null +++ b/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F @@ -0,0 +1,143 @@ +! Copyright (c) 2022, University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html +! +module mpas_cloud_diagnostics + + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type + use mpas_kind_types, only : RKIND + + type (MPAS_pool_type), pointer :: mesh + type (MPAS_pool_type), pointer :: diag + type (MPAS_pool_type), pointer :: diag_physics + + type (MPAS_clock_type), pointer :: clock + + public :: cloud_diagnostics_setup, & + cloud_diagnostics_compute, & + + private + + + contains + + + !----------------------------------------------------------------------- + ! routine cloud_diagnostics_setup + ! + !> \brief Initialize the cloud diagnostic module + !> \author G. Dylan Dickerson + !> \date 23 August 2022 + !> \details + !> Initialize the diagnostic and save pointers to subpools for + !> reuse in this module + ! + !----------------------------------------------------------------------- + subroutine cloud_diagnostics_setup(all_pools, simulation_clock) + + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type + use mpas_pool_routines, only : mpas_pool_get_subpool + + implicit none + + type (MPAS_pool_type), pointer :: all_pools + type (MPAS_clock_type), pointer :: simulation_clock + + + call mpas_pool_get_subpool(all_pools, 'mesh', mesh) + call mpas_pool_get_subpool(all_pools, 'diag', diag) + call mpas_pool_get_subpool(all_pools, 'diag_physics', diag_physics) + + clock => simulation_clock + + end subroutine cloud_diagnostics_setup + + + !----------------------------------------------------------------------- + ! routine cloud_diagnostics_compute + ! + !> \brief Compute diagnostic before model output is written + !> \author G. Dylan Dickerson + !> \date 23 August 2022 + !> \details + !> Compute diagnostic before model output is written + !> The following fields are computed by this routine: + !> cldfrac_low_UPP + !> cldfrac_mid_UPP + !> cldfrac_high_UPP + !> cldfrac_tot_UPP + ! + !----------------------------------------------------------------------- + subroutine cloud_diagnostics_compute() + + use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + + implicit none + + integer :: iCell, k + integer, pointer :: nCellsSolve, nVertLevels + + real (kind=RKIND), dimension(:), pointer :: cldfrac_low_UPP + real (kind=RKIND), dimension(:), pointer :: cldfrac_mid_UPP + real (kind=RKIND), dimension(:), pointer :: cldfrac_high_UPP + real (kind=RKIND), dimension(:), pointer :: cldfrac_tot_UPP + + real (kind=RKIND), dimension(:), allocatable :: p_in + real (kind=RKIND), dimension(:,:), pointer :: pressure_p + real (kind=RKIND), dimension(:,:), pointer :: pressure_base + real (kind=RKIND), dimension(:,:), pointer :: cldfrac + + ! levels for low/mid/high cloud fraction - UPP method + real (kind=RKIND), parameter :: ptop_low = 64200.0, ptop_mid = 35000.0, ptop_high = 15000.0 + + logical :: need_cldfrac_UPP + + + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_low_UPP') + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_mid_UPP') .or. need_cldfrac_UPP + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_high_UPP') .or. need_cldfrac_UPP + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_tot_UPP') .or. need_cldfrac_UPP + + if (need_cldfrac_UPP) then + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(diag, 'cldfrac_low_UPP', cldfrac_low_UPP) + call mpas_pool_get_array(diag, 'cldfrac_mid_UPP', cldfrac_mid_UPP) + call mpas_pool_get_array(diag, 'cldfrac_high_UPP', cldfrac_high_UPP) + call mpas_pool_get_array(diag, 'cldfrac_tot_UPP', cldfrac_tot_UPP) + + call mpas_pool_get_array(diag, 'pressure_base', pressure_base) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag_physics, 'cldfrac', cldfrac) + + allocate(p_in(nVertLevels)) + + do iCell = 1, nCellsSolve + cldfrac_low_UPP (iCell) = 0.0 + cldfrac_mid_UPP (iCell) = 0.0 + cldfrac_high_UPP(iCell) = 0.0 + cldfrac_tot_UPP (iCell) = 0.0 + p_in(1:nVertLevels) = pressure_p(1:nVertLevels,iCell) + pressure_base(1:nVertLevels,iCell) + do k = 1, nVertLevels + if ( p_in(k) >= ptop_low ) then + cldfrac_low_UPP(iCell) = max(cldfrac_low_UPP(iCell), cldfrac(k,iCell)) + else if ( p_in(k) < ptop_low .and. p_in(k) >= ptop_mid ) then + cldfrac_mid_UPP(iCell) = max(cldfrac_mid_UPP(iCell), cldfrac(k,iCell)) + else if ( p_in(k) < ptop_mid .and. p_in(k) >= ptop_high ) then + cldfrac_high_UPP(iCell) = max(cldfrac_high_UPP(iCell), cldfrac(k,iCell)) + end if + cldfrac_tot_UPP(iCell) = max(cldfrac_tot_UPP(iCell), cldfrac(k,iCell)) + end do + end do + + deallocate(p_in) + + end if ! need_cldfrac_UPP + + end subroutine cloud_diagnostics_compute + +end module mpas_cloud_diagnostics diff --git a/src/core_atmosphere/diagnostics/convective_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_convective_diagnostics.F similarity index 99% rename from src/core_atmosphere/diagnostics/convective_diagnostics.F rename to src/core_atmosphere/diagnostics/mpas_convective_diagnostics.F index 9554113e4e..163ee3774f 100644 --- a/src/core_atmosphere/diagnostics/convective_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_convective_diagnostics.F @@ -5,10 +5,10 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -module convective_diagnostics +module mpas_convective_diagnostics use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, MPAS_LOG_ERR, MPAS_LOG_CRIT - use mpas_kind_types, only : RKIND + use mpas_kind_types, only : RKIND, R8KIND use mpas_log, only : mpas_log_write type (MPAS_pool_type), pointer :: mesh @@ -669,7 +669,7 @@ subroutine getcape( nk , p_in , t_in , td_in, cape , cin ) real (kind=RKIND) :: th1,p1,t1,qv1,ql1,qi1,b1,pi1,thv1,qt,dp,dz,ps,frac real (kind=RKIND) :: th2,p2,t2,qv2,ql2,qi2,b2,pi2,thv2 real (kind=RKIND) :: thlast,fliq,fice,tbar,qvbar,qlbar,qibar,lhv,lhs,lhf,rm,cpm - real*8 :: avgth,avgqv + real (kind=R8KIND) :: avgth,avgqv ! real (kind=RKIND) :: getqvs,getqvi,getthe !----------------------------------------------------------------------- @@ -1096,4 +1096,4 @@ end function getthe !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !----------------------------------------------------------------------- -end module convective_diagnostics +end module mpas_convective_diagnostics diff --git a/src/core_atmosphere/diagnostics/isobaric_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F similarity index 83% rename from src/core_atmosphere/diagnostics/isobaric_diagnostics.F rename to src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F index c7aa9b568c..e52c71b125 100644 --- a/src/core_atmosphere/diagnostics/isobaric_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F @@ -5,7 +5,7 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -module isobaric_diagnostics +module mpas_isobaric_diagnostics use mpas_dmpar use mpas_kind_types @@ -26,14 +26,14 @@ module isobaric_diagnostics private logical :: need_mslp, & - need_relhum_200, need_relhum_250, need_relhum_500, need_relhum_700, need_relhum_850, need_relhum_925, & - need_dewpoint_200, need_dewpoint_250, need_dewpoint_500, need_dewpoint_700, need_dewpoint_850, need_dewpoint_925, & - need_temp_200, need_temp_250, need_temp_500, need_temp_700, need_temp_850, need_temp_925, & - need_height_200, need_height_250, need_height_500, need_height_700, need_height_850, need_height_925, & - need_uzonal_200, need_uzonal_250, need_uzonal_500, need_uzonal_700, need_uzonal_850, need_uzonal_925, & - need_umeridional_200, need_umeridional_250, need_umeridional_500, need_umeridional_700, need_umeridional_850, need_umeridional_925, & - need_w_200, need_w_250, need_w_500, need_w_700, need_w_850, need_w_925, & - need_vorticity_200, need_vorticity_250, need_vorticity_500, need_vorticity_700, need_vorticity_850, need_vorticity_925, & + need_relhum_50, need_relhum_100, need_relhum_200, need_relhum_250, need_relhum_500, need_relhum_700, need_relhum_850, need_relhum_925, & + need_dewpoint_50, need_dewpoint_100, need_dewpoint_200, need_dewpoint_250, need_dewpoint_500, need_dewpoint_700, need_dewpoint_850, need_dewpoint_925, & + need_temp_50, need_temp_100, need_temp_200, need_temp_250, need_temp_500, need_temp_700, need_temp_850, need_temp_925, & + need_height_50, need_height_100, need_height_200, need_height_250, need_height_500, need_height_700, need_height_850, need_height_925, & + need_uzonal_50, need_uzonal_100, need_uzonal_200, need_uzonal_250, need_uzonal_500, need_uzonal_700, need_uzonal_850, need_uzonal_925, & + need_umeridional_50, need_umeridional_100, need_umeridional_200, need_umeridional_250, need_umeridional_500, need_umeridional_700, need_umeridional_850, need_umeridional_925, & + need_w_50, need_w_100, need_w_200, need_w_250, need_w_500, need_w_700, need_w_850, need_w_925, & + need_vorticity_50, need_vorticity_100, need_vorticity_200, need_vorticity_250, need_vorticity_500, need_vorticity_700, need_vorticity_850, need_vorticity_925, & need_t_isobaric, need_z_isobaric, need_meanT_500_300 logical :: need_temp, need_relhum, need_dewpoint, need_w, need_uzonal, need_umeridional, need_vorticity, need_height @@ -103,6 +103,12 @@ subroutine isobaric_diagnostics_compute() need_mslp = MPAS_field_will_be_written('mslp') need_any_diags = need_any_diags .or. need_mslp + need_relhum_50 = MPAS_field_will_be_written('relhum_50hPa') + need_relhum = need_relhum .or. need_relhum_50 + need_any_diags = need_any_diags .or. need_relhum_50 + need_relhum_100 = MPAS_field_will_be_written('relhum_100hPa') + need_relhum = need_relhum .or. need_relhum_100 + need_any_diags = need_any_diags .or. need_relhum_100 need_relhum_200 = MPAS_field_will_be_written('relhum_200hPa') need_relhum = need_relhum .or. need_relhum_200 need_any_diags = need_any_diags .or. need_relhum_200 @@ -121,6 +127,12 @@ subroutine isobaric_diagnostics_compute() need_relhum_925 = MPAS_field_will_be_written('relhum_925hPa') need_relhum = need_relhum .or. need_relhum_925 need_any_diags = need_any_diags .or. need_relhum_925 + need_dewpoint_50 = MPAS_field_will_be_written('dewpoint_50hPa') + need_dewpoint = need_dewpoint .or. need_dewpoint_50 + need_any_diags = need_any_diags .or. need_dewpoint_50 + need_dewpoint_100 = MPAS_field_will_be_written('dewpoint_100hPa') + need_dewpoint = need_dewpoint .or. need_dewpoint_100 + need_any_diags = need_any_diags .or. need_dewpoint_100 need_dewpoint_200 = MPAS_field_will_be_written('dewpoint_200hPa') need_dewpoint = need_dewpoint .or. need_dewpoint_200 need_any_diags = need_any_diags .or. need_dewpoint_200 @@ -139,6 +151,12 @@ subroutine isobaric_diagnostics_compute() need_dewpoint_925 = MPAS_field_will_be_written('dewpoint_925hPa') need_dewpoint = need_dewpoint .or. need_dewpoint_925 need_any_diags = need_any_diags .or. need_dewpoint_925 + need_temp_50 = MPAS_field_will_be_written('temperature_50hPa') + need_temp = need_temp .or. need_temp_50 + need_any_diags = need_any_diags .or. need_temp_50 + need_temp_100 = MPAS_field_will_be_written('temperature_100hPa') + need_temp = need_temp .or. need_temp_100 + need_any_diags = need_any_diags .or. need_temp_100 need_temp_200 = MPAS_field_will_be_written('temperature_200hPa') need_temp = need_temp .or. need_temp_200 need_any_diags = need_any_diags .or. need_temp_200 @@ -157,6 +175,12 @@ subroutine isobaric_diagnostics_compute() need_temp_925 = MPAS_field_will_be_written('temperature_925hPa') need_temp = need_temp .or. need_temp_925 need_any_diags = need_any_diags .or. need_temp_925 + need_height_50 = MPAS_field_will_be_written('height_50hPa') + need_height = need_height .or. need_height_50 + need_any_diags = need_any_diags .or. need_height_50 + need_height_100 = MPAS_field_will_be_written('height_100hPa') + need_height = need_height .or. need_height_100 + need_any_diags = need_any_diags .or. need_height_100 need_height_200 = MPAS_field_will_be_written('height_200hPa') need_height = need_height .or. need_height_200 need_any_diags = need_any_diags .or. need_height_200 @@ -175,6 +199,12 @@ subroutine isobaric_diagnostics_compute() need_height_925 = MPAS_field_will_be_written('height_925hPa') need_height = need_height .or. need_height_925 need_any_diags = need_any_diags .or. need_height_925 + need_uzonal_50 = MPAS_field_will_be_written('uzonal_50hPa') + need_uzonal = need_uzonal .or. need_uzonal_50 + need_any_diags = need_any_diags .or. need_uzonal_50 + need_uzonal_100 = MPAS_field_will_be_written('uzonal_100hPa') + need_uzonal = need_uzonal .or. need_uzonal_100 + need_any_diags = need_any_diags .or. need_uzonal_100 need_uzonal_200 = MPAS_field_will_be_written('uzonal_200hPa') need_uzonal = need_uzonal .or. need_uzonal_200 need_any_diags = need_any_diags .or. need_uzonal_200 @@ -193,6 +223,12 @@ subroutine isobaric_diagnostics_compute() need_uzonal_925 = MPAS_field_will_be_written('uzonal_925hPa') need_uzonal = need_uzonal .or. need_uzonal_925 need_any_diags = need_any_diags .or. need_uzonal_925 + need_umeridional_50 = MPAS_field_will_be_written('umeridional_50hPa') + need_umeridional = need_umeridional .or. need_umeridional_50 + need_any_diags = need_any_diags .or. need_umeridional_50 + need_umeridional_100 = MPAS_field_will_be_written('umeridional_100hPa') + need_umeridional = need_umeridional .or. need_umeridional_100 + need_any_diags = need_any_diags .or. need_umeridional_100 need_umeridional_200 = MPAS_field_will_be_written('umeridional_200hPa') need_umeridional = need_umeridional .or. need_umeridional_200 need_any_diags = need_any_diags .or. need_umeridional_200 @@ -211,6 +247,12 @@ subroutine isobaric_diagnostics_compute() need_umeridional_925 = MPAS_field_will_be_written('umeridional_925hPa') need_umeridional = need_umeridional .or. need_umeridional_925 need_any_diags = need_any_diags .or. need_umeridional_925 + need_w_50 = MPAS_field_will_be_written('w_50hPa') + need_w = need_w .or. need_w_50 + need_any_diags = need_any_diags .or. need_w_50 + need_w_100 = MPAS_field_will_be_written('w_100hPa') + need_w = need_w .or. need_w_100 + need_any_diags = need_any_diags .or. need_w_100 need_w_200 = MPAS_field_will_be_written('w_200hPa') need_w = need_w .or. need_w_200 need_any_diags = need_any_diags .or. need_w_200 @@ -229,6 +271,12 @@ subroutine isobaric_diagnostics_compute() need_w_925 = MPAS_field_will_be_written('w_925hPa') need_w = need_w .or. need_w_925 need_any_diags = need_any_diags .or. need_w_925 + need_vorticity_50 = MPAS_field_will_be_written('vorticity_50hPa') + need_vorticity = need_vorticity .or. need_vorticity_50 + need_any_diags = need_any_diags .or. need_vorticity_50 + need_vorticity_100 = MPAS_field_will_be_written('vorticity_100hPa') + need_vorticity = need_vorticity .or. need_vorticity_100 + need_any_diags = need_any_diags .or. need_vorticity_100 need_vorticity_200 = MPAS_field_will_be_written('vorticity_200hPa') need_vorticity = need_vorticity .or. need_vorticity_200 need_any_diags = need_any_diags .or. need_vorticity_200 @@ -297,6 +345,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:,:), pointer :: z_isobaric real (kind=RKIND), dimension(:), pointer :: meanT_500_300 + real (kind=RKIND), dimension(:), pointer :: temperature_50hPa + real (kind=RKIND), dimension(:), pointer :: temperature_100hPa real (kind=RKIND), dimension(:), pointer :: temperature_200hPa real (kind=RKIND), dimension(:), pointer :: temperature_250hPa real (kind=RKIND), dimension(:), pointer :: temperature_500hPa @@ -304,6 +354,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: temperature_850hPa real (kind=RKIND), dimension(:), pointer :: temperature_925hPa + real (kind=RKIND), dimension(:), pointer :: relhum_50hPa + real (kind=RKIND), dimension(:), pointer :: relhum_100hPa real (kind=RKIND), dimension(:), pointer :: relhum_200hPa real (kind=RKIND), dimension(:), pointer :: relhum_250hPa real (kind=RKIND), dimension(:), pointer :: relhum_500hPa @@ -311,6 +363,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: relhum_850hPa real (kind=RKIND), dimension(:), pointer :: relhum_925hPa + real (kind=RKIND), dimension(:), pointer :: dewpoint_50hPa + real (kind=RKIND), dimension(:), pointer :: dewpoint_100hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_200hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_250hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_500hPa @@ -318,6 +372,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: dewpoint_850hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_925hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_50hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_100hPa real (kind=RKIND), dimension(:), pointer :: uzonal_200hPa real (kind=RKIND), dimension(:), pointer :: uzonal_250hPa real (kind=RKIND), dimension(:), pointer :: uzonal_500hPa @@ -325,6 +381,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: uzonal_850hPa real (kind=RKIND), dimension(:), pointer :: uzonal_925hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_50hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_100hPa real (kind=RKIND), dimension(:), pointer :: umeridional_200hPa real (kind=RKIND), dimension(:), pointer :: umeridional_250hPa real (kind=RKIND), dimension(:), pointer :: umeridional_500hPa @@ -332,6 +390,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: umeridional_850hPa real (kind=RKIND), dimension(:), pointer :: umeridional_925hPa + real (kind=RKIND), dimension(:), pointer :: height_50hPa + real (kind=RKIND), dimension(:), pointer :: height_100hPa real (kind=RKIND), dimension(:), pointer :: height_200hPa real (kind=RKIND), dimension(:), pointer :: height_250hPa real (kind=RKIND), dimension(:), pointer :: height_500hPa @@ -339,6 +399,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: height_850hPa real (kind=RKIND), dimension(:), pointer :: height_925hPa + real (kind=RKIND), dimension(:), pointer :: w_50hPa + real (kind=RKIND), dimension(:), pointer :: w_100hPa real (kind=RKIND), dimension(:), pointer :: w_200hPa real (kind=RKIND), dimension(:), pointer :: w_250hPa real (kind=RKIND), dimension(:), pointer :: w_500hPa @@ -346,6 +408,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: w_850hPa real (kind=RKIND), dimension(:), pointer :: w_925hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_50hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_100hPa real (kind=RKIND), dimension(:), pointer :: vorticity_200hPa real (kind=RKIND), dimension(:), pointer :: vorticity_250hPa real (kind=RKIND), dimension(:), pointer :: vorticity_500hPa @@ -411,6 +475,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'z_isobaric', z_isobaric) call mpas_pool_get_array(diag, 'meanT_500_300', meanT_500_300) + call mpas_pool_get_array(diag, 'temperature_50hPa', temperature_50hPa) + call mpas_pool_get_array(diag, 'temperature_100hPa', temperature_100hPa) call mpas_pool_get_array(diag, 'temperature_200hPa', temperature_200hPa) call mpas_pool_get_array(diag, 'temperature_250hPa', temperature_250hPa) call mpas_pool_get_array(diag, 'temperature_500hPa', temperature_500hPa) @@ -418,6 +484,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'temperature_850hPa', temperature_850hPa) call mpas_pool_get_array(diag, 'temperature_925hPa', temperature_925hPa) + call mpas_pool_get_array(diag, 'relhum_50hPa', relhum_50hPa) + call mpas_pool_get_array(diag, 'relhum_100hPa', relhum_100hPa) call mpas_pool_get_array(diag, 'relhum_200hPa', relhum_200hPa) call mpas_pool_get_array(diag, 'relhum_250hPa', relhum_250hPa) call mpas_pool_get_array(diag, 'relhum_500hPa', relhum_500hPa) @@ -425,6 +493,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'relhum_850hPa', relhum_850hPa) call mpas_pool_get_array(diag, 'relhum_925hPa', relhum_925hPa) + call mpas_pool_get_array(diag, 'dewpoint_50hPa', dewpoint_50hPa) + call mpas_pool_get_array(diag, 'dewpoint_100hPa', dewpoint_100hPa) call mpas_pool_get_array(diag, 'dewpoint_200hPa', dewpoint_200hPa) call mpas_pool_get_array(diag, 'dewpoint_250hPa', dewpoint_250hPa) call mpas_pool_get_array(diag, 'dewpoint_500hPa', dewpoint_500hPa) @@ -432,6 +502,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'dewpoint_850hPa', dewpoint_850hPa) call mpas_pool_get_array(diag, 'dewpoint_925hPa', dewpoint_925hPa) + call mpas_pool_get_array(diag, 'uzonal_50hPa', uzonal_50hPa) + call mpas_pool_get_array(diag, 'uzonal_100hPa', uzonal_100hPa) call mpas_pool_get_array(diag, 'uzonal_200hPa', uzonal_200hPa) call mpas_pool_get_array(diag, 'uzonal_250hPa', uzonal_250hPa) call mpas_pool_get_array(diag, 'uzonal_500hPa', uzonal_500hPa) @@ -439,6 +511,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'uzonal_850hPa', uzonal_850hPa) call mpas_pool_get_array(diag, 'uzonal_925hPa', uzonal_925hPa) + call mpas_pool_get_array(diag, 'umeridional_50hPa', umeridional_50hPa) + call mpas_pool_get_array(diag, 'umeridional_100hPa', umeridional_100hPa) call mpas_pool_get_array(diag, 'umeridional_200hPa', umeridional_200hPa) call mpas_pool_get_array(diag, 'umeridional_250hPa', umeridional_250hPa) call mpas_pool_get_array(diag, 'umeridional_500hPa', umeridional_500hPa) @@ -446,6 +520,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'umeridional_850hPa', umeridional_850hPa) call mpas_pool_get_array(diag, 'umeridional_925hPa', umeridional_925hPa) + call mpas_pool_get_array(diag, 'height_50hPa', height_50hPa) + call mpas_pool_get_array(diag, 'height_100hPa', height_100hPa) call mpas_pool_get_array(diag, 'height_200hPa', height_200hPa) call mpas_pool_get_array(diag, 'height_250hPa', height_250hPa) call mpas_pool_get_array(diag, 'height_500hPa', height_500hPa) @@ -453,6 +529,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'height_850hPa', height_850hPa) call mpas_pool_get_array(diag, 'height_925hPa', height_925hPa) + call mpas_pool_get_array(diag, 'w_50hPa', w_50hPa) + call mpas_pool_get_array(diag, 'w_100hPa', w_100hPa) call mpas_pool_get_array(diag, 'w_200hPa', w_200hPa) call mpas_pool_get_array(diag, 'w_250hPa', w_250hPa) call mpas_pool_get_array(diag, 'w_500hPa', w_500hPa) @@ -460,6 +538,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'w_850hPa', w_850hPa) call mpas_pool_get_array(diag, 'w_925hPa', w_925hPa) + call mpas_pool_get_array(diag, 'vorticity_50hPa', vorticity_50hPa) + call mpas_pool_get_array(diag, 'vorticity_100hPa', vorticity_100hPa) call mpas_pool_get_array(diag, 'vorticity_200hPa', vorticity_200hPa) call mpas_pool_get_array(diag, 'vorticity_250hPa', vorticity_250hPa) call mpas_pool_get_array(diag, 'vorticity_500hPa', vorticity_500hPa) @@ -528,7 +608,10 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) do iCell = 1, nCells w1 = (height(k,iCell)-height(k-1,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) w2 = (height(k+1,iCell)-height(k,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) - pressure2(k,iCell) = w1*pressure(k,iCell) + w2*pressure(k-1,iCell) + ! pressure2(k,iCell) = w1*pressure(k,iCell) + w2*pressure(k-1,iCell) + ! + ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 + pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k-1,iCell))) enddo enddo k = 1 @@ -538,7 +621,10 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) z2 = 0.5*(height(k+1,iCell)+height(k+2,iCell)) w1 = (z0-z2)/(z1-z2) w2 = 1.-w1 - pressure2(k,iCell) = w1*pressure(k,iCell)+w2*pressure(k+1,iCell) + ! pressure2(k,iCell) = w1*pressure(k,iCell)+w2*pressure(k+1,iCell) + ! + ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 + pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k+1,iCell))) enddo !calculation of total pressure at cell vertices (at mass points): @@ -572,16 +658,18 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) end if !interpolation to fixed pressure levels for fields located at cells centers and at mass points: - nIntP = 6 + nIntP = 8 if(.not.allocated(field_interp)) allocate(field_interp(nCells,nIntP) ) if(.not.allocated(press_interp)) allocate(press_interp(nCells,nIntP) ) do iCell = 1, nCells - press_interp(iCell,1) = 200.0_RKIND - press_interp(iCell,2) = 250.0_RKIND - press_interp(iCell,3) = 500.0_RKIND - press_interp(iCell,4) = 700.0_RKIND - press_interp(iCell,5) = 850.0_RKIND - press_interp(iCell,6) = 925.0_RKIND + press_interp(iCell,1) = 50.0_RKIND + press_interp(iCell,2) = 100.0_RKIND + press_interp(iCell,3) = 200.0_RKIND + press_interp(iCell,4) = 250.0_RKIND + press_interp(iCell,5) = 500.0_RKIND + press_interp(iCell,6) = 700.0_RKIND + press_interp(iCell,7) = 850.0_RKIND + press_interp(iCell,8) = 925.0_RKIND enddo if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevels)) @@ -603,12 +691,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - temperature_200hPa(1:nCells) = field_interp(1:nCells,1) - temperature_250hPa(1:nCells) = field_interp(1:nCells,2) - temperature_500hPa(1:nCells) = field_interp(1:nCells,3) - temperature_700hPa(1:nCells) = field_interp(1:nCells,4) - temperature_850hPa(1:nCells) = field_interp(1:nCells,5) - temperature_925hPa(1:nCells) = field_interp(1:nCells,6) + temperature_50hPa(1:nCells) = field_interp(1:nCells,1) + temperature_100hPa(1:nCells) = field_interp(1:nCells,2) + temperature_200hPa(1:nCells) = field_interp(1:nCells,3) + temperature_250hPa(1:nCells) = field_interp(1:nCells,4) + temperature_500hPa(1:nCells) = field_interp(1:nCells,5) + temperature_700hPa(1:nCells) = field_interp(1:nCells,6) + temperature_850hPa(1:nCells) = field_interp(1:nCells,7) + temperature_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate temperature:') end if @@ -622,12 +712,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - relhum_200hPa(1:nCells) = field_interp(1:nCells,1) - relhum_250hPa(1:nCells) = field_interp(1:nCells,2) - relhum_500hPa(1:nCells) = field_interp(1:nCells,3) - relhum_700hPa(1:nCells) = field_interp(1:nCells,4) - relhum_850hPa(1:nCells) = field_interp(1:nCells,5) - relhum_925hPa(1:nCells) = field_interp(1:nCells,6) + relhum_50hPa(1:nCells) = field_interp(1:nCells,1) + relhum_100hPa(1:nCells) = field_interp(1:nCells,2) + relhum_200hPa(1:nCells) = field_interp(1:nCells,3) + relhum_250hPa(1:nCells) = field_interp(1:nCells,4) + relhum_500hPa(1:nCells) = field_interp(1:nCells,5) + relhum_700hPa(1:nCells) = field_interp(1:nCells,6) + relhum_850hPa(1:nCells) = field_interp(1:nCells,7) + relhum_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate relative humidity:') end if @@ -640,12 +732,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - dewpoint_200hPa(1:nCells) = field_interp(1:nCells,1) - dewpoint_250hPa(1:nCells) = field_interp(1:nCells,2) - dewpoint_500hPa(1:nCells) = field_interp(1:nCells,3) - dewpoint_700hPa(1:nCells) = field_interp(1:nCells,4) - dewpoint_850hPa(1:nCells) = field_interp(1:nCells,5) - dewpoint_925hPa(1:nCells) = field_interp(1:nCells,6) + dewpoint_50hPa(1:nCells) = field_interp(1:nCells,1) + dewpoint_100hPa(1:nCells) = field_interp(1:nCells,2) + dewpoint_200hPa(1:nCells) = field_interp(1:nCells,3) + dewpoint_250hPa(1:nCells) = field_interp(1:nCells,4) + dewpoint_500hPa(1:nCells) = field_interp(1:nCells,5) + dewpoint_700hPa(1:nCells) = field_interp(1:nCells,6) + dewpoint_850hPa(1:nCells) = field_interp(1:nCells,7) + dewpoint_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate relative humidity:') end if @@ -658,12 +752,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - uzonal_200hPa(1:nCells) = field_interp(1:nCells,1) - uzonal_250hPa(1:nCells) = field_interp(1:nCells,2) - uzonal_500hPa(1:nCells) = field_interp(1:nCells,3) - uzonal_700hPa(1:nCells) = field_interp(1:nCells,4) - uzonal_850hPa(1:nCells) = field_interp(1:nCells,5) - uzonal_925hPa(1:nCells) = field_interp(1:nCells,6) + uzonal_50hPa(1:nCells) = field_interp(1:nCells,1) + uzonal_100hPa(1:nCells) = field_interp(1:nCells,2) + uzonal_200hPa(1:nCells) = field_interp(1:nCells,3) + uzonal_250hPa(1:nCells) = field_interp(1:nCells,4) + uzonal_500hPa(1:nCells) = field_interp(1:nCells,5) + uzonal_700hPa(1:nCells) = field_interp(1:nCells,6) + uzonal_850hPa(1:nCells) = field_interp(1:nCells,7) + uzonal_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate zonal wind:') end if @@ -676,12 +772,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - umeridional_200hPa(1:nCells) = field_interp(1:nCells,1) - umeridional_250hPa(1:nCells) = field_interp(1:nCells,2) - umeridional_500hPa(1:nCells) = field_interp(1:nCells,3) - umeridional_700hPa(1:nCells) = field_interp(1:nCells,4) - umeridional_850hPa(1:nCells) = field_interp(1:nCells,5) - umeridional_925hPa(1:nCells) = field_interp(1:nCells,6) + umeridional_50hPa(1:nCells) = field_interp(1:nCells,1) + umeridional_100hPa(1:nCells) = field_interp(1:nCells,2) + umeridional_200hPa(1:nCells) = field_interp(1:nCells,3) + umeridional_250hPa(1:nCells) = field_interp(1:nCells,4) + umeridional_500hPa(1:nCells) = field_interp(1:nCells,5) + umeridional_700hPa(1:nCells) = field_interp(1:nCells,6) + umeridional_850hPa(1:nCells) = field_interp(1:nCells,7) + umeridional_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate meridional wind:') end if @@ -708,12 +806,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - height_200hPa(1:nCells) = field_interp(1:nCells,1) - height_250hPa(1:nCells) = field_interp(1:nCells,2) - height_500hPa(1:nCells) = field_interp(1:nCells,3) - height_700hPa(1:nCells) = field_interp(1:nCells,4) - height_850hPa(1:nCells) = field_interp(1:nCells,5) - height_925hPa(1:nCells) = field_interp(1:nCells,6) + height_50hPa(1:nCells) = field_interp(1:nCells,1) + height_100hPa(1:nCells) = field_interp(1:nCells,2) + height_200hPa(1:nCells) = field_interp(1:nCells,3) + height_250hPa(1:nCells) = field_interp(1:nCells,4) + height_500hPa(1:nCells) = field_interp(1:nCells,5) + height_700hPa(1:nCells) = field_interp(1:nCells,6) + height_850hPa(1:nCells) = field_interp(1:nCells,7) + height_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate height:') !... vertical velocity @@ -724,12 +824,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - w_200hPa(1:nCells) = field_interp(1:nCells,1) - w_250hPa(1:nCells) = field_interp(1:nCells,2) - w_500hPa(1:nCells) = field_interp(1:nCells,3) - w_700hPa(1:nCells) = field_interp(1:nCells,4) - w_850hPa(1:nCells) = field_interp(1:nCells,5) - w_925hPa(1:nCells) = field_interp(1:nCells,6) + w_50hPa(1:nCells) = field_interp(1:nCells,1) + w_100hPa(1:nCells) = field_interp(1:nCells,2) + w_200hPa(1:nCells) = field_interp(1:nCells,3) + w_250hPa(1:nCells) = field_interp(1:nCells,4) + w_500hPa(1:nCells) = field_interp(1:nCells,5) + w_700hPa(1:nCells) = field_interp(1:nCells,6) + w_850hPa(1:nCells) = field_interp(1:nCells,7) + w_925hPa(1:nCells) = field_interp(1:nCells,8) if(allocated(field_in)) deallocate(field_in) if(allocated(press_in)) deallocate(press_in) @@ -741,16 +843,18 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) if (NEED_VORTICITY) then !interpolation to fixed pressure levels for fields located at cell vertices and at mass points: - nIntP = 6 + nIntP = 8 if(.not.allocated(field_interp)) allocate(field_interp(nVertices,nIntP) ) if(.not.allocated(press_interp)) allocate(press_interp(nVertices,nIntP) ) do iVert = 1, nVertices - press_interp(iVert,1) = 200.0_RKIND - press_interp(iVert,2) = 250.0_RKIND - press_interp(iVert,3) = 500.0_RKIND - press_interp(iVert,4) = 700.0_RKIND - press_interp(iVert,5) = 850.0_RKIND - press_interp(iVert,6) = 925.0_RKIND + press_interp(iVert,1) = 50.0_RKIND + press_interp(iVert,2) = 100.0_RKIND + press_interp(iVert,3) = 200.0_RKIND + press_interp(iVert,4) = 250.0_RKIND + press_interp(iVert,5) = 500.0_RKIND + press_interp(iVert,6) = 700.0_RKIND + press_interp(iVert,7) = 850.0_RKIND + press_interp(iVert,8) = 925.0_RKIND enddo if(.not.allocated(press_in)) allocate(press_in(nVertices,nVertLevels)) @@ -770,12 +874,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nVertices,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - vorticity_200hPa(1:nVertices) = field_interp(1:nVertices,1) - vorticity_250hPa(1:nVertices) = field_interp(1:nVertices,2) - vorticity_500hPa(1:nVertices) = field_interp(1:nVertices,3) - vorticity_700hPa(1:nVertices) = field_interp(1:nVertices,4) - vorticity_850hPa(1:nVertices) = field_interp(1:nVertices,5) - vorticity_925hPa(1:nVertices) = field_interp(1:nVertices,6) + vorticity_50hPa(1:nVertices) = field_interp(1:nVertices,1) + vorticity_100hPa(1:nVertices) = field_interp(1:nVertices,2) + vorticity_200hPa(1:nVertices) = field_interp(1:nVertices,3) + vorticity_250hPa(1:nVertices) = field_interp(1:nVertices,4) + vorticity_500hPa(1:nVertices) = field_interp(1:nVertices,5) + vorticity_700hPa(1:nVertices) = field_interp(1:nVertices,6) + vorticity_850hPa(1:nVertices) = field_interp(1:nVertices,7) + vorticity_925hPa(1:nVertices) = field_interp(1:nVertices,8) ! call mpas_log_write('--- end interpolate relative vorticity:') if(allocated(field_interp)) deallocate(field_interp) @@ -1244,4 +1350,4 @@ subroutine compute_layer_mean(layerMean, p1, p2, field_in, press_in) end subroutine compute_layer_mean -end module isobaric_diagnostics +end module mpas_isobaric_diagnostics diff --git a/src/core_atmosphere/diagnostics/pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F similarity index 99% rename from src/core_atmosphere/diagnostics/pv_diagnostics.F rename to src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index e217323947..d21061b0fb 100644 --- a/src/core_atmosphere/diagnostics/pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -5,7 +5,7 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -module pv_diagnostics +module mpas_pv_diagnostics use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type use mpas_kind_types, only : RKIND @@ -13,8 +13,10 @@ module pv_diagnostics type (MPAS_pool_type), pointer :: mesh type (MPAS_pool_type), pointer :: state type (MPAS_pool_type), pointer :: diag +#ifdef DO_PHYSICS type (MPAS_pool_type), pointer :: tend type (MPAS_pool_type), pointer :: tend_physics +#endif type (MPAS_clock_type), pointer :: clock @@ -57,8 +59,10 @@ subroutine pv_diagnostics_setup(all_pools, simulation_clock) call mpas_pool_get_subpool(all_pools, 'mesh', mesh) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(all_pools, 'tend', tend) call mpas_pool_get_subpool(all_pools, 'tend_physics', tend_physics) +#endif clock => simulation_clock @@ -100,6 +104,7 @@ subroutine pv_diagnostics_compute() need_iLev_DT = MPAS_field_will_be_written('iLev_DT') need_any_diags = need_any_diags .or. need_iLev_DT +#ifdef DO_PHYSICS need_tend_lw = MPAS_field_will_be_written('depv_dt_lw') need_any_diags = need_any_diags .or. need_tend_lw need_any_budget = need_any_budget .or. need_tend_lw @@ -133,13 +138,16 @@ subroutine pv_diagnostics_compute() need_tend_fric_pv = MPAS_field_will_be_written('depv_dt_fric_pv') need_any_diags = need_any_diags .or. need_tend_fric_pv need_any_budget = need_any_budget .or. need_tend_fric_pv +#endif if (need_any_diags) then call atm_compute_pv_diagnostics(state, 1, diag, mesh) end if +#ifdef DO_PHYSICS if (need_any_budget) then call atm_compute_pvBudget_diagnostics(state, 1, diag, mesh, tend, tend_physics) end if +#endif end subroutine pv_diagnostics_compute @@ -1639,4 +1647,4 @@ subroutine atm_compute_pvBudget_diagnostics(state, time_lev, diag, mesh, tend, t end subroutine atm_compute_pvBudget_diagnostics -end module pv_diagnostics +end module mpas_pv_diagnostics diff --git a/src/core_atmosphere/diagnostics/soundings.F b/src/core_atmosphere/diagnostics/mpas_soundings.F similarity index 88% rename from src/core_atmosphere/diagnostics/soundings.F rename to src/core_atmosphere/diagnostics/mpas_soundings.F index c213f6f82b..3175dfad1a 100644 --- a/src/core_atmosphere/diagnostics/soundings.F +++ b/src/core_atmosphere/diagnostics/mpas_soundings.F @@ -5,7 +5,7 @@ ! Additional copyright and license information can be found in the LICENSE file ! distributed with this code, or at http://mpas-dev.github.com/license.html ! -module soundings +module mpas_soundings use mpas_kind_types, only : RKIND, StrKIND use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type @@ -50,11 +50,12 @@ module soundings !----------------------------------------------------------------------- subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) - use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, dm_info - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, dm_info, MPAS_POOL_SILENT + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config, & + mpas_pool_get_error_level, mpas_pool_set_error_level use mpas_io_units, only : mpas_new_unit, mpas_release_unit - use mpas_timekeeping, only : MPAS_timeInterval_type, MPAS_time_type, MPAS_set_timeInterval, & - MPAS_get_clock_time, MPAS_add_clock_alarm, MPAS_NOW + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_timekeeping, only : MPAS_set_timeInterval, MPAS_get_clock_time, MPAS_add_clock_alarm use mpas_dmpar, only : IO_NODE, mpas_dmpar_bcast_int, mpas_dmpar_bcast_logical, mpas_dmpar_bcast_char implicit none @@ -67,6 +68,7 @@ subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) character(len=StrKIND), pointer :: soundingInterval integer :: i, ierr + integer :: err_level integer :: sndUnit real (kind=RKIND) :: station_lat, station_lon character (len=StrKIND) :: tempstr @@ -87,8 +89,30 @@ subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) + ! + ! Query the config_sounding_interval namelist option without triggering + ! warning messages if no such option exists + ! + nullify(soundingInterval) + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) call mpas_pool_get_config(configs, 'config_sounding_interval', soundingInterval) + call mpas_pool_set_error_level(err_level) + + ! + ! If the config_sounding_interval namelist option was not found, just return + ! This may happen if MPAS-A is built within another system where, e.g., only + ! dynamics namelist options are available + ! + if (.not. associated(soundingInterval)) then + call mpas_log_write('config_sounding_interval is not a namelist option...') + return + end if + ! + ! If the config_sounding_interval namelist option is 'none', no soundings + ! will to be produced + ! if (trim(soundingInterval) == 'none') then return end if @@ -205,9 +229,10 @@ subroutine soundings_compute() use mpas_derived_types, only : MPAS_pool_type use mpas_pool_routines, only : MPAS_pool_get_dimension, MPAS_pool_get_array - use mpas_timekeeping, only : MPAS_time_type, MPAS_is_alarm_ringing, MPAS_reset_clock_alarm, MPAS_get_clock_time, & - MPAS_get_time, MPAS_NOW + use mpas_derived_types, only : MPAS_Time_type, MPAS_NOW + use mpas_timekeeping, only : MPAS_is_alarm_ringing, MPAS_reset_clock_alarm, MPAS_get_clock_time, MPAS_get_time use mpas_constants, only : rvord + use mpas_io_units, only: mpas_new_unit, mpas_release_unit implicit none @@ -220,6 +245,7 @@ subroutine soundings_compute() type (MPAS_time_type) :: now character(len=StrKIND) :: nowString integer :: yyyy, mm, dd, h, m, s + integer :: sndUnit character(len=StrKIND) :: fname character(len=10) :: stid @@ -247,16 +273,17 @@ subroutine soundings_compute() ! call mpas_log_write('Writing sounding for station '//trim(stationNames(iStn))) write(fname,'(a,i4.4,i2.2,i2.2,i2.2,i2.2,a)') trim(stationNames(iStn))//'.', yyyy, mm, dd, h, m, '.snd' - open(97,file=trim(fname),form='formatted',status='replace') + call mpas_new_unit(sndUnit) + open(sndUnit,file=trim(fname),form='formatted',status='replace') write(stid,'(a)') trim(stationNames(iStn)) - write(97,'(a)') ' SNPARM = PRES;HGHT;TMPC;DWPC;DRCT;SPED;' - write(97,'(a)') '' - write(97,'(a,i2.2,i2.2,i2.2,a,i2.2,i2.2)') ' STID = '//stid//' STNM = 99999 TIME = ', mod(yyyy,100), mm, dd,'/', h, m - write(97,'(a,f6.2,a,f7.2,a)') ' SLAT = ', stationLats(iStn), ' SLON = ', stationLons(iStn), ' SELV = -999' - write(97,'(a)') '' - write(97,'(a)') ' PRES HGHT TMPC DWPC DRCT SPED' + write(sndUnit,'(a)') ' SNPARM = PRES;HGHT;TMPC;DWPC;DRCT;SPED;' + write(sndUnit,'(a)') '' + write(sndUnit,'(a,i2.2,i2.2,i2.2,a,i2.2,i2.2)') ' STID = '//stid//' STNM = 99999 TIME = ', mod(yyyy,100), mm, dd,'/', h, m + write(sndUnit,'(a,f6.2,a,f7.2,a)') ' SLAT = ', stationLats(iStn), ' SLON = ', stationLons(iStn), ' SELV = -999' + write(sndUnit,'(a)') '' + write(sndUnit,'(a)') ' PRES HGHT TMPC DWPC DRCT SPED' do k=1,nVertLevels tmpc = theta_m(k,stationCells(iStn)) / (1.0_RKIND + rvord * scalars(index_qv,k,stationCells(iStn))) * exner(k,stationCells(iStn)) @@ -281,7 +308,7 @@ subroutine soundings_compute() end if dir = dir * 180.0_RKIND / pi_const end if - write(97,'(f10.2,f10.2,f9.2,f9.2,f9.2,f9.2)') & + write(sndUnit,'(f10.2,f10.2,f9.2,f9.2,f9.2,f9.2)') & pres, & 0.5 * (zgrid(k,stationCells(iStn)) + zgrid(k+1,stationCells(iStn))), & ! Avg to layer midpoint tmpc, & @@ -290,7 +317,8 @@ subroutine soundings_compute() spd end do - close(97) + close(sndUnit) + call mpas_release_unit(sndUnit) end if end do @@ -463,4 +491,4 @@ REAL(KIND=RKIND) FUNCTION RSIF(P,T) END FUNCTION RSIF -end module soundings +end module mpas_soundings diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F index 6ecff6f157..7d439b49a8 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -13,6 +13,14 @@ module mpas_atm_boundaries use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_dimension, mpas_pool_get_subpool, mpas_pool_shift_time_levels use mpas_kind_types, only : RKIND, StrKIND use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_timeInterval, mpas_set_time, operator(-) +#ifdef __NVCOMPILER + ! + ! Some versions of the nvfortran compiler complain about the illegal use + ! of an operator on a derived type if the following specific + ! implementation of the (-) operator is not explicitly imported + ! + use mpas_timekeeping, only : sub_t_t +#endif ! Important note: At present, the code in mpas_atm_setup_bdy_masks for ! deriving the nearestRelaxationCell field assumes that nSpecZone == 2 diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index e286ee0f8f..7b80f1e087 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -15,8 +15,8 @@ module atm_time_integration use mpas_dmpar 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_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) use mpas_timer #ifdef DO_PHYSICS @@ -29,10 +29,26 @@ module atm_time_integration use mpas_atm_iau + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + subroutine halo_exchange_routine(domain, halo_group, ierr) + + use mpas_derived_types, only : domain_type + + type (domain_type), intent(inout) :: domain + character(len=*), intent(in) :: halo_group + integer, intent(out), optional :: ierr + + end subroutine halo_exchange_routine + end interface + integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables - real (kind=RKIND), allocatable, dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics + real (kind=RKIND), dimension(:,:), pointer :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics ! Used in compute_dyn_tend real (kind=RKIND), allocatable, dimension(:,:) :: qtot @@ -48,13 +64,11 @@ module atm_time_integration ! Used in atm_advance_scalars_mono real (kind=RKIND), dimension(:,:), allocatable :: scalar_old_arr, scalar_new_arr real (kind=RKIND), dimension(:,:), allocatable :: s_max_arr, s_min_arr - real (kind=RKIND), dimension(:,:,:), allocatable :: scale_array real (kind=RKIND), dimension(:,:), allocatable :: flux_array real (kind=RKIND), dimension(:,:), allocatable :: flux_upwind_tmp_arr real (kind=RKIND), dimension(:,:), allocatable :: flux_tmp_arr real (kind=RKIND), dimension(:,:), allocatable :: wdtn_arr real (kind=RKIND), dimension(:,:), allocatable :: rho_zz_int - real (kind=RKIND), dimension(:,:,:), allocatable :: scalar_tend_array real (kind=RKIND), dimension(:,:,:), allocatable :: scalars_driving ! regional_MPAS addition real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_tend ! regional_MPAS addition @@ -71,7 +85,7 @@ module atm_time_integration real (kind=RKIND), allocatable, dimension(:,:) :: ke_edge type (MPAS_Clock_type), pointer, private :: clock - type (block_type), pointer, private :: blocklist + type (block_type), pointer, private :: block ! Used for Rayleigh damping on u @@ -84,7 +98,160 @@ module atm_time_integration contains - subroutine atm_timestep(domain, dt, nowTime, itimestep) + !*********************************************************************** + ! + ! routine mpas_atm_dynamics_checks + ! + !> \brief Checks compatibility of dynamics settings + !> \author Michael Duda + !> \date 14 June 2023 + !> \details + !> This routine checks that dynamics settings are valid. + !> Specifically,the following are checked by this routine: + !> + !> 1) config_positive_definite == .false. + !> + !> At present only a warning is printed in the case of a failed check, + !> and a value of 0 is always returned by the ierr argument. However, + !> warnings may be escalated to errors in future. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_dynamics_checks(dminfo, blockList, streamManager, ierr) + + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : dm_info, block_type, MPAS_LOG_WARN + use mpas_pool_routines, only : mpas_pool_get_config + + implicit none + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: blockList + type (MPAS_streamManager_type), pointer :: streamManager + integer, intent(out) :: ierr + + logical, pointer :: config_positive_definite + + + call mpas_log_write('') + call mpas_log_write('Checking consistency of dynamics settings...') + + ! + ! Check that config_positive_definite == .false., since the positive-definite advection + ! option is currently unimplemented. + ! + nullify(config_positive_definite) + call mpas_pool_get_config(blocklist % configs, 'config_positive_definite', config_positive_definite) + + if (config_positive_definite) then + call mpas_log_write('The positive definite advection option is currently unimplemented, and', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('setting config_positive_definite = true will enable monotonic advection.', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('Please remove the specification of config_positive_definite from the', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('&nhyd_model namelist group.', & + messageType=MPAS_LOG_WARN) + end if + + call mpas_log_write(' ----- done checking dynamics settings -----') + call mpas_log_write('') + + ierr = 0 + + end subroutine mpas_atm_dynamics_checks + + + !---------------------------------------------------------------------------- + ! routine MPAS_atm_dynamics_init + ! + !> \brief Initialize the dynamics + !> \date 28 July 2021 + !> \details + !> Prepare the dynamics component of MPAS-Atmosphere for time integration. + !> This may involve, for example, allocating dynamics-local storage or + !> initializing data structures used throughout the dynamics. Since this + !> routine is called once before the first integration step, the work done + !> by this routine is generally persistent across all calls to the dynamical + !> core, in contrast to work that is performed at the beginning of each call + !> to the dynamical core. + ! + !---------------------------------------------------------------------------- + subroutine mpas_atm_dynamics_init(domain) + + implicit none + + type (domain_type), intent(inout) :: domain + +#ifdef MPAS_CAM_DYCORE + ! Used in allocating scratch fields for physics tendencies + type (mpas_pool_type), pointer :: tend_physics + type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField +#endif + + +#ifdef MPAS_CAM_DYCORE + nullify(tend_physics) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) + + call mpas_pool_get_field(tend_physics, 'tend_rtheta_physics', tend_rtheta_physicsField) + call mpas_allocate_scratch_field(tend_rtheta_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_rho_physics', tend_rho_physicsField) + call mpas_allocate_scratch_field(tend_rho_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_ru_physics', tend_ru_physicsField) + call mpas_allocate_scratch_field(tend_ru_physicsField) +#endif + + end subroutine mpas_atm_dynamics_init + + + !---------------------------------------------------------------------------- + ! routine MPAS_atm_dynamics_finalize + ! + !> \brief Finalize the dynamics + !> \author Michael Duda + !> \date 28 July 2021 + !> \details + !> Finalizes the dynamics component of MPAS-Atmosphere by, for example, + !> freeing up dynamics-local memory and shut down infrastructure used only + !> in the dynamics component of MPAS-Atmosphere. This routine is called once + !> after the last integration step, and the work done here is usually the + !> inverse of that done in the mpas_atm_dynamics_init routine (e.g., + !> deallocating memory that was allocated by mpas_atm_dynamics_init). + ! + !---------------------------------------------------------------------------- + subroutine mpas_atm_dynamics_finalize(domain) + + implicit none + + type (domain_type), intent(inout) :: domain + +#ifdef MPAS_CAM_DYCORE + ! Used in allocating scratch fields for physics tendencies + type (mpas_pool_type), pointer :: tend_physics + type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField +#endif + + +#ifdef MPAS_CAM_DYCORE + nullify(tend_physics) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) + + call mpas_pool_get_field(tend_physics, 'tend_rtheta_physics', tend_rtheta_physicsField) + call mpas_deallocate_scratch_field(tend_rtheta_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_rho_physics', tend_rho_physicsField) + call mpas_deallocate_scratch_field(tend_rho_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_ru_physics', tend_ru_physicsField) + call mpas_deallocate_scratch_field(tend_ru_physicsField) +#endif + + end subroutine mpas_atm_dynamics_finalize + + + subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance model state forward in time by the specified time step ! @@ -100,9 +267,9 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep) real (kind=RKIND), intent(in) :: dt type (MPAS_Time_type), intent(in) :: nowTime integer, intent(in) :: itimestep + procedure (halo_exchange_routine) :: exchange_halo_group - type (block_type), pointer :: block type (MPAS_Time_type) :: currTime type (MPAS_TimeInterval_type) :: dtInterval character (len=StrKIND), pointer :: xtime @@ -112,13 +279,13 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep) clock => domain % clock - blocklist => domain % blocklist + block => domain % blocklist - call mpas_pool_get_config(domain % blocklist % configs, 'config_time_integration', config_time_integration) - call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + call mpas_pool_get_config(block % configs, 'config_time_integration', config_time_integration) + call mpas_pool_get_config(block % configs, 'config_apply_lbcs', config_apply_lbcs) if (trim(config_time_integration) == 'SRK3') then - call atm_srk3(domain, dt, itimestep) + call atm_srk3(domain, dt, itimestep, exchange_halo_group) else call mpas_log_write('Unknown time integration option '//trim(config_time_integration), messageType=MPAS_LOG_ERR) call mpas_log_write('Currently, only ''SRK3'' is supported.', messageType=MPAS_LOG_CRIT) @@ -128,18 +295,14 @@ subroutine atm_timestep(domain, dt, nowTime, itimestep) currTime = nowTime + dtInterval call mpas_get_time(currTime, dateTimeString=xtime_new) - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'xtime', xtime, 2) - xtime = xtime_new - block => block % next - end do + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'xtime', xtime, 2) + xtime = xtime_new end subroutine atm_timestep - subroutine atm_srk3(domain, dt, itimestep) + subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance model state forward in time by the specified time step using ! time-split RK3 scheme @@ -158,10 +321,10 @@ subroutine atm_srk3(domain, dt, itimestep) type (domain_type), intent(inout) :: domain real (kind=RKIND), intent(in) :: dt integer, intent(in) :: itimestep + procedure (halo_exchange_routine) :: exchange_halo_group integer :: thread integer :: iCell, k, iEdge - type (block_type), pointer :: block integer, pointer :: nThreads integer, dimension(:), pointer :: cellThreadStart, cellThreadEnd @@ -203,29 +366,20 @@ subroutine atm_srk3(domain, dt, itimestep) type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: mesh type (mpas_pool_type), pointer :: tend - type (mpas_pool_type), pointer :: tend_physics + type (mpas_pool_type), pointer :: tend_physics => null() type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition - type (field2DReal), pointer :: theta_m_field - type (field3DReal), pointer :: scalars_field - type (field2DReal), pointer :: pressure_p_field - type (field2DReal), pointer :: rtheta_p_field - type (field2DReal), pointer :: rtheta_pp_field - type (field2DReal), pointer :: tend_u_field - type (field2DReal), pointer :: u_field - type (field2DReal), pointer :: w_field - type (field2DReal), pointer :: rw_p_field - type (field2DReal), pointer :: ru_p_field - type (field2DReal), pointer :: rho_pp_field - type (field2DReal), pointer :: pv_edge_field - type (field2DReal), pointer :: rho_edge_field - type (field2DReal), pointer :: exner_field - real (kind=RKIND), dimension(:,:), pointer :: w real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, scalars_1, scalars_2 - real (kind=RKIND), dimension(:,:), pointer :: rqvdynten + real (kind=RKIND), dimension(:,:), pointer :: rqvdynten, rthdynten, theta_m + real (kind=RKIND) :: theta_local, fac_m + +#ifndef MPAS_CAM_DYCORE + ! Used in allocating scratch fields for physics tendencies + type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField +#endif real (kind=RKIND) :: time_dyn_step logical, parameter :: debug = .false. @@ -234,48 +388,103 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! Retrieve configuration options ! - call mpas_pool_get_config(domain % blocklist % configs, 'config_number_of_sub_steps', config_number_of_sub_steps) - call mpas_pool_get_config(domain % blocklist % configs, 'config_time_integration_order', config_time_integration_order) - call mpas_pool_get_config(domain % blocklist % configs, 'config_scalar_advection', config_scalar_advection) - call mpas_pool_get_config(domain % blocklist % configs, 'config_positive_definite', config_positive_definite) - call mpas_pool_get_config(domain % blocklist % configs, 'config_monotonic', config_monotonic) - call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', config_dt) - call mpas_pool_get_config(domain % blocklist % configs, 'config_microp_scheme', config_microp_scheme) - call mpas_pool_get_config(domain % blocklist % configs, 'config_convection_scheme', config_convection_scheme) - call mpas_pool_get_config(domain % blocklist % configs, 'config_IAU_option', config_IAU_option) - + call mpas_pool_get_config(block % configs, 'config_number_of_sub_steps', config_number_of_sub_steps) + call mpas_pool_get_config(block % configs, 'config_time_integration_order', config_time_integration_order) + call mpas_pool_get_config(block % configs, 'config_scalar_advection', config_scalar_advection) + call mpas_pool_get_config(block % configs, 'config_positive_definite', config_positive_definite) + call mpas_pool_get_config(block % configs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(block % configs, 'config_dt', config_dt) + call mpas_pool_get_config(block % configs, 'config_IAU_option', config_IAU_option) ! config variables for dynamics-transport splitting, WCS 18 November 2014 - call mpas_pool_get_config(domain % blocklist % configs, 'config_split_dynamics_transport', config_split_dynamics_transport) - call mpas_pool_get_config(domain % blocklist % configs, 'config_dynamics_split_steps', config_dynamics_split) + call mpas_pool_get_config(block % configs, 'config_split_dynamics_transport', config_split_dynamics_transport) + call mpas_pool_get_config(block % configs, 'config_dynamics_split_steps', config_dynamics_split) + ! config variables for cloud microphysics +#ifdef DO_PHYSICS + call mpas_pool_get_config(block % configs, 'config_microp_scheme', config_microp_scheme) + call mpas_pool_get_config(block % configs, 'config_convection_scheme', config_convection_scheme) +#endif ! ! Retrieve field structures ! - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) +#ifdef DO_PHYSICS + call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) +#endif ! - ! Retrieve fields + ! Retrieve dimensions + ! Note: nCellsSolve and nVerticesSolve are not currently used in this function ! - call mpas_pool_get_field(state, 'theta_m', theta_m_field, 1) - call mpas_pool_get_field(state, 'scalars', scalars_field, 1) - call mpas_pool_get_field(diag, 'pressure_p', pressure_p_field) - call mpas_pool_get_field(diag, 'rtheta_p', rtheta_p_field) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + !call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + !call mpas_pool_get_dimension(mesh, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + + +#ifdef DO_PHYSICS + call mpas_pool_get_dimension(state, 'index_qv', index_qv) +#endif + if (config_apply_lbcs) then + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + call mpas_pool_get_dimension(state, 'index_qc', index_qc) + call mpas_pool_get_dimension(state, 'index_qr', index_qr) + call mpas_pool_get_dimension(state, 'index_qi', index_qi) + call mpas_pool_get_dimension(state, 'index_qs', index_qs) + call mpas_pool_get_dimension(state, 'index_qg', index_qg) + call mpas_pool_get_dimension(state, 'index_nr', index_nr) + call mpas_pool_get_dimension(state, 'index_ni', index_ni) + endif ! ! allocate storage for physics tendency save ! - call mpas_pool_get_dimension(state, 'nCells', nCells) - call mpas_pool_get_dimension(state, 'nEdges', nEdges) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - allocate(qtot(nVertLevels,nCells+1)) qtot(:,nCells+1) = 0.0_RKIND - allocate(tend_rtheta_physics(nVertLevels,nCells+1)) + +#ifndef MPAS_CAM_DYCORE + call mpas_pool_get_field(tend_physics, 'tend_rtheta_physics', tend_rtheta_physicsField) + call mpas_allocate_scratch_field(tend_rtheta_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_rho_physics', tend_rho_physicsField) + call mpas_allocate_scratch_field(tend_rho_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_ru_physics', tend_ru_physicsField) + call mpas_allocate_scratch_field(tend_ru_physicsField) +#endif + + call mpas_pool_get_array(tend_physics, 'tend_rtheta_physics', tend_rtheta_physics) tend_rtheta_physics(:,nCells+1) = 0.0_RKIND - allocate(tend_rho_physics(nVertLevels,nCells+1)) + call mpas_pool_get_array(tend_physics, 'tend_rho_physics', tend_rho_physics) tend_rho_physics(:,nCells+1) = 0.0_RKIND - allocate(tend_ru_physics(nVertLevels,nEdges+1)) + call mpas_pool_get_array(tend_physics, 'tend_ru_physics', tend_ru_physics) tend_ru_physics(:,nEdges+1) = 0.0_RKIND ! @@ -324,148 +533,70 @@ subroutine atm_srk3(domain, dt, itimestep) number_sub_steps(3) = number_of_sub_steps end if - -! theta_m - call mpas_dmpar_exch_halo_field(theta_m_field) - -! scalars - call mpas_dmpar_exch_halo_field(scalars_field) - -! pressure_p - call mpas_dmpar_exch_halo_field(pressure_p_field) - -! rtheta_p - call mpas_dmpar_exch_halo_field(rtheta_p_field) + ! + ! Communicate halos for theta_m, scalars, pressure_p, and rtheta_p + ! + call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') call mpas_timer_start('atm_rk_integration_setup') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - ! mesh is needed for atm_compute_moist_coefficients - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - !$OMP PARALLEL DO - do thread=1,nThreads - call atm_rk_integration_setup(state, diag, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_rk_integration_setup(state, diag, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_rk_integration_setup') call mpas_timer_start('atm_compute_moist_coefficients') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - ! mesh is needed for atm_compute_moist_coefficients - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_moist_coefficients( block % dimensions, state, diag, mesh, & !MGD could do away with dimensions arg - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_compute_moist_coefficients( block % dimensions, state, diag, mesh, & !MGD could do away with dimensions arg + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_compute_moist_coefficients') #ifdef DO_PHYSICS call mpas_timer_start('physics_get_tend') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) - rk_step = 1 - dynamics_substep = 1 - call physics_get_tend( block, & - mesh, & - state, & - diag, & - tend, & - tend_physics, & - block % configs, & - rk_step, & - dynamics_substep, & - tend_ru_physics, & - tend_rtheta_physics, & - tend_rho_physics ) - block => block % next - end do + rk_step = 1 + dynamics_substep = 1 + call physics_get_tend( block, mesh, state, diag, tend, tend_physics, & + block % configs, rk_step, dynamics_substep, & + tend_ru_physics, tend_rtheta_physics, tend_rho_physics, & + exchange_halo_group ) call mpas_timer_stop('physics_get_tend') #else +#ifndef MPAS_CAM_DYCORE ! ! If no physics are being used, simply zero-out the physics tendency fields ! tend_ru_physics(:,:) = 0.0_RKIND tend_rtheta_physics(:,:) = 0.0_RKIND tend_rho_physics(:,:) = 0.0_RKIND +#endif #endif ! ! IAU - Incremental Analysis Update ! if (trim(config_IAU_option) /= 'off') then - block => domain % blocklist - do while (associated(block)) - call atm_add_tend_anal_incr(block % configs, block % structs, itimestep, dt, & - tend_ru_physics, tend_rtheta_physics, tend_rho_physics) - block => block % next - end do + call atm_add_tend_anal_incr(block % configs, block % structs, itimestep, dt, & + tend_ru_physics, tend_rtheta_physics, tend_rho_physics) end if @@ -474,43 +605,20 @@ subroutine atm_srk3(domain, dt, itimestep) ! Compute the coefficients for the vertically implicit solve in the acoustic step. ! These coefficients will work for the first acoustic step in all cases. call mpas_timer_start('atm_compute_vert_imp_coefs') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - rk_step = 1 + rk_step = 1 !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - block => block % next + do thread=1,nThreads + call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) end do +!$OMP END PARALLEL DO call mpas_timer_stop('atm_compute_vert_imp_coefs') - call mpas_pool_get_field(diag, 'exner', exner_field) - call mpas_dmpar_exch_halo_field(exner_field) + call exchange_halo_group(domain, 'dynamics:exner') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -524,109 +632,55 @@ subroutine atm_srk3(domain, dt, itimestep) ! Compute the coefficients for the vertically implicit solve in the acoustic step. ! These coefficients will work for the 2nd and 3rd acoustic steps (dt is the same for both). - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - block => block % next + do thread=1,nThreads + call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) end do +!$OMP END PARALLEL DO end if call mpas_timer_start('atm_compute_dyn_tend') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(delsq_theta(nVertLevels,nCells+1)) - delsq_theta(:,nCells+1) = 0.0_RKIND - allocate(delsq_w(nVertLevels,nCells+1)) - delsq_w(:,nCells+1) = 0.0_RKIND -!! allocate(qtot(nVertLevels,nCells+1)) ! initializing this earlier in solution sequence - allocate(delsq_divergence(nVertLevels,nCells+1)) - delsq_divergence(:,nCells+1) = 0.0_RKIND - allocate(delsq_u(nVertLevels,nEdges+1)) - delsq_u(:,nEdges+1) = 0.0_RKIND -!! allocate(delsq_circulation(nVertLevels,nVertices+1)) ! no longer used -> removed - allocate(delsq_vorticity(nVertLevels,nVertices+1)) - delsq_vorticity(:,nVertices+1) = 0.0_RKIND - allocate(dpdz(nVertLevels,nCells+1)) - dpdz(:,nCells+1) = 0.0_RKIND + allocate(delsq_theta(nVertLevels,nCells+1)) + delsq_theta(:,nCells+1) = 0.0_RKIND + allocate(delsq_w(nVertLevels,nCells+1)) + delsq_w(:,nCells+1) = 0.0_RKIND +!! allocate(qtot(nVertLevels,nCells+1)) ! initializing this earlier in solution sequence + allocate(delsq_divergence(nVertLevels,nCells+1)) + delsq_divergence(:,nCells+1) = 0.0_RKIND + allocate(delsq_u(nVertLevels,nEdges+1)) + delsq_u(:,nEdges+1) = 0.0_RKIND +!! allocate(delsq_circulation(nVertLevels,nVertices+1)) ! no longer used -> removed + allocate(delsq_vorticity(nVertLevels,nVertices+1)) + delsq_vorticity(:,nVertices+1) = 0.0_RKIND + allocate(dpdz(nVertLevels,nCells+1)) + dpdz(:,nCells+1) = 0.0_RKIND !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - deallocate(delsq_theta) - deallocate(delsq_w) -!! deallocate(qtot) ! deallocation after dynamics step complete, see below - deallocate(delsq_divergence) - deallocate(delsq_u) -!! deallocate(delsq_circulation) ! no longer used -> removed - deallocate(delsq_vorticity) - deallocate(dpdz) + deallocate(delsq_theta) + deallocate(delsq_w) +!! deallocate(qtot) ! deallocation after dynamics step complete, see below + deallocate(delsq_divergence) + deallocate(delsq_u) +!! deallocate(delsq_circulation) ! no longer used -> removed + deallocate(delsq_vorticity) + deallocate(dpdz) - block => block % next - end do call mpas_timer_stop('atm_compute_dyn_tend') @@ -637,145 +691,72 @@ subroutine atm_srk3(domain, dt, itimestep) !*********************************** ! tend_u - call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) - call mpas_pool_get_field(tend, 'u', tend_u_field) - call mpas_dmpar_exch_halo_field(tend_u_field, (/ 1 /)) + call exchange_halo_group(domain, 'dynamics:tend_u') call mpas_timer_start('small_step_prep') - - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - !$OMP PARALLEL DO - do thread=1,nThreads - call atm_set_smlstep_pert_variables( tend, diag, mesh, block % configs, & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - block => block % next + do thread=1,nThreads + call atm_set_smlstep_pert_variables( tend, diag, mesh, block % configs, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) end do +!$OMP END PARALLEL DO call mpas_timer_stop('small_step_prep') !------------------------------------------------------------------------------------------------------------------------ if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS dry dynamics in the specified zone - - block => domain % blocklist - do while (associated(block)) - - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(ru_driving_tend(nVertLevels,nEdges+1)) - allocate(rt_driving_tend(nVertLevels,nCells+1)) - allocate(rho_driving_tend(nVertLevels,nCells+1)) - ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nEdges, 'ru', 0.0_RKIND ) - rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) - rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) + allocate(ru_driving_tend(nVertLevels,nEdges+1)) + allocate(rt_driving_tend(nVertLevels,nCells+1)) + allocate(rho_driving_tend(nVertLevels,nCells+1)) + ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_tend( clock, block, nVertLevels, nEdges, 'ru', 0.0_RKIND ) + rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, block, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) + rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, block, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, block % configs, nVertLevels, & - ru_driving_tend, rt_driving_tend, rho_driving_tend, & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) - end do + do thread=1,nThreads + call atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, block % configs, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + end do !$OMP END PARALLEL DO - deallocate(ru_driving_tend) - deallocate(rt_driving_tend) - deallocate(rho_driving_tend) - block => block % next - end do + deallocate(ru_driving_tend) + deallocate(rt_driving_tend) + deallocate(rho_driving_tend) ! -------- next, add in the tendencies for the horizontal filters and Rayleigh damping. We will keep the spec zone and relax zone adjustments separate for now... - - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(ru_driving_values(nVertLevels,nEdges+1)) - allocate(rt_driving_values(nVertLevels,nCells+1)) - allocate(rho_driving_values(nVertLevels,nCells+1)) - - time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) - ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', time_dyn_step ) - rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) - rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) -!$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVertLevels, dt, & - ru_driving_values, rt_driving_values, rho_driving_values, & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) - end do -!$OMP END PARALLEL DO + allocate(ru_driving_values(nVertLevels,nEdges+1)) + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) - deallocate(ru_driving_values) - deallocate(rt_driving_values) - deallocate(rho_driving_values) - block => block % next + time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nEdges, 'ru', time_dyn_step ) + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rho_zz', time_dyn_step ) + +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_adjust_dynamics_relaxzone_tend( block % configs, tend, state, diag, mesh, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) end do +!$OMP END PARALLEL DO + deallocate(ru_driving_values) + deallocate(rt_driving_values) + deallocate(rho_driving_values) end if ! regional_MPAS addition @@ -787,146 +768,66 @@ subroutine atm_srk3(domain, dt, itimestep) do small_step = 1, number_sub_steps(rk_step) - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) - call mpas_dmpar_exch_halo_field(rho_pp_field, (/ 1 /)) + call exchange_halo_group(domain, 'dynamics:rho_pp') call mpas_timer_start('atm_advance_acoustic_step') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_advance_acoustic_step( state, diag, tend, mesh, block % configs, nCells, nVertLevels, & - rk_sub_timestep(rk_step), small_step, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_advance_acoustic_step( state, diag, tend, mesh, block % configs, nCells, nVertLevels, & + rk_sub_timestep(rk_step), small_step, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_advance_acoustic_step') ! rtheta_pp ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) - call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 1 /)) + call exchange_halo_group(domain, 'dynamics:rtheta_pp') ! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step call mpas_timer_start('atm_divergence_damping_3d') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_divergence_damping_3d( state, diag, mesh, block % configs, rk_sub_timestep(rk_step), & - edgeThreadStart(thread), edgeThreadEnd(thread) ) - end do + do thread=1,nThreads + call atm_divergence_damping_3d( state, diag, mesh, block % configs, rk_sub_timestep(rk_step), & + edgeThreadStart(thread), edgeThreadEnd(thread) ) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_divergence_damping_3d') end do ! end of acoustic steps loop - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'rw_p', rw_p_field) - call mpas_dmpar_exch_halo_field(rw_p_field) - - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /)) - call mpas_pool_get_field(diag, 'ru_p', ru_p_field) - call mpas_dmpar_exch_halo_field(ru_p_field) - - call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) - call mpas_dmpar_exch_halo_field(rho_pp_field) - - ! the second layer of halo cells must be exchanged before calling atm_recover_large_step_variables - call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) - call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 2 /)) + ! + ! Communicate halos for rw_p[1,2], ru_p[1,2], rho_pp[1,2], rtheta_pp[2] + ! + call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') call mpas_timer_start('atm_recover_large_step_variables') - block => domain % blocklist - do while (associated(block)) - - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_recover_large_step_variables( state, diag, tend, mesh, block % configs, rk_timestep(rk_step), & - number_sub_steps(rk_step), rk_step, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_recover_large_step_variables( state, diag, tend, mesh, block % configs, rk_timestep(rk_step), & + number_sub_steps(rk_step), rk_step, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_recover_large_step_variables') !------------------------------------------------------------------- @@ -935,46 +836,34 @@ subroutine atm_srk3(domain, dt, itimestep) ! First, (re)set the value of u and ru in the specified zone at the outermost edge (we will reset all for now). ! atm_recover_large_step_variables will not have set outermost edge velocities correctly. - - block => domain % blocklist - do while (associated(block)) - - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - - allocate(ru_driving_values(nVertLevels,nEdges+1)) - - time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) - - ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'u', time_dyn_step ) - ! do this inline at present - it is simple enough - do iEdge = 1, nEdgesSolve - if(bdyMaskEdge(iEdge) > nRelaxZone) then - do k = 1, nVertLevels - u(k,iEdge) = ru_driving_values(k,iEdge) - end do - end if - end do + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nEdges, 'ru', time_dyn_step ) - call mpas_pool_get_array(diag, 'ru', u) - ! do this inline at present - it is simple enough - do iEdge = 1, nEdges - if(bdyMaskEdge(iEdge) > nRelaxZone) then - do k = 1, nVertLevels - u(k,iEdge) = ru_driving_values(k,iEdge) - end do - end if - end do - - block => block % next + allocate(ru_driving_values(nVertLevels,nEdges+1)) + + time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) + + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nEdges, 'u', time_dyn_step ) + ! do this inline at present - it is simple enough + do iEdge = 1, nEdgesSolve + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k = 1, nVertLevels + u(k,iEdge) = ru_driving_values(k,iEdge) + end do + end if end do + + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nEdges, 'ru', time_dyn_step ) + call mpas_pool_get_array(diag, 'ru', u) + ! do this inline at present - it is simple enough + do iEdge = 1, nEdges + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k = 1, nVertLevels + u(k,iEdge) = ru_driving_values(k,iEdge) + end do + end if + end do + deallocate(ru_driving_values) end if ! regional_MPAS addition @@ -982,310 +871,125 @@ subroutine atm_srk3(domain, dt, itimestep) !------------------------------------------------------------------- ! u - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /)) - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'u', u_field, 2) - call mpas_dmpar_exch_halo_field(u_field) + if (config_apply_lbcs) then + call exchange_halo_group(domain, 'dynamics:u_123') + else + call exchange_halo_group(domain, 'dynamics:u_3') + end if ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_start('atm_advance_scalars') - else - call mpas_timer_start('atm_advance_scalars_mono') - end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(scalar_old_arr(nVertLevels,nCells+1)) - scalar_old_arr(:,nCells+1) = 0.0_RKIND - allocate(scalar_new_arr(nVertLevels,nCells+1)) - scalar_new_arr(:,nCells+1) = 0.0_RKIND - allocate(s_max_arr(nVertLevels,nCells+1)) - s_max_arr(:,nCells+1) = 0.0_RKIND - allocate(s_min_arr(nVertLevels,nCells+1)) - s_min_arr(:,nCells+1) = 0.0_RKIND - allocate(scale_array(nVertLevels,2,nCells+1)) - scale_array(:,:,nCells+1) = 0.0_RKIND - allocate(flux_array(nVertLevels,nEdges+1)) - flux_array(:,nEdges+1) = 0.0_RKIND - allocate(wdtn_arr(nVertLevels+1,nCells+1)) - wdtn_arr(:,nCells+1) = 0.0_RKIND - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) - horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND - else - allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) - flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND - allocate(flux_tmp_arr(nVertLevels,nEdges+1)) - flux_tmp_arr(:,nEdges+1) = 0.0_RKIND - end if - - ! - ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses - ! the functionality of the advance_scalars routine; however, it is noticeably slower, - ! so we use the advance_scalars routine for the first two RK substeps. - ! -!$OMP PARALLEL DO - do thread=1,nThreads - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.false. ) - else - - block % domain = domain - call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=.false.) - end if - end do -!$OMP END PARALLEL DO - - deallocate(scalar_old_arr) - deallocate(scalar_new_arr) - deallocate(s_max_arr) - deallocate(s_min_arr) - deallocate(scale_array) - deallocate(flux_array) - deallocate(wdtn_arr) - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - deallocate(horiz_flux_array) - else - deallocate(flux_upwind_tmp_arr) - deallocate(flux_tmp_arr) - end if - - block => block % next - end do - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_stop('atm_advance_scalars') - else - call mpas_timer_stop('atm_advance_scalars_mono') - end if + call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter - call mpas_dmpar_exch_halo_field(scalars_field) + call exchange_halo_group(domain, 'dynamics:scalars') - block => domain % blocklist - do while (associated(block)) + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) - - - ! get the scalar values driving the regional boundary conditions - ! - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_qc', index_qc) - call mpas_pool_get_dimension(state, 'index_qr', index_qr) - call mpas_pool_get_dimension(state, 'index_qi', index_qi) - call mpas_pool_get_dimension(state, 'index_qs', index_qs) - call mpas_pool_get_dimension(state, 'index_qg', index_qg) - call mpas_pool_get_dimension(state, 'index_nr', index_nr) - call mpas_pool_get_dimension(state, 'index_ni', index_ni) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - if (index_qv > 0) then - scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) - end if - if (index_qc > 0) then - scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) - end if - if (index_qr > 0) then - scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) - end if - if (index_qi > 0) then - scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) - end if - if (index_qs > 0) then - scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) - end if - if (index_qg > 0) then - scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) - end if - if (index_nr > 0) then - scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) - end if - if (index_ni > 0) then - scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) - end if + ! get the scalar values driving the regional boundary conditions + ! + if (index_qv > 0) then + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) + end if + if (index_qc > 0) then + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) + end if + if (index_qr > 0) then + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) + end if + if (index_qi > 0) then + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) + end if + if (index_qs > 0) then + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) + end if + if (index_qg > 0) then + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) + end if + if (index_nr > 0) then + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + end if + if (index_ni > 0) then + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + end if - !$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) - end do - !$OMP END PARALLEL DO + !$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do + !$OMP END PARALLEL DO - deallocate(scalars_driving) + deallocate(scalars_driving) - block => block % next - end do end if ! regional_MPAS addition end if call mpas_timer_start('atm_compute_solve_diagnostics') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(state, 'nEdges', nEdges) - call mpas_pool_get_dimension(state, 'nVertices', nVertices) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - - allocate(ke_vertex(nVertLevels,nVertices+1)) - ke_vertex(:,nVertices+1) = 0.0_RKIND - allocate(ke_edge(nVertLevels,nEdges+1)) - ke_edge(:,nEdges+1) = 0.0_RKIND + allocate(ke_vertex(nVertLevels,nVertices+1)) + ke_vertex(:,nVertices+1) = 0.0_RKIND + allocate(ke_edge(nVertLevels,nEdges+1)) + ke_edge(:,nEdges+1) = 0.0_RKIND !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_solve_diagnostics(dt, state, 2, diag, mesh, block % configs, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), rk_step) - end do + do thread=1,nThreads + call atm_compute_solve_diagnostics(dt, state, 2, diag, mesh, block % configs, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), rk_step) + end do !$OMP END PARALLEL DO - deallocate(ke_vertex) - deallocate(ke_edge) + deallocate(ke_vertex) + deallocate(ke_edge) - block => block % next - end do call mpas_timer_stop('atm_compute_solve_diagnostics') - - ! w - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'w', w_field, 2) - call mpas_dmpar_exch_halo_field(w_field) - - ! pv_edge - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) - call mpas_dmpar_exch_halo_field(pv_edge_field) - - ! rho_edge - call mpas_pool_get_field(diag, 'rho_edge', rho_edge_field) - call mpas_dmpar_exch_halo_field(rho_edge_field) - - ! scalars if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) - call mpas_dmpar_exch_halo_field(scalars_field) + ! + ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2], scalars[1,2] + ! + call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + else + ! + ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2] + ! + call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge') end if ! set the zero-gradient condition on w for regional_MPAS if ( config_apply_lbcs ) then ! regional_MPAS addition - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_zero_gradient_w_bdy( state, mesh, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) - end do -!$OMP END PARALLEL DO - - block => block % next + do thread=1,nThreads + call atm_zero_gradient_w_bdy( state, mesh, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) end do +!$OMP END PARALLEL DO ! w halo values needs resetting after regional boundary update - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'w', w_field, 2) - call mpas_dmpar_exch_halo_field(w_field) + call exchange_halo_group(domain, 'dynamics:w') end if ! end of regional_MPAS addition end do RK3_DYNAMICS if (dynamics_substep < dynamics_split) then - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'theta_m', theta_m_field, 2) - call mpas_dmpar_exch_halo_field(theta_m_field) - call mpas_dmpar_exch_halo_field(pressure_p_field) - call mpas_dmpar_exch_halo_field(rtheta_p_field) + ! + ! Communicate halos for theta_m[1,2], pressure_p[1,2], and rtheta_p[1,2] + ! + call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -1302,51 +1006,32 @@ subroutine atm_srk3(domain, dt, itimestep) ! Notes: physics tendencies for scalars should be OK coming out of dynamics call mpas_timer_start('atm_rk_dynamics_substep_finish') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_rk_dynamics_substep_finish(state, diag, dynamics_substep, dynamics_split, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_rk_dynamics_substep_finish(state, diag, dynamics_substep, dynamics_split, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_rk_dynamics_substep_finish') end do DYNAMICS_SUBSTEPS deallocate(qtot) ! we are finished with these now - deallocate(tend_rtheta_physics) - deallocate(tend_rho_physics) - deallocate(tend_ru_physics) + +#ifndef MPAS_CAM_DYCORE + call mpas_deallocate_scratch_field(tend_rtheta_physicsField) + call mpas_deallocate_scratch_field(tend_rho_physicsField) + call mpas_deallocate_scratch_field(tend_ru_physicsField) +#endif + ! ! split transport, at present RK3 @@ -1363,212 +1048,60 @@ subroutine atm_srk3(domain, dt, itimestep) RK3_SPLIT_TRANSPORT : do rk_step = 1, 3 ! Runge-Kutta loop - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_start('atm_advance_scalars') - else - call mpas_timer_start('atm_advance_scalars_mono') - end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(scalar_old_arr(nVertLevels,nCells+1)) - scalar_old_arr(:,nCells+1) = 0.0_RKIND - allocate(scalar_new_arr(nVertLevels,nCells+1)) - scalar_new_arr(:,nCells+1) = 0.0_RKIND - allocate(s_max_arr(nVertLevels,nCells+1)) - s_max_arr(:,nCells+1) = 0.0_RKIND - allocate(s_min_arr(nVertLevels,nCells+1)) - s_min_arr(:,nCells+1) = 0.0_RKIND - allocate(scale_array(nVertLevels,2,nCells+1)) - scale_array(:,:,nCells+1) = 0.0_RKIND - allocate(flux_array(nVertLevels,nEdges+1)) - flux_array(:,nEdges+1) = 0.0_RKIND - allocate(wdtn_arr(nVertLevels+1,nCells+1)) - wdtn_arr(:,nCells+1) = 0.0_RKIND - allocate(rho_zz_int(nVertLevels,nCells+1)) - rho_zz_int(:,nCells+1) = 0.0_RKIND - allocate(scalar_tend_array(num_scalars,nVertLevels,nCells+1)) - scalar_tend_array(:,:,nCells+1) = 0.0_RKIND - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) - horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND - else - allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) - flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND - allocate(flux_tmp_arr(nVertLevels,nEdges+1)) - flux_tmp_arr(:,nEdges+1) = 0.0_RKIND - end if - - ! - ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses - ! the functionality of the advance_scalars routine; however, it is noticeably slower, - ! so we use the advance_scalars routine for the first two RK substeps. - ! - - ! The latest version of atm_advance_scalars does not need the arrays scalar_tend_array or rho_zz_int - ! We can remove scalar_tend_array???? WCS 20160921 -!$OMP PARALLEL DO - do thread=1,nThreads - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.true., scalar_tend=scalar_tend_array, rho_zz_int=rho_zz_int ) - else - - block % domain = domain - call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=.true., rho_zz_int=rho_zz_int) - end if - end do -!$OMP END PARALLEL DO - - deallocate(scalar_old_arr) - deallocate(scalar_new_arr) - deallocate(s_max_arr) - deallocate(s_min_arr) - deallocate(scale_array) - deallocate(flux_array) - deallocate(wdtn_arr) - deallocate(rho_zz_int) - deallocate(scalar_tend_array) - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - deallocate(horiz_flux_array) - else - deallocate(flux_upwind_tmp_arr) - deallocate(flux_tmp_arr) - end if - - block => block % next - end do - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_stop('atm_advance_scalars') - else - call mpas_timer_stop('atm_advance_scalars_mono') - end if - -!------------------------------------------------------------------------------------------------------------------------ + call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter - call mpas_dmpar_exch_halo_field(scalars_field) - - block => domain % blocklist - do while (associated(block)) - - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + ! need to fill halo for horizontal filter + call exchange_halo_group(domain, 'dynamics:scalars') - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) - - - ! get the scalar values driving the regional boundary conditions - ! - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_qc', index_qc) - call mpas_pool_get_dimension(state, 'index_qr', index_qr) - call mpas_pool_get_dimension(state, 'index_qi', index_qi) - call mpas_pool_get_dimension(state, 'index_qs', index_qs) - call mpas_pool_get_dimension(state, 'index_qg', index_qg) - call mpas_pool_get_dimension(state, 'index_nr', index_nr) - call mpas_pool_get_dimension(state, 'index_ni', index_ni) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) - if (index_qv > 0) then - scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) - end if - if (index_qc > 0) then - scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) - end if - if (index_qr > 0) then - scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) - end if - if (index_qi > 0) then - scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) - end if - if (index_qs > 0) then - scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) - end if - if (index_qg > 0) then - scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) - end if - if (index_nr > 0) then - scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) - end if - if (index_ni > 0) then - scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) - end if - + ! get the scalar values driving the regional boundary conditions + ! + if (index_qv > 0) then + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) + end if + if (index_qc > 0) then + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) + end if + if (index_qr > 0) then + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) + end if + if (index_qi > 0) then + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) + end if + if (index_qs > 0) then + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) + end if + if (index_qg > 0) then + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) + end if + if (index_nr > 0) then + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + end if + if (index_ni > 0) then + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + end if + !$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) - end do + do thread=1,nThreads + call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do !$OMP END PARALLEL DO - deallocate(scalars_driving) + deallocate(scalars_driving) - block => block % next - end do end if ! regional_MPAS addition !------------------------------------------------------------------------------------------------------------------------ if (rk_step < 3) then - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) - call mpas_dmpar_exch_halo_field(scalars_field) + call exchange_halo_group(domain, 'dynamics:scalars') end if end do RK3_SPLIT_TRANSPORT @@ -1578,29 +1111,21 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! reconstruct full velocity vectors at cell centers: ! - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + + call mpas_reconstruct(mesh, u, & + uReconstructX, & + uReconstructY, & + uReconstructZ, & + uReconstructZonal, & + uReconstructMeridional & + ) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) - call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) - call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) - call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) - - call mpas_reconstruct(mesh, u, & - uReconstructX, & - uReconstructY, & - uReconstructZ, & - uReconstructZonal, & - uReconstructMeridional & - ) - - block => block % next - end do ! ! call to parameterizations of cloud microphysics. calculation of the tendency of water vapor to horizontal and @@ -1608,57 +1133,53 @@ subroutine atm_srk3(domain, dt, itimestep) ! #ifdef DO_PHYSICS - block => domain % blocklist - do while(associated(block)) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_array(state, 'scalars', scalars_1, 1) - call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call mpas_pool_get_dimension(state, 'index_qv', index_qv) + if(config_convection_scheme == 'cu_grell_freitas' .or. & + config_convection_scheme == 'cu_ntiedtke') then - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + if (associated(tend_physics)) then + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + end if - if(config_convection_scheme == 'cu_grell_freitas' .or. & - config_convection_scheme == 'cu_tiedtke' .or. & - config_convection_scheme == 'cu_ntiedtke') then + !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 + rqvdynten(:,:) = ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt + else + rqvdynten(:,:) = 0._RKIND + end if - call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + do k = 1, nVertLevels + do iCell = 1, nCellsSolve + fac_m = 1._RKIND/(1._RKIND + rv/rgas*scalars_2(index_qv,k,iCell)) + theta_local = theta_m(k,iCell)*fac_m + rthdynten(k,iCell) = fac_m*(rthdynten(k,iCell)-theta_local*rv/rgas*rqvdynten(k,iCell)) + end do + end do - !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 - rqvdynten(:,:) = ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt - else - rqvdynten(:,:) = 0._RKIND - end if - end if + end if - !simply set to zero negative mixing ratios of different water species (for now): - where ( scalars_2(:,:,:) < 0.0) & - scalars_2(:,:,:) = 0.0 + !simply set to zero negative mixing ratios of different water species (for now): + where ( scalars_2(:,:,:) < 0.0) & + scalars_2(:,:,:) = 0.0 - !call microphysics schemes: - if (trim(config_microp_scheme) /= 'off') then - call mpas_timer_start('microphysics') + !call microphysics schemes: + if (trim(config_microp_scheme) /= 'off') then + call mpas_timer_start('microphysics') !$OMP PARALLEL DO - do thread=1,nThreads - call driver_microphysics ( block % configs, mesh, state, 2, diag, diag_physics, tend, itimestep, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call driver_microphysics ( block % configs, mesh, state, 2, diag, diag_physics, tend, itimestep, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - call mpas_timer_stop('microphysics') - end if - block => block % next - end do + call mpas_timer_stop('microphysics') + end if ! ! Note: A halo exchange for 'exner' here as well as at the end of @@ -1671,129 +1192,247 @@ subroutine atm_srk3(domain, dt, itimestep) if (config_apply_lbcs) then ! reset boundary values of rtheta in the specified zone - microphysics has messed with them - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) + time_dyn_step = dt ! end of full timestep values - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rho_zz', time_dyn_step ) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & + rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO - allocate(rt_driving_values(nVertLevels,nCells+1)) - allocate(rho_driving_values(nVertLevels,nCells+1)) - time_dyn_step = dt ! end of full timestep values + deallocate(rt_driving_values) + deallocate(rho_driving_values) - rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) - rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', time_dyn_step ) + end if ! regional_MPAS addition -!$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & - rt_driving_values, rho_driving_values, & - cellThreadStart(thread), cellThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) - end do -!$OMP END PARALLEL DO - deallocate(rt_driving_values) - deallocate(rho_driving_values) - block => block % next + if (config_apply_lbcs) then ! adjust boundary values for regional_MPAS scalar transport + call exchange_halo_group(domain, 'dynamics:scalars') + + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + + ! get the scalar values driving the regional boundary conditions + ! + if (index_qv > 0) then + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qv', dt ) + end if + if (index_qc > 0) then + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qc', dt ) + end if + if (index_qr > 0) then + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qr', dt ) + end if + if (index_qi > 0) then + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qi', dt ) + end if + if (index_qs > 0) then + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qs', dt ) + end if + if (index_qg > 0) then + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qg', dt ) + end if + if (index_nr > 0) then + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nr', dt ) + end if + if (index_ni > 0) then + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', dt ) + end if + +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) end do +!$OMP END PARALLEL DO + + deallocate(scalars_driving) end if ! regional_MPAS addition + call summarize_timestep(domain) - if (config_apply_lbcs) then ! adjust boundary values for regional_MPAS scalar transport + end subroutine atm_srk3 - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) ! need to fill halo for horizontal filter - call mpas_dmpar_exch_halo_field(scalars_field) - block => domain % blocklist - do while (associated(block)) + !----------------------------------------------------------------------- + ! routine advance_scalars + ! + !> \brief Advance the scalar fields + !> \date 10 February 2020 + !> \details + !> Manages the advance of the model scalar fields, taking into account + !> runtime selection of monotonicity and scalar transport splitting. + !> + !> The first argument, field_name, indicates the base name for the array + !> of scalars to be advected. It is assumed that, if the name of + !> the array is XYZ, then there will exist: + !> + !> (1) An array in the 'state' pool named XYZ with dimensions + !> (num_XYZ, nVertLevels, nCells) and two time levels + !> + !> (2) A dimension, num_XYZ, in the 'state' pool + !> + !> (3) An array in the 'tend' pool named XYZ_tend with dimensions + !> (num_XYZ, nVertLevels, nCells) and one time level + !> + !> The scalars arrays can either be var_arrays formed from multiple + !> constituents, each with dimensions (nVertLevels, nCells), or they can + !> simply be vars with dimensions (num_???, nVertLevels, nCells). + ! + !----------------------------------------------------------------------- + subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + implicit none + ! Arguments + character(len=*), intent(in) :: field_name + type (domain_type), intent(inout) :: domain + integer, intent(in) :: rk_step + real(kind=RKIND), dimension(:), intent(in) :: rk_timestep + logical, intent(in) :: config_monotonic + logical, intent(in) :: config_positive_definite + integer, intent(in) :: config_time_integration_order + logical, intent(in) :: config_split_dynamics_transport + procedure (halo_exchange_routine) :: exchange_halo_group - ! get the scalar values driving the regional boundary conditions - ! - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - call mpas_pool_get_dimension(state, 'index_qc', index_qc) - call mpas_pool_get_dimension(state, 'index_qr', index_qr) - call mpas_pool_get_dimension(state, 'index_qi', index_qi) - call mpas_pool_get_dimension(state, 'index_qs', index_qs) - call mpas_pool_get_dimension(state, 'index_qg', index_qg) - call mpas_pool_get_dimension(state, 'index_nr', index_nr) - call mpas_pool_get_dimension(state, 'index_ni', index_ni) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - if (index_qv > 0) then - scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qv', dt ) - end if - if (index_qc > 0) then - scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qc', dt ) - end if - if (index_qr > 0) then - scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qr', dt ) - end if - if (index_qi > 0) then - scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qi', dt ) - end if - if (index_qs > 0) then - scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qs', dt ) - end if - if (index_qg > 0) then - scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'qg', dt ) - end if - if (index_nr > 0) then - scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'nr', dt ) - end if - if (index_ni > 0) then - scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, domain % blocklist, nVertLevels, nCells, 'ni', dt ) - end if - -!$OMP PARALLEL DO - do thread=1,nThreads - call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & - cellThreadStart(thread), cellThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) - end do -!$OMP END PARALLEL DO + ! Local variables + integer :: thread - deallocate(scalars_driving) + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: halo_scratch - block => block % next - end do + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: nVertLevels + integer, pointer :: num_scalars + + integer, pointer :: nThreads + integer, dimension(:), pointer :: cellThreadStart + integer, dimension(:), pointer :: cellThreadEnd + integer, dimension(:), pointer :: cellSolveThreadStart + integer, dimension(:), pointer :: cellSolveThreadEnd + integer, dimension(:), pointer :: edgeThreadStart + integer, dimension(:), pointer :: edgeThreadEnd + + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call mpas_timer_start('atm_advance_scalars') + else + call mpas_timer_start('atm_advance_scalars_mono') + end if + + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'halo_scratch', halo_scratch) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + + allocate(scalar_old_arr(nVertLevels,nCells+1)) + scalar_old_arr(:,nCells+1) = 0.0_RKIND + allocate(scalar_new_arr(nVertLevels,nCells+1)) + scalar_new_arr(:,nCells+1) = 0.0_RKIND + allocate(s_max_arr(nVertLevels,nCells+1)) + s_max_arr(:,nCells+1) = 0.0_RKIND + allocate(s_min_arr(nVertLevels,nCells+1)) + s_min_arr(:,nCells+1) = 0.0_RKIND + allocate(flux_array(nVertLevels,nEdges+1)) + flux_array(:,nEdges+1) = 0.0_RKIND + allocate(wdtn_arr(nVertLevels+1,nCells+1)) + wdtn_arr(:,nCells+1) = 0.0_RKIND + if (config_split_dynamics_transport) then + allocate(rho_zz_int(nVertLevels,nCells+1)) + rho_zz_int(:,nCells+1) = 0.0_RKIND + else + allocate(rho_zz_int(1,1)) + end if + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) + horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND + else + allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) + flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND + allocate(flux_tmp_arr(nVertLevels,nEdges+1)) + flux_tmp_arr(:,nEdges+1) = 0.0_RKIND + end if - end if ! regional_MPAS addition + ! + ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses + ! the functionality of the advance_scalars routine; however, it is noticeably slower, + ! so we use the advance_scalars routine for the first two RK substeps. + ! + !$OMP PARALLEL DO + do thread=1,nThreads + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call atm_advance_scalars(field_name, tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + horiz_flux_array, rk_step, config_time_integration_order, & + advance_density=config_split_dynamics_transport) + else + call atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, halo_scratch, & + block % configs, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & + flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & + exchange_halo_group, & + advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) + end if + end do + !$OMP END PARALLEL DO + + deallocate(scalar_old_arr) + deallocate(scalar_new_arr) + deallocate(s_max_arr) + deallocate(s_min_arr) + deallocate(flux_array) + deallocate(wdtn_arr) + deallocate(rho_zz_int) + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + deallocate(horiz_flux_array) + else + deallocate(flux_upwind_tmp_arr) + deallocate(flux_tmp_arr) + end if - call summarize_timestep(domain) + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call mpas_timer_stop('atm_advance_scalars') + else + call mpas_timer_stop('atm_advance_scalars_mono') + end if - end subroutine atm_srk3 + end subroutine advance_scalars subroutine atm_rk_integration_setup( state, diag, & @@ -3099,47 +2738,45 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end subroutine atm_recover_large_step_variables_work - subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - horiz_flux_arr, rk_step, config_time_integration_order, advance_density, scalar_tend, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + ! routine atm_advance_scalars ! - ! Integrate scalar equations - explicit transport plus other tendencies + !> \brief Integrate scalar equations - explicit transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This routine is a wrapper for atm_advance_scalars_work and is primarily + !> intended to allow pointers to fields to be dereferenced through the call + !> to the work routine. ! - ! Wrapper for atm_advance_scalars_work() to de-reference pointers - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars(field_name, tend, state, diag, mesh, configs, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + horiz_flux_arr, rk_step, config_time_integration_order, advance_density) implicit none + ! Arguments + character(len=*), intent(in) :: field_name type (mpas_pool_type), intent(in) :: tend type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: num_scalars ! for allocating stack variables - integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step ! rk substep we are integrating integer, intent(in) :: config_time_integration_order ! time integration order real (kind=RKIND) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd logical, intent(in), optional :: advance_density - real (kind=RKIND), dimension(:,:,:), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int - integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 - real (kind=RKIND), dimension(:), pointer :: invAreaCell - real (kind=RKIND) :: rho_zz_new_inv - real (kind=RKIND) :: scalar_weight + ! Local variables + real (kind=RKIND), dimension(:), pointer :: invAreaCell real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend_save - real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two - real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg, rho_edge, zgrid, kdiff - real (kind=RKIND), dimension(:), pointer :: dvEdge, qv_init + real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg + real (kind=RKIND), dimension(:), pointer :: dvEdge integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:,:,:), intent(inout) :: horiz_flux_arr @@ -3147,16 +2784,18 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n integer, dimension(:), pointer :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension( num_scalars, nVertLevels + 1 ) :: wdtn - integer, pointer :: nCellsSolve, nEdges + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: num_scalars - real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw real (kind=RKIND), pointer :: coef_3rd_order integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition logical :: local_advance_density + if (present(advance_density)) then local_advance_density = advance_density else @@ -3165,144 +2804,120 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) - call mpas_pool_get_array(state, 'scalars', scalar_old, 1) - call mpas_pool_get_array(state, 'scalars', scalar_new, 2) + call mpas_pool_get_array(state, trim(field_name), scalar_old, 1) + call mpas_pool_get_array(state, trim(field_name), scalar_new, 2) call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(diag, 'kdiff', kdiff) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) - - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) ! regional_MPAS addition + call mpas_pool_get_array(tend, trim(field_name)//'_tend', scalar_tend_save) call mpas_pool_get_array(mesh, 'fzm', fnm) call mpas_pool_get_array(mesh, 'fzp', fnp) call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - if (local_advance_density) then - call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & + call atm_advance_scalars_work(nCells, num_scalars, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & + uhAvg, wwAvg, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & + scalar_tend_save, fnm, fnp, rdnw, & bdyMaskCell, bdyMaskEdge, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - local_advance_density, scalar_tend, rho_zz_int) - else - call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & - cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - bdyMaskCell, bdyMaskEdge, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & + nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, & + nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density) - end if end subroutine atm_advance_scalars - subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & - cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - bdyMaskCell, bdyMaskEdge, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - advance_density, scalar_tend, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - explicit transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. - ! - ! WCS 18 November 2014 - !----------------------- - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata - ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in state). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES NOT apply any positive definite or monotonic renormalizations. + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_work ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. + !> \brief Integrate scalar equations - explicit transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This transport routine is similar to the original atm_advance_scalars, except + !> it also advances (re-integrates) the density. This re-integration allows the scalar + !> transport routine to use a different timestep than the dry dynamics, and also makes + !> possible a spatial splitting of the scalar transport integration (and density + !> integration). The current integration is, however, not spatially split. + !> + !> WCS 18 November 2014 + !> + !> Input: s - current model state, + !> including tendencies from sources other than resolved transport. + !> grid - grid metadata + !> + !> input scalars in state are uncoupled (i.e. not mulitplied by density) + !> + !> Output: updated uncoupled scalars (scalars in state). + !> Note: scalar tendencies are also modified by this routine. + !> + !> This routine DOES NOT apply any positive definite or monotonic renormalizations. + !> + !> The transport scheme is from Skamarock and Gassmann MWR 2011. ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & + uhAvg, wwAvg, dvEdge, & + cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & + scalar_tend_save, fnm, fnp, rdnw, & + bdyMaskCell, bdyMaskEdge, & + nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, & + nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & + advance_density) - use mpas_atm_dimensions + use mpas_atm_dimensions, only : nVertLevels implicit none - integer, intent(in) :: num_scalars_dummy ! for allocating stack variables integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables + integer, intent(in) :: nEdges ! for allocating stack variables + integer, intent(in) :: num_scalars real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd integer, intent(in) :: rk_step, config_time_integration_order logical, intent(in) :: advance_density real (kind=RKIND), dimension(:,:,:), intent(in) :: scalar_old real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalar_new real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalar_tend_save - real (kind=RKIND), dimension(:,:,:), intent(in) :: deriv_two real (kind=RKIND), dimension(:,:), intent(in) :: rho_zz_old - real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_edge, zgrid, rho_zz_new, kdiff - real (kind=RKIND), dimension(:), intent(in) :: dvEdge, qv_init + real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_zz_new + real (kind=RKIND), dimension(:), intent(in) :: dvEdge integer, dimension(:,:), intent(in) :: cellsOnEdge integer, dimension(:,:), intent(in) :: advCellsForEdge, edgesOnCell integer, dimension(:), intent(in) :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw real (kind=RKIND), intent(in) :: coef_3rd_order real (kind=RKIND), dimension(num_scalars,nVertLevels,nEdges+1), intent(inout) :: horiz_flux_arr - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int real (kind=RKIND), dimension(:), intent(in) :: invAreaCell integer, dimension(:), intent(in) :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition - integer, intent(in) :: nCellsSolve, nEdges integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 real (kind=RKIND) :: rho_zz_new_inv @@ -3335,7 +2950,6 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old ! - ! horizontal flux divergence, accumulate in scalar_tend ! horiz_flux_arr stores the value of the scalar at the edge. @@ -3506,44 +3120,47 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm end subroutine atm_advance_scalars_work - subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & - flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_mono ! - ! Integrate scalar equations - transport plus other tendencies + !> \brief Integrate scalar equations - transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This routine is a wrapper for atm_advance_scalars_mono_work and is primarily + !> intended to allow pointers to fields to be dereferenced through the call + !> to the work routine. ! - ! wrapper routine for atm_advance_scalars_mono_work - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_atm_dimensions + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, halo_scratch, configs, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + scalar_old, scalar_new, s_max, s_min, wdtn, flux_arr, & + flux_upwind_tmp, flux_tmp, exchange_halo_group, advance_density, rho_zz_int) implicit none + ! Arguments + character(len=*), intent(in) :: field_name type (block_type), intent(inout), target :: block type (mpas_pool_type), intent(in) :: tend type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: halo_scratch type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nEdges ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn - real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout) :: scale_arr - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_arr - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_upwind_tmp, flux_tmp + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + real (kind=RKIND), dimension(:,:), intent(inout) :: scalar_old, scalar_new + real (kind=RKIND), dimension(:,:), intent(inout) :: s_max, s_min + real (kind=RKIND), dimension(:,:), intent(inout) :: wdtn + real (kind=RKIND), dimension(:,:), intent(inout) :: flux_arr + real (kind=RKIND), dimension(:,:), intent(inout) :: flux_upwind_tmp, flux_tmp + procedure (halo_exchange_routine) :: exchange_halo_group logical, intent(in), optional :: advance_density - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int + real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int + ! Local variables real (kind=RKIND), dimension(:,:,:), pointer :: scalar_tend real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg real (kind=RKIND), dimension(:), pointer :: dvEdge, invAreaCell @@ -3557,25 +3174,35 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition + integer, pointer :: nCells + integer, pointer :: nEdges integer, pointer :: nCellsSolve + integer, pointer :: num_scalars real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), pointer :: coef_3rd_order + type (field3DReal), pointer :: scale + real (kind=RKIND), dimension(:,:,:), pointer :: scale_arr + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) + call mpas_pool_get_array(tend, trim(field_name)//'_tend', scalar_tend) call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(state, 'scalars', scalars_old, 1) - call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + call mpas_pool_get_array(state, trim(field_name), scalars_old, 1) + call mpas_pool_get_array(state, trim(field_name), scalars_new, 2) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) @@ -3595,60 +3222,70 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! MPAS_regional addition call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) ! MPAS_regional addition - call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, nCellsSolve, num_scalars, uhAvg, wwAvg, scalar_tend, rho_zz_old, & + call mpas_pool_get_field(halo_scratch, 'scale', scale) + call mpas_allocate_scratch_field(scale) + call mpas_pool_get_array(halo_scratch, 'scale', scale_arr) + + call atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scalars, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & bdyMaskCell, bdyMaskEdge, & - advance_density, rho_zz_int) + exchange_halo_group, advance_density, rho_zz_int) + + call mpas_deallocate_scratch_field(scale) end subroutine atm_advance_scalars_mono - subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, nCellsSolve, num_scalars_dummy, uhAvg, wwAvg, scalar_tend, rho_zz_old, & + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_mono_work + ! + !> \brief Integrate scalar equations - transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This transport routine is similar to the original atm_advance_scalars_mono_work, + !> except it also advances (re-integrates) the density. This re-integration allows + !> the scalar transport routine to use a different timestep than the dry dynamics, + !> and also makes possible a spatial splitting of the scalar transport integration + !> (and density integration). The current integration is, however, not spatially split. + !> + !> WCS 18 November 2014 + !> + !> + !> Input: s - current model state, + !> including tendencies from sources other than resolved transport. + !> grid - grid metadata + !> + !> input scalars in state are uncoupled (i.e. not mulitplied by density) + !> + !> Output: updated uncoupled scalars (scalars in s_new). + !> Note: scalar tendencies are also modified by this routine. + !> + !> This routine DOES apply positive definite or monotonic renormalizations. + !> + !> The transport scheme is from Skamarock and Gassmann MWR 2011. + !> + !> The positive-definite or monotonic renormalization is from Zalesak JCP 1979 + !> as used in the RK3 scheme as described in Wang et al MWR 2009 + ! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, num_scalars, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & bdyMaskCell, bdyMaskEdge, & - advance_density, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars_mono_work, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. - ! - ! WCS 18 November 2014 - !----------------------- - ! - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata - ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in s_new). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES apply positive definite or monotonic renormalizations. - ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. - ! - ! The positive-definite or monotonic renormalization is from Zalesak JCP 1979 - ! as used in the RK3 scheme as described in Wang et al MWR 2009 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + exchange_halo_group, advance_density, rho_zz_int) - use mpas_atm_dimensions + use mpas_atm_dimensions, only : nVertLevels implicit none @@ -3656,10 +3293,11 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve type (mpas_pool_type), intent(inout) :: state integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: nEdges ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables + integer, intent(in) :: num_scalars real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + procedure (halo_exchange_routine) :: exchange_halo_group logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int @@ -3686,19 +3324,17 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn - real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout), target :: scale_arr + real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout) :: scale_arr real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_arr real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_upwind_tmp, flux_tmp type (field3DReal), pointer :: scalars_old_field - type (field3DReal), pointer :: tempField - type (field3DReal), target :: tempFieldTarget - - integer, parameter :: SCALE_IN = 1, SCALE_OUT = 2 - integer, intent(in) :: nCellsSolve, num_scalars_dummy + integer, intent(in) :: nCellsSolve +#ifdef DEBUG_TRANSPORT integer :: icellmax, kmax +#endif real (kind=RKIND), dimension(nVertLevels), intent(in) :: fnm, fnp, rdnw integer, dimension(:), intent(in) :: nEdgesOnCell @@ -3707,7 +3343,10 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels) :: flux_upwind_arr real (kind=RKIND) :: flux3, flux4, flux_upwind - real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3, scmin,scmax + real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 +#ifdef DEBUG_TRANSPORT + real (kind=RKIND) :: scmin,scmax +#endif real (kind=RKIND) :: scale_factor logical :: local_advance_density @@ -3754,7 +3393,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve !$OMP BARRIER !$OMP MASTER - call mpas_dmpar_exch_halo_field(scalars_old_field) + call exchange_halo_group(block % domain, 'dynamics:scalars_old') !$OMP END MASTER !$OMP BARRIER @@ -3769,11 +3408,8 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end if ! begin with update of density - do iCell=cellStart,cellEnd - rho_zz_int(:,iCell) = 0.0 - end do -!$OMP BARRIER do iCell=cellSolveStart,cellSolveEnd + rho_zz_int(:,iCell) = 0.0 do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) @@ -4081,21 +3717,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! !$OMP BARRIER !$OMP MASTER - tempField => tempFieldTarget - - tempField % block => block - tempField % dimSizes(1) = nVertLevels - tempField % dimSizes(2) = 2 - tempField % dimSizes(3) = nCells - tempField % sendList => block % parinfo % cellsToSend - tempField % recvList => block % parinfo % cellsToRecv - tempField % copyList => block % parinfo % cellsToCopy - tempField % prev => null() - tempField % next => null() - tempField % isActive = .true. - - tempField % array => scale_arr - call mpas_dmpar_exch_halo_field(tempField, (/ 1 /)) + call exchange_halo_group(block % domain, 'dynamics:scale') !$OMP END MASTER !$OMP BARRIER @@ -4236,7 +3858,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, ! Dummy arguments ! type (mpas_pool_type), intent(inout) :: tend - type (mpas_pool_type), intent(inout) :: tend_physics + type (mpas_pool_type), pointer :: tend_physics type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh @@ -4266,9 +3888,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: rr_save - - real (kind=RKIND), dimension(:,:), pointer :: tend_rtheta_adv ! needed for Tiedtke convection scheme - real (kind=RKIND), dimension(:,:), pointer :: rthdynten ! needed for Grell-Freitas convection scheme + real (kind=RKIND), dimension(:,:), pointer :: rthdynten => null() real (kind=RKIND), dimension(:,:,:), pointer :: scalars @@ -4309,7 +3929,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_mpas_cam_coef logical, pointer :: config_rayleigh_damp_u real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days - integer, pointer :: config_number_rayleigh_damp_u_levels + integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels logical :: inactive_rthdynten @@ -4332,6 +3952,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_config(configs, 'config_rayleigh_damp_u', config_rayleigh_damp_u) call mpas_pool_get_config(configs, 'config_rayleigh_damp_u_timescale_days', config_rayleigh_damp_u_timescale_days) call mpas_pool_get_config(configs, 'config_number_rayleigh_damp_u_levels', config_number_rayleigh_damp_u_levels) + call mpas_pool_get_config(configs, 'config_number_cam_damping_levels', config_number_cam_damping_levels) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) call mpas_pool_get_array(state, 'u', u, 2) @@ -4361,8 +3982,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'h_divergence', h_divergence) call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'tend_rtheta_adv', tend_rtheta_adv) - call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + if (associated(tend_physics)) then + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) + end if call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) @@ -4466,8 +4088,9 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & config_mpas_cam_coef, & - config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, config_number_rayleigh_damp_u_levels, & - tend_rtheta_adv, rthdynten, & + config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & + config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & + rthdynten, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -4493,8 +4116,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & config_mpas_cam_coef, & - config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, config_number_rayleigh_damp_u_levels, & - tend_rtheta_adv, rthdynten, & + config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & + config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & + rthdynten, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -4617,9 +4241,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm logical, intent(in) :: config_rayleigh_damp_u real (kind=RKIND), intent(in) :: config_rayleigh_damp_u_timescale_days - integer, intent(in) :: config_number_rayleigh_damp_u_levels + integer, intent(in) :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rtheta_adv real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rthdynten integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd @@ -4645,7 +4268,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 real (kind=RKIND) :: u_diffusion - real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp, rayleigh_coef_inverse + real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp, rayleigh_coef_inverse, visc2cam real (kind=RKIND), dimension( nVertLevels ) :: rayleigh_damp_coef @@ -4659,7 +4282,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm flux4(q_im2, q_im1, q_i, q_ip1, ua) + & coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 - prandtl_inv = 1.0_RKIND / prandtl invDt = 1.0_RKIND / dt inv_r_earth = 1.0_RKIND / r_earth @@ -4709,12 +4331,14 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm do iCell = cellStart,cellEnd ! - ! 2nd-order filter for top absorbing layer as in CAM-SE : WCS 10 May 2017 + ! 2nd-order filter for top absorbing layer similar to that in CAM-SE : WCS 10 May 2017, modified 7 April 2023 ! From MPAS-CAM V4.0 code, with addition to config-specified coefficient (V4.0_coef = 0.2; SE_coef = 1.0) ! - kdiff(nVertLevels-2,iCell) = max(kdiff(nVertLevels-2,iCell), 2.0833*config_len_disp*config_mpas_cam_coef) - kdiff(nVertLevels-1,iCell) = max(kdiff(nVertLevels-1,iCell),2.0*2.0833*config_len_disp*config_mpas_cam_coef) - kdiff(nVertLevels ,iCell) = max(kdiff(nVertLevels ,iCell),4.0*2.0833*config_len_disp*config_mpas_cam_coef) + do k = nVertLevels-config_number_cam_damping_levels + 1, nVertLevels + visc2cam = 4.0*2.0833*config_len_disp*config_mpas_cam_coef + visc2cam = visc2cam*(1.0-real(nVertLevels-k)/real(config_number_cam_damping_levels)) + kdiff(k ,iCell) = max(kdiff(nVertLevels ,iCell),visc2cam) + end do end do end if @@ -5347,8 +4971,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !DIR$ IVDEP do k=1,nVertLevels tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) - tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme - rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme + rthdynten(k,iCell) = (tend_theta(k,iCell)-tend_rho(k,iCell)*theta_m(k,iCell))/rho_zz(k,iCell) tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) end do end do @@ -6201,7 +5824,7 @@ end subroutine atm_bdy_adjust_dynamics_speczone_tend !------------------------------------------------------------------------- - subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVertLevels, dt, & + subroutine atm_bdy_adjust_dynamics_relaxzone_tend( config, tend, state, diag, mesh, nVertLevels, dt, & ru_driving_values, rt_driving_values, rho_driving_values, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd ) @@ -6214,6 +5837,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVer ! ! WCS Fall 2016 + type (mpas_pool_type), intent(in) :: config type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(inout) :: tend type (mpas_pool_type), intent(in) :: diag @@ -6235,6 +5859,7 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVer real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, r_dc, r_dv, invArea + real (kind=RKIND), pointer :: divdamp_coef real (kind=RKIND), dimension(nVertLevels) :: divergence1, divergence2, vorticity1, vorticity2 integer :: iCell, iEdge, i, k, cell1, cell2, iEdge_vort, iEdge_div integer :: vertex1, vertex2, iVertex @@ -6269,6 +5894,8 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVer call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) call mpas_pool_get_array(mesh, 'nEdgesOnCell',nEdgesOnCell) call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + + call mpas_pool_get_config(config, 'config_relax_zone_divdamp_coef', divdamp_coef) ! First, Rayleigh damping terms for ru, rtheta_m and rho_zz @@ -6380,8 +6007,9 @@ subroutine atm_bdy_adjust_dynamics_relaxzone_tend( tend, state, diag, mesh, nVer ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity ! do k=1,nVertLevels - tend_ru(k,iEdge) = tend_ru(k,iEdge) + laplacian_filter_coef * ( ( divergence2(k) - divergence1(k) ) * r_dc & - -( vorticity2(k) - vorticity1(k) ) * r_dv ) + tend_ru(k,iEdge) = tend_ru(k,iEdge) + laplacian_filter_coef & + * (divdamp_coef * (divergence2(k) - divergence1(k)) * r_dc & + -(vorticity2(k) - vorticity1(k)) * r_dv) end do end if ! end test for relaxation-zone edge @@ -6686,8 +6314,6 @@ subroutine summarize_timestep(domain) logical, pointer :: config_print_detailed_minmax_vel logical, pointer :: config_print_global_minmax_sca - type (block_type), pointer :: block - integer :: iCell, k, iEdge, iScalar integer, pointer :: num_scalars, nCellsSolve, nEdgesSolve, nVertLevels @@ -6714,273 +6340,262 @@ subroutine summarize_timestep(domain) real (kind=RKIND), dimension(:,:), pointer :: u, v, uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, scalars_1, scalars_2 - call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_vel', config_print_global_minmax_vel) - call mpas_pool_get_config(domain % blocklist % configs, 'config_print_detailed_minmax_vel', config_print_detailed_minmax_vel) - call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) + call mpas_pool_get_config(block % configs, 'config_print_global_minmax_vel', config_print_global_minmax_vel) + call mpas_pool_get_config(block % configs, 'config_print_detailed_minmax_vel', config_print_detailed_minmax_vel) + call mpas_pool_get_config(block % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) if (config_print_detailed_minmax_vel) then call mpas_log_write('') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(mesh, 'indexToCellID', indexToCellID) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'lonCell', lonCell) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) - call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) - call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - - scalar_min = 1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - if (w(k,iCell) < scalar_min) then - scalar_min = w(k,iCell) - indexMax = iCell - kMax = k - latMax = latCell(iCell) - lonMax = lonCell(iCell) - end if - end do - end do - localVals(1) = scalar_min - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) - global_scalar_min = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(mesh, 'indexToCellID', indexToCellID) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + + scalar_min = 1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + if (w(k,iCell) < scalar_min) then + scalar_min = w(k,iCell) + indexMax = iCell + kMax = k + latMax = latCell(iCell) + lonMax = lonCell(iCell) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) - - scalar_max = -1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - if (w(k,iCell) > scalar_max) then - scalar_max = w(k,iCell) - indexMax = iCell - kMax = k - latMax = latCell(iCell) - lonMax = lonCell(iCell) - end if - end do - end do - localVals(1) = scalar_max - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) - global_scalar_max = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_min + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) + global_scalar_min = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + + scalar_max = -1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + if (w(k,iCell) > scalar_max) then + scalar_max = w(k,iCell) + indexMax = iCell + kMax = k + latMax = latCell(iCell) + lonMax = lonCell(iCell) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - - scalar_min = 1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - if (u(k,iEdge) < scalar_min) then - scalar_min = u(k,iEdge) - indexMax = iEdge - kMax = k - latMax = latEdge(iEdge) - lonMax = lonEdge(iEdge) - end if - end do - end do - localVals(1) = scalar_min - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) - global_scalar_min = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_max + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) + global_scalar_max = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + + scalar_min = 1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + if (u(k,iEdge) < scalar_min) then + scalar_min = u(k,iEdge) + indexMax = iEdge + kMax = k + latMax = latEdge(iEdge) + lonMax = lonEdge(iEdge) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) - - scalar_max = -1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - if (u(k,iEdge) > scalar_max) then - scalar_max = u(k,iEdge) - indexMax = iEdge - kMax = k - latMax = latEdge(iEdge) - lonMax = lonEdge(iEdge) - end if - end do - end do - localVals(1) = scalar_max - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) - global_scalar_max = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_min + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) + global_scalar_min = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + + scalar_max = -1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + if (u(k,iEdge) > scalar_max) then + scalar_max = u(k,iEdge) + indexMax = iEdge + kMax = k + latMax = latEdge(iEdge) + lonMax = lonEdge(iEdge) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - - scalar_max = -1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - spd = sqrt(u(k,iEdge)*u(k,iEdge) + v(k,iEdge)*v(k,iEdge)) - if (spd > scalar_max) then - scalar_max = spd - indexMax = iEdge - kMax = k - latMax = latEdge(iEdge) - lonMax = lonEdge(iEdge) - end if - end do - end do - localVals(1) = scalar_max - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) - global_scalar_max = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_max + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) + global_scalar_max = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + + scalar_max = -1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + spd = sqrt(u(k,iEdge)*u(k,iEdge) + v(k,iEdge)*v(k,iEdge)) + if (spd > scalar_max) then + scalar_max = spd + indexMax = iEdge + kMax = k + latMax = latEdge(iEdge) + lonMax = lonEdge(iEdge) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - - ! - ! Check for NaNs - ! - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - if (ieee_is_nan(w(k,iCell))) then - call mpas_log_write('NaN detected in ''w'' field.', messageType=MPAS_LOG_CRIT) - end if - end do - end do + end do + end do + localVals(1) = scalar_max + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) + global_scalar_max = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - if (ieee_is_nan(u(k,iEdge))) then - call mpas_log_write('NaN detected in ''u'' field.', messageType=MPAS_LOG_CRIT) - end if - end do - end do + ! + ! Check for NaNs + ! + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + if (ieee_is_nan(w(k,iCell))) then + call mpas_log_write('NaN detected in ''w'' field.', messageType=MPAS_LOG_CRIT) + end if + end do + end do - block => block % next + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + if (ieee_is_nan(u(k,iEdge))) then + call mpas_log_write('NaN detected in ''u'' field.', messageType=MPAS_LOG_CRIT) + end if + end do end do else if (config_print_global_minmax_vel) then call mpas_log_write('') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - - scalar_min = 0.0 - scalar_max = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - scalar_min = min(scalar_min, w(k,iCell)) - scalar_max = max(scalar_max, w(k,iCell)) - end do - end do - call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max w $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - scalar_min = 0.0 - scalar_max = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - scalar_min = min(scalar_min, u(k,iEdge)) - scalar_max = max(scalar_max, u(k,iEdge)) - end do - end do - call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max u $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + scalar_min = 0.0 + scalar_max = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, w(k,iCell)) + scalar_max = max(scalar_max, w(k,iCell)) + end do + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + call mpas_log_write('global min, max w $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) - block => block % next + scalar_min = 0.0 + scalar_max = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, u(k,iEdge)) + scalar_max = max(scalar_max, u(k,iEdge)) end do + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + call mpas_log_write('global min, max u $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) end if if (config_print_global_minmax_sca) then @@ -6988,30 +6603,24 @@ subroutine summarize_timestep(domain) call mpas_log_write('') end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - - call mpas_pool_get_array(state, 'scalars', scalars, 2) - call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - do iScalar = 1, num_scalars - scalar_min = 0.0 - scalar_max = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - scalar_min = min(scalar_min, scalars(iScalar,k,iCell)) - scalar_max = max(scalar_max, scalars(iScalar,k,iCell)) - end do - end do - call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write(' global min, max scalar $i $r $r', intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) + do iScalar = 1, num_scalars + scalar_min = 0.0 + scalar_max = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, scalars(iScalar,k,iCell)) + scalar_max = max(scalar_max, scalars(iScalar,k,iCell)) end do - - block => block % next + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + call mpas_log_write(' global min, max scalar $i $r $r', intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) end do end if diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index 5b56d653a8..065e74c547 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -11,8 +11,31 @@ module atm_core use mpas_pool_routines use mpas_dmpar use mpas_log, only : mpas_log_write, mpas_log_info + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + subroutine halo_exchange_routine(domain, halo_group, ierr) + + use mpas_derived_types, only : domain_type + + type (domain_type), intent(inout) :: domain + character(len=*), intent(in) :: halo_group + integer, intent(out), optional :: ierr + + end subroutine halo_exchange_routine + end interface type (MPAS_Clock_type), pointer :: clock + procedure (halo_exchange_routine), pointer :: exchange_halo_group + character(len=StrKIND), pointer :: config_halo_exch_method + + private :: exchange_halo_group + private :: atm_build_halo_groups, atm_destroy_halo_groups + private :: config_halo_exch_method contains @@ -26,6 +49,8 @@ function atm_core_init(domain, startTimeStamp) result(ierr) use mpas_atm_dimensions, only : mpas_atm_set_dims use mpas_atm_diagnostics_manager, only : mpas_atm_diag_setup use mpas_atm_threading, only : mpas_atm_threading_init + use atm_time_integration, only : mpas_atm_dynamics_init + use mpas_timer, only : mpas_timer_start, mpas_timer_stop implicit none @@ -36,7 +61,6 @@ function atm_core_init(domain, startTimeStamp) result(ierr) real (kind=RKIND), pointer :: dt type (block_type), pointer :: block - integer :: i logical, pointer :: config_do_restart type (mpas_pool_type), pointer :: state @@ -47,7 +71,13 @@ function atm_core_init(domain, startTimeStamp) result(ierr) character (len=StrKIND), pointer :: initial_time1, initial_time2 type (MPAS_Time_Type) :: startTime + real (kind=RKIND), pointer :: nominalMinDc + real (kind=RKIND), pointer :: config_len_disp + integer, pointer :: nVertLevels, maxEdges, maxEdges2, num_scalars + character (len=ShortStrKIND) :: init_stream_name + real (kind=R8KIND) :: input_start_time, input_stop_time + ierr = 0 @@ -77,11 +107,18 @@ function atm_core_init(domain, startTimeStamp) result(ierr) clock => domain % clock mpas_log_info => domain % logInfo + ! + ! Build halo exchange groups and set method for exchanging halos in a group + ! + call atm_build_halo_groups(domain, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to build halo exchange groups.', messageType=MPAS_LOG_ERR) + return + end if call mpas_pool_get_config(domain % blocklist % configs, 'config_do_restart', config_do_restart) call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', dt) - ! ! If this is a restart run, read the restart stream, else read the input ! stream. @@ -89,18 +126,81 @@ function atm_core_init(domain, startTimeStamp) result(ierr) ! input alarms for both input and restart before reading any remaining ! input streams. ! + call mpas_timer_start('read_ICs') if (config_do_restart) then - call MPAS_stream_mgr_read(domain % streamManager, streamID='restart', ierr=ierr) + init_stream_name = 'restart' else - call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=ierr) + init_stream_name = 'input' end if + call mpas_log_write('Reading initial state from '''//trim(init_stream_name)//''' stream') + + call mpas_dmpar_get_time(input_start_time) + call MPAS_stream_mgr_read(domain % streamManager, streamID=trim(init_stream_name), ierr=ierr) + call mpas_dmpar_get_time(input_stop_time) + call mpas_timer_stop('read_ICs') + if (ierr /= MPAS_STREAM_MGR_NOERR) then call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Error reading initial conditions', messageType=MPAS_LOG_ERR) call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) end if + + call mpas_log_write(' Timing for read of '''//trim(init_stream_name)//''' stream: $r s', & + realArgs=(/real(input_stop_time - input_start_time, kind=RKIND)/)) + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='input', direction=MPAS_STREAM_INPUT, ierr=ierr) call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_INPUT, ierr=ierr) + call mpas_log_write(' ----- done reading initial state -----') + + + ! + ! Determine horizontal length scale used by horizontal diffusion and 3-d divergence damping + ! + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + nullify(nominalMinDc) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + + nullify(config_len_disp) + call mpas_pool_get_config(domain % blocklist % configs, 'config_len_disp', config_len_disp) + + call mpas_log_write('') + + ! + ! If config_len_disp was specified as a valid value, use that + ! + if (config_len_disp > 0.0_RKIND) then + call mpas_log_write('Setting nominalMinDc to $r based on namelist option config_len_disp', realArgs=[config_len_disp]) + + ! + ! But if nominalMinDc was available in the input file and is different, print a warning + ! + if (nominalMinDc > 0.0_RKIND .and. abs(nominalMinDc - config_len_disp) > 1.0e-6_RKIND * config_len_disp) then + call mpas_log_write('nominalMinDc was read from input file as a positive value ($r) that differs', & + realArgs=[nominalMinDc], messageType=MPAS_LOG_WARN) + call mpas_log_write('from the specified config_len_disp value ($r)', & + realArgs=[config_len_disp], messageType=MPAS_LOG_WARN) + end if + + nominalMinDc = config_len_disp + + ! + ! Otherwise, try to use nominalMinDc + ! + else + if (nominalMinDc > 0.0_RKIND) then + call mpas_log_write('Setting config_len_disp to $r based on nominalMinDc value in input file', realArgs=[nominalMinDc]) + config_len_disp = nominalMinDc + else + call mpas_log_write('Both config_len_disp and nominalMinDc are <= 0.0.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please either specify config_len_disp in the &nhyd_model namelist group,', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('or use an input file that provides a valid value for the nominalMinDc variable.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + end if + ! ! Read all other inputs @@ -139,10 +239,7 @@ function atm_core_init(domain, startTimeStamp) result(ierr) startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) call mpas_get_time(startTime, dateTimeString=startTimeStamp) - - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'u', u_field, 1) - call mpas_dmpar_exch_halo_field(u_field) + call exchange_halo_group(domain, 'initialization:u') ! @@ -175,19 +272,16 @@ function atm_core_init(domain, startTimeStamp) result(ierr) block => block % next end do - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) - call mpas_dmpar_exch_halo_field(pv_edge_field) - - call mpas_pool_get_field(diag, 'ru', ru_field) - call mpas_dmpar_exch_halo_field(ru_field) - - call mpas_pool_get_field(diag, 'rw', rw_field) - call mpas_dmpar_exch_halo_field(rw_field) + call exchange_halo_group(domain, 'initialization:pv_edge,ru,rw') call mpas_atm_diag_setup(domain % streamManager, domain % blocklist % configs, & domain % blocklist % structs, domain % clock, domain % dminfo) + ! + ! Prepare the dynamics for integration + ! + call mpas_atm_dynamics_init(domain) + end function atm_core_init @@ -201,8 +295,8 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) type (mpas_pool_type), intent(inout) :: configs integer, intent(out) :: ierr - type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime - type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + type (MPAS_Time_Type) :: startTime, stopTime + type (MPAS_TimeInterval_type) :: runDuration, timeStep integer :: local_err real (kind=RKIND), pointer :: config_dt character (len=StrKIND), pointer :: config_start_time @@ -210,6 +304,7 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) character (len=StrKIND), pointer :: config_run_duration character (len=StrKIND), pointer :: config_stop_time character (len=StrKIND) :: startTimeStamp + integer :: iounit ierr = 0 @@ -221,9 +316,11 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) if(trim(config_start_time) == 'file') then - open(22,file=trim(config_restart_timestamp_name),form='formatted',status='old') - read(22,*) startTimeStamp - close(22) + call mpas_new_unit(iounit) + open(iounit,file=trim(config_restart_timestamp_name),form='formatted',status='old') + read(iounit,*) startTimeStamp + close(iounit) + call mpas_release_unit(iounit) else startTimeStamp = config_start_time end if @@ -288,7 +385,6 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructX, uReconstructY, uReconstructZ, uReconstructZonal, uReconstructMeridional real (kind=RKIND), dimension(:), pointer :: meshScalingDel2, meshScalingDel4 - real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge real (kind=RKIND), dimension(:), pointer :: areaCell, invAreaCell real (kind=RKIND), dimension(:), pointer :: dvEdge, invDvEdge real (kind=RKIND), dimension(:), pointer :: dcEdge, invDcEdge @@ -480,7 +576,7 @@ function atm_core_run(domain) result(ierr) use mpas_kind_types use mpas_stream_manager use mpas_derived_types, only : MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_INPUT, MPAS_STREAM_INPUT_OUTPUT - use mpas_timer + use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atm_boundaries, only : mpas_atm_update_bdy_tend use mpas_atm_diagnostics_manager, only : mpas_atm_diag_update, mpas_atm_diag_compute, mpas_atm_diag_reset @@ -498,15 +594,13 @@ function atm_core_run(domain) result(ierr) character(len=StrKIND) :: timeStamp character (len=StrKIND), pointer :: config_restart_timestamp_name integer :: itimestep + integer :: iounit integer :: stream_dir character(len=StrKIND) :: input_stream, read_time type (mpas_pool_type), pointer :: state, diag, mesh, diag_physics, tend, tend_physics - ! For high-frequency diagnostics output - character (len=StrKIND) :: tempfilename - ! For timing information real (kind=R8KIND) :: integ_start_time, integ_stop_time real (kind=R8KIND) :: diag_start_time, diag_stop_time @@ -539,22 +633,28 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call atm_compute_output_diagnostics(state, 1, diag, mesh) block_ptr => block_ptr % next end do end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() call mpas_atm_diag_update() call mpas_atm_diag_compute() + call mpas_timer_stop('diagnostic_fields') call mpas_dmpar_get_time(diag_stop_time) + call mpas_timer_start('stream_output') call mpas_dmpar_get_time(output_start_time) call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_dmpar_get_time(output_stop_time) + call mpas_timer_stop('stream_output') if (ierr /= MPAS_STREAM_MGR_NOERR .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_FILE .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_REC) then @@ -567,7 +667,9 @@ function atm_core_run(domain) result(ierr) call mpas_log_write('Timing for stream output: $r s', realArgs=(/real(output_stop_time - output_start_time, kind=RKIND)/)) end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() + call mpas_timer_stop('diagnostic_fields') call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) @@ -575,7 +677,9 @@ function atm_core_run(domain) result(ierr) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) @@ -639,10 +743,12 @@ function atm_core_run(domain) result(ierr) if (stream_dir == MPAS_STREAM_INPUT .or. stream_dir == MPAS_STREAM_INPUT_OUTPUT) then if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID=input_stream, & direction=MPAS_STREAM_INPUT, ierr=ierr)) then + call mpas_timer_start('stream_input') call mpas_dmpar_get_time(input_start_time) call MPAS_stream_mgr_read(domain % streamManager, streamID=input_stream, whence=MPAS_STREAM_LATEST_BEFORE, & actualWhen=read_time, ierr=ierr) call mpas_dmpar_get_time(input_stop_time) + call mpas_timer_stop('stream_input') if (ierr /= MPAS_STREAM_MGR_NOERR) then call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Error reading input stream '//trim(input_stream), messageType=MPAS_LOG_ERR) @@ -687,23 +793,29 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block_ptr % structs, 'tend_physics', tend_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'tend', tend) - call mpas_pool_get_subpool(block_ptr % structs, 'tend_physics', tend_physics) call atm_compute_output_diagnostics(state, 1, diag, mesh) block_ptr => block_ptr % next end do end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_update() call mpas_atm_diag_compute() + call mpas_timer_stop('diagnostic_fields') call mpas_dmpar_get_time(diag_stop_time) + call mpas_timer_start('stream_output') call mpas_dmpar_get_time(output_start_time) call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_dmpar_get_time(output_stop_time) + call mpas_timer_stop('stream_output') if (ierr /= MPAS_STREAM_MGR_NOERR .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_FILE .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_REC) then @@ -722,9 +834,10 @@ function atm_core_run(domain) result(ierr) block_ptr => domain % blocklist do while (associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) - call atm_reset_diagnostics(diag, diag_physics) +#endif + call atm_reset_diagnostics(diag_physics) block_ptr => block_ptr % next end do @@ -735,13 +848,17 @@ function atm_core_run(domain) result(ierr) ! write the restart_timestamp file if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then if (domain % dminfo % my_proc_id == 0) then - open(22,file=trim(config_restart_timestamp_name),form='formatted',status='replace') - write(22,*) trim(timeStamp) - close(22) + call mpas_new_unit(iounit) + open(iounit,file=trim(config_restart_timestamp_name),form='formatted',status='replace') + write(iounit,*) trim(timeStamp) + close(iounit) + call mpas_release_unit(iounit) end if end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() + call mpas_timer_stop('diagnostic_fields') call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) @@ -802,27 +919,27 @@ subroutine atm_compute_output_diagnostics(state, time_lev, diag, mesh) end subroutine atm_compute_output_diagnostics - subroutine atm_reset_diagnostics(diag, diag_physics) + subroutine atm_reset_diagnostics(diag_physics) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! reset some diagnostics after output ! - ! Input: diag - contains dynamics diagnostic fields - ! daig_physics - contains physics diagnostic fields + ! Input: diag_physics - contains physics diagnostic fields ! ! Output: whatever diagnostics need resetting after output !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(inout) :: diag_physics + type (mpas_pool_type), pointer :: diag_physics real (kind=RKIND), dimension(:), pointer :: refl10cm_1km_max +#ifdef DO_PHYSICS call mpas_pool_get_array(diag_physics, 'refl10cm_1km_max', refl10cm_1km_max) if(associated(refl10cm_1km_max)) then refl10cm_1km_max(:) = 0. endif +#endif end subroutine atm_reset_diagnostics @@ -870,7 +987,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) endif #endif - call atm_timestep(domain, dt, currTime, itimestep) + call atm_timestep(domain, dt, currTime, itimestep, exchange_halo_group) end subroutine atm_do_timestep @@ -881,6 +998,7 @@ function atm_core_finalize(domain) result(ierr) use mpas_timekeeping use mpas_atm_diagnostics_manager, only : mpas_atm_diag_cleanup use mpas_atm_threading, only : mpas_atm_threading_finalize + use atm_time_integration, only : mpas_atm_dynamics_finalize #ifdef DO_PHYSICS use mpas_atmphys_finalize @@ -897,6 +1015,11 @@ function atm_core_finalize(domain) result(ierr) clock => domain % clock mpas_log_info => domain % logInfo + ! + ! Finalize the dynamics + ! + call mpas_atm_dynamics_finalize(domain) + call mpas_atm_diag_cleanup() call mpas_destroy_clock(clock, ierr) @@ -911,6 +1034,14 @@ function atm_core_finalize(domain) result(ierr) end do #endif + ! + ! Destroy halo exchange groups + ! + call atm_destroy_halo_groups(domain, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to destroy halo exchange groups.', messageType=MPAS_LOG_ERR) + end if + ! ! Finalize threading ! @@ -1307,8 +1438,11 @@ end subroutine atm_couple_coef_3rd_order !----------------------------------------------------------------------- subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) +#ifdef DO_PHYSICS use mpas_atmphys_control, only : physics_compatibility_check +#endif use mpas_atm_boundaries, only : mpas_atm_bdy_checks + use atm_time_integration, only : mpas_atm_dynamics_checks implicit none @@ -1321,11 +1455,13 @@ subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) ierr = 0 +#ifdef DO_PHYSICS ! ! Physics specific checks found in physics/mpas_atmphys_control.F ! call physics_compatibility_check(dminfo, blockList, streamManager, local_ierr) ierr = ierr + local_ierr +#endif ! ! Checks for limited-area simulations @@ -1333,8 +1469,419 @@ subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) call mpas_atm_bdy_checks(dminfo, blockList, streamManager, local_ierr) ierr = ierr + local_ierr + ! + ! Checks for dynamics options + ! + call mpas_atm_dynamics_checks(dminfo, blockList, streamManager, local_ierr) + ierr = ierr + local_ierr + end subroutine mpas_atm_run_compatibility + !----------------------------------------------------------------------- + ! routine atm_build_halo_groups + ! + !> \brief Builds halo exchange groups used throughout atmosphere core + !> \author Michael Duda + !> \date 5 June 2023 + !> \details + !> This routine builds the halo exchange groups that are used throughout + !> the atmosphere core, and it sets a function pointer, + !> exchange_halo_group, to the routine that may be used to exchange the + !> halos for all fields in a named group. + !> + !> A value of 0 is returned if halo exchange groups have been + !> successfully set up and a non-zero value is returned otherwise. + ! + !----------------------------------------------------------------------- + subroutine atm_build_halo_groups(domain, ierr) + + use mpas_halo, only : mpas_halo_init, mpas_halo_exch_group_create, mpas_halo_exch_group_add_field, & + mpas_halo_exch_group_complete, mpas_halo_exch_group_full_halo_exch + + type (domain_type), intent(inout) :: domain + integer, intent(inout) :: ierr + + ! + ! Determine from the namelist option config_halo_exch_method which halo exchange method to employ + ! + call mpas_pool_get_config(domain % blocklist % configs, 'config_halo_exch_method', config_halo_exch_method) + + if (trim(config_halo_exch_method) == 'mpas_dmpar') then + call mpas_log_write('') + call mpas_log_write('*** Using ''mpas_dmpar'' routines for exchanging halos') + call mpas_log_write('') + + ! + ! Set up halo exchange groups used during atmosphere core initialization + ! + call mpas_dmpar_exch_group_create(domain, 'initialization:u') + call mpas_dmpar_exch_group_add_field(domain, 'initialization:u', 'u', timeLevel=1, haloLayers=(/1,2,3/)) + + call mpas_dmpar_exch_group_create(domain, 'initialization:pv_edge,ru,rw') + call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'pv_edge', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'ru', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_dmpar_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'rw', timeLevel=1, haloLayers=(/1,2/)) + + ! + ! Set up halo exchange groups used by dynamics + ! + call mpas_dmpar_exch_group_create(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'theta_m', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'scalars', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + + !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) + !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /)) + call mpas_dmpar_exch_group_create(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rw_p', & + timeLevel=1, haloLayers=(/1/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'ru_p', & + timeLevel=1, haloLayers=(/2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rho_pp', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rtheta_pp', & + timeLevel=1, haloLayers=(/2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'w', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'pv_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'rho_edge', & + timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'w', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'pv_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'rho_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'scalars', & + timeLevel=2, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'theta_m', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + + + call mpas_dmpar_exch_group_create(domain, 'dynamics:exner') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:exner', 'exner', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:tend_u') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:tend_u', 'tend_u', timeLevel=1, haloLayers=(/1/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:rho_pp') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rho_pp', 'rho_pp', timeLevel=1, haloLayers=(/1/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:rtheta_pp') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:rtheta_pp', 'rtheta_pp', timeLevel=1, haloLayers=(/1/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:u_123') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:u_123', 'u', timeLevel=2, haloLayers=(/1,2,3/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:u_3') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:u_3', 'u', timeLevel=2, haloLayers=(/3/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:scalars') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scalars', 'scalars', timeLevel=2, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:scalars_old') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scalars_old', 'scalars', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:w') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:w', 'w', timeLevel=2, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'dynamics:scale') + call mpas_dmpar_exch_group_add_field(domain, 'dynamics:scale', 'scale', timeLevel=1, haloLayers=(/1,2/)) + +#ifdef DO_PHYSICS + ! + ! Set up halo exchange groups used by physics + ! + call mpas_dmpar_exch_group_create(domain, 'physics:blten') + call mpas_dmpar_exch_group_add_field(domain, 'physics:blten', 'rublten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'physics:blten', 'rvblten', timeLevel=1, haloLayers=(/1,2/)) + + call mpas_dmpar_exch_group_create(domain, 'physics:cuten') + call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_dmpar_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) +#endif + + ! + ! Set routine to exchange a halo group + ! + exchange_halo_group => mpas_dmpar_exch_group_full_halo_exch + + else if (trim(config_halo_exch_method) == 'mpas_halo') then + + call mpas_log_write('') + call mpas_log_write('*** Using ''mpas_halo'' routines for exchanging halos') + call mpas_log_write('') + + call mpas_halo_init(domain) + + ! + ! Set up halo exchange groups used during atmosphere core initialization + ! + call mpas_halo_exch_group_create(domain, 'initialization:u') + call mpas_halo_exch_group_add_field(domain, 'initialization:u', 'u', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_complete(domain, 'initialization:u') + + call mpas_halo_exch_group_create(domain, 'initialization:pv_edge,ru,rw') + call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'pv_edge', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'ru', timeLevel=1, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_add_field(domain, 'initialization:pv_edge,ru,rw', 'rw', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'initialization:pv_edge,ru,rw') + + ! + ! Set up halo exchange groups used by dynamics + ! + call mpas_halo_exch_group_create(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'theta_m', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'scalars', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + + call mpas_halo_exch_group_create(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rw_p', & + timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'ru_p', & + timeLevel=1, haloLayers=(/2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rho_pp', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp', 'rtheta_pp', & + timeLevel=1, haloLayers=(/2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + + call mpas_halo_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'w', timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'pv_edge', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge', 'rho_edge', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:w,pv_edge,rho_edge') + + call mpas_halo_exch_group_create(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'w', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'pv_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'rho_edge', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:w,pv_edge,rho_edge,scalars', 'scalars', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + + call mpas_halo_exch_group_create(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'theta_m', & + timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'pressure_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'dynamics:theta_m,pressure_p,rtheta_p', 'rtheta_p', & + timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + + + call mpas_halo_exch_group_create(domain, 'dynamics:exner') + call mpas_halo_exch_group_add_field(domain, 'dynamics:exner', 'exner', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:exner') + + call mpas_halo_exch_group_create(domain, 'dynamics:tend_u') + call mpas_halo_exch_group_add_field(domain, 'dynamics:tend_u', 'tend_u', timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:tend_u') + + call mpas_halo_exch_group_create(domain, 'dynamics:rho_pp') + call mpas_halo_exch_group_add_field(domain, 'dynamics:rho_pp', 'rho_pp', timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:rho_pp') + + call mpas_halo_exch_group_create(domain, 'dynamics:rtheta_pp') + call mpas_halo_exch_group_add_field(domain, 'dynamics:rtheta_pp', 'rtheta_pp', timeLevel=1, haloLayers=(/1/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:rtheta_pp') + + call mpas_halo_exch_group_create(domain, 'dynamics:u_123') + call mpas_halo_exch_group_add_field(domain, 'dynamics:u_123', 'u', timeLevel=2, haloLayers=(/1,2,3/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:u_123') + + call mpas_halo_exch_group_create(domain, 'dynamics:u_3') + call mpas_halo_exch_group_add_field(domain, 'dynamics:u_3', 'u', timeLevel=2, haloLayers=(/3/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:u_3') + + call mpas_halo_exch_group_create(domain, 'dynamics:scalars') + call mpas_halo_exch_group_add_field(domain, 'dynamics:scalars', 'scalars', timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:scalars') + + call mpas_halo_exch_group_create(domain, 'dynamics:scalars_old') + call mpas_halo_exch_group_add_field(domain, 'dynamics:scalars_old', 'scalars', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:scalars_old') + + call mpas_halo_exch_group_create(domain, 'dynamics:w') + call mpas_halo_exch_group_add_field(domain, 'dynamics:w', 'w', timeLevel=2, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:w') + + call mpas_halo_exch_group_create(domain, 'dynamics:scale') + call mpas_halo_exch_group_add_field(domain, 'dynamics:scale', 'scale', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'dynamics:scale') + +#ifdef DO_PHYSICS + ! + ! Set up halo exchange groups used by physics + ! + call mpas_halo_exch_group_create(domain, 'physics:blten') + call mpas_halo_exch_group_add_field(domain, 'physics:blten', 'rublten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'physics:blten', 'rvblten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'physics:blten') + + call mpas_halo_exch_group_create(domain, 'physics:cuten') + call mpas_halo_exch_group_add_field(domain, 'physics:cuten', 'rucuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_add_field(domain, 'physics:cuten', 'rvcuten', timeLevel=1, haloLayers=(/1,2/)) + call mpas_halo_exch_group_complete(domain, 'physics:cuten') +#endif + + ! + ! Set routine to exchange a halo group + ! + exchange_halo_group => mpas_halo_exch_group_full_halo_exch + + else + + ! + ! Invalid method for exchanging halos + ! + ierr = 1 + call mpas_log_write('Invalid method for exchanging halos specified by ''config_halo_exch_method'': ' // & + trim(config_halo_exch_method), messageType=MPAS_LOG_ERR) + return + + end if + + ierr = 0 + + end subroutine atm_build_halo_groups + + + !----------------------------------------------------------------------- + ! routine atm_destroy_halo_groups + ! + !> \brief Destroys halo exchange groups used throughout atmosphere core + !> \author Michael Duda + !> \date 5 June 2023 + !> \details + !> This routine destroys the halo exchange groups that are used throughout + !> the atmosphere core, freeing up any resources that were used by these + !> halo exchange groups. + !> + !> A value of 0 is returned if halo exchange groups have been + !> successfully destroyed and a non-zero value is returned otherwise. + ! + !----------------------------------------------------------------------- + subroutine atm_destroy_halo_groups(domain, ierr) + + use mpas_halo, only : mpas_halo_exch_group_destroy, mpas_halo_finalize + + type (domain_type), intent(inout) :: domain + integer, intent(inout) :: ierr + + + if (trim(config_halo_exch_method) == 'mpas_dmpar') then + ! + ! Destroy halo exchange groups used only during initialization + ! + call mpas_dmpar_exch_group_destroy(domain, 'initialization:u') + call mpas_dmpar_exch_group_destroy(domain, 'initialization:pv_edge,ru,rw') + + ! + ! Destroy halo exchange groups used by dynamics + ! + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:exner') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:tend_u') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rho_pp') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:rtheta_pp') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:u_123') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:u_3') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scalars') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scalars_old') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:w') + call mpas_dmpar_exch_group_destroy(domain, 'dynamics:scale') + +#ifdef DO_PHYSICS + ! + ! Destroy halo exchange groups used by physics + ! + call mpas_dmpar_exch_group_destroy(domain, 'physics:blten') + call mpas_dmpar_exch_group_destroy(domain, 'physics:cuten') +#endif + + else if (trim(config_halo_exch_method) == 'mpas_halo') then + + ! + ! Destroy halo exchange groups used only during initialization + ! + call mpas_halo_exch_group_destroy(domain, 'initialization:u') + call mpas_halo_exch_group_destroy(domain, 'initialization:pv_edge,ru,rw') + + ! + ! Destroy halo exchange groups used by dynamics + ! + call mpas_halo_exch_group_destroy(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') + call mpas_halo_exch_group_destroy(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') + call mpas_halo_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge') + call mpas_halo_exch_group_destroy(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + call mpas_halo_exch_group_destroy(domain, 'dynamics:theta_m,pressure_p,rtheta_p') + + call mpas_halo_exch_group_destroy(domain, 'dynamics:exner') + call mpas_halo_exch_group_destroy(domain, 'dynamics:tend_u') + call mpas_halo_exch_group_destroy(domain, 'dynamics:rho_pp') + call mpas_halo_exch_group_destroy(domain, 'dynamics:rtheta_pp') + call mpas_halo_exch_group_destroy(domain, 'dynamics:u_123') + call mpas_halo_exch_group_destroy(domain, 'dynamics:u_3') + call mpas_halo_exch_group_destroy(domain, 'dynamics:scalars') + call mpas_halo_exch_group_destroy(domain, 'dynamics:scalars_old') + call mpas_halo_exch_group_destroy(domain, 'dynamics:w') + call mpas_halo_exch_group_destroy(domain, 'dynamics:scale') + +#ifdef DO_PHYSICS + ! + ! Destroy halo exchange groups used by physics + ! + call mpas_halo_exch_group_destroy(domain, 'physics:blten') + call mpas_halo_exch_group_destroy(domain, 'physics:cuten') +#endif + + call mpas_halo_finalize(domain) + + else + + ! + ! Invalid method for exchanging halos - an error should have already occurred in atm_build_halo_groups() + ! + ierr = 1 + return + + end if + + ierr = 0 + + end subroutine atm_destroy_halo_groups + end module atm_core diff --git a/src/core_atmosphere/mpas_atm_core_interface.F b/src/core_atmosphere/mpas_atm_core_interface.F index 8c3858b165..5e319ef26b 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -236,15 +236,19 @@ end function atm_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function atm_setup_log(logInfo, domain) result(iErr)!{{{ + function atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open +#ifdef MPAS_OPENMP + use mpas_threading, only : mpas_threading_get_num_threads +#endif implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -253,7 +257,7 @@ function atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -265,10 +269,53 @@ function atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = ior(iErr, local_err) call mpas_log_write('') + call mpas_log_write('MPAS-Atmosphere Version '//trim(domain % core % modelVersion)) + call mpas_log_write('') + call mpas_log_write('') + call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) + call mpas_log_write('') + call mpas_log_write('Compile-time options:') + call mpas_log_write(' Build target: '//trim(domain % core % build_target)) + call mpas_log_write(' OpenMP support: ' // & +#ifdef MPAS_OPENMP + 'yes') +#else + 'no') +#endif + call mpas_log_write(' OpenACC support: ' // & +#ifdef MPAS_OPENACC + 'yes') +#else + 'no') +#endif + call mpas_log_write(' Default real precision: ' // & #ifdef SINGLE_PRECISION - call mpas_log_write('Using default single-precision reals') + 'single') +#else + 'double') +#endif + call mpas_log_write(' Compiler flags: ' // & +#ifdef MPAS_DEBUG + 'debug') #else - call mpas_log_write('Using default double-precision reals') + 'optimize') +#endif + call mpas_log_write(' I/O layer: ' // & +#ifdef MPAS_PIO_SUPPORT +#ifdef USE_PIO2 + 'PIO 2.x') +#else + 'PIO 1.x') +#endif +#else + 'SMIOL') +#endif + call mpas_log_write('') + + call mpas_log_write('Run-time settings:') + call mpas_log_write(' MPI task count: $i', intArgs=[domain % dminfo % nprocs]) +#ifdef MPAS_OPENMP + call mpas_log_write(' OpenMP max threads: $i', intArgs=[mpas_threading_get_max_threads()]) #endif call mpas_log_write('') @@ -374,19 +421,176 @@ end function atm_setup_decompositions function atm_setup_block(block) result(ierr) use mpas_derived_types, only : block_type + use mpas_pool_routines, only : mpas_pool_get_config + use mpas_log, only : mpas_log_write implicit none type (block_type), pointer :: block integer :: ierr + integer, pointer :: cam_pcnst + integer :: err_level + ierr = 0 call atm_generate_structs(block, block % structs, block % dimensions, block % packages) + ! + ! When MPAS-A is operating as a dycore in CAM, the scalars/scalars_tend var_arrays are + ! allocated by the call to atm_allocate_scalars, below. The CAM-MPAS interface layer + ! should have added a config, cam_pcnst, to the configs pool to indicate how many scalars + ! are to be allocated. + ! + nullify(cam_pcnst) + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(block % domain % configs, 'cam_pcnst', cam_pcnst) + call mpas_pool_set_error_level(err_level) + if (associated(cam_pcnst)) then + call mpas_log_write('') + call mpas_log_write('** Config ''cam_pcnst'' is defined with a value of $i', intArgs=[cam_pcnst]) + call mpas_log_write(' Scalars will be allocated separately from Registry-defined variables') + call mpas_log_write('') + ierr = atm_allocate_scalars(block, cam_pcnst) + end if + end function atm_setup_block + !*********************************************************************** + ! + ! function atm_allocate_scalars + ! + !> \brief Allocate scalars and scalars_tend var_arrays + !> \author Michael G. Duda + !> \date 20 May 2020 + !> \details + !> When MPAS-A is operating as a dycore for CAM, the scalars and + !> scalars_tend var_arrays are allocated separately from other Registry- + !> defined variables, since the set of scalars to be handled by the dycore + !> is not known until runtime. This routine allocates these var_arrays, + !> but it does not define which constituent is at which position in + !> var_arrays; this is defined later in the CAM-MPAS interface layer. + ! + !----------------------------------------------------------------------- + function atm_allocate_scalars(block, num_scalars) result(ierr) + + use mpas_derived_types, only : block_type + + use mpas_derived_types, only : mpas_pool_type, field3dReal, MPAS_LOG_ERR + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_add_dimension, mpas_pool_add_field + use mpas_log, only : mpas_log_write + + implicit none + + ! Arguments + type (block_type), pointer :: block + integer, intent(in) :: num_scalars + + ! Return value + integer :: ierr + + ! Local variables + integer :: i, j, timeLevs + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tendPool + type (field3dReal), dimension(:), pointer :: scalarsField + + + ierr = 0 + + ! + ! Allocate scalars var_array + ! + nullify(statePool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + if (.not. associated(statePool)) then + call mpas_log_write('No pool named ''state'' was found in atm_allocate_scalars', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + timeLevs = 2 + + call mpas_pool_add_dimension(statePool, 'num_scalars', num_scalars) + + allocate(scalarsField(timeLevs)) + + do i = 1, timeLevs + scalarsField(i) % block => block + scalarsField(i) % fieldName = 'scalars' + scalarsField(i) % dimNames(1) = 'num_scalars' + scalarsField(i) % dimNames(2) = 'nVertLevels' + scalarsField(i) % dimNames(3) = 'nCells' + scalarsField(i) % defaultValue = 0.0 + scalarsField(i) % missingValue = -1.0 + scalarsField(i) % isDecomposed = .true. + scalarsField(i) % hasTimeDimension = .true. + scalarsField(i) % isActive = .true. + scalarsField(i) % isVarArray = .true. + scalarsField(i) % isPersistent = .true. + + allocate(scalarsField(i) % constituentNames(num_scalars)) + + allocate(scalarsField(i) % attLists(num_scalars)) + do j = 1, num_scalars + allocate(scalarsField(i) % attLists(j) % attList) + end do + + end do + + call mpas_pool_add_field(statePool, 'scalars', scalarsField) + call mpas_pool_add_field(block % allFields, 'scalars', scalarsField) + + + ! + ! Allocate scalars_tend var_array + ! + nullify(tendPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + + if (.not. associated(tendPool)) then + call mpas_log_write('No pool named ''tend'' was found in atm_allocate_scalars', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + timeLevs = 1 + + call mpas_pool_add_dimension(tendPool, 'num_scalars_tend', num_scalars) + + allocate(scalarsField(timeLevs)) + + do i = 1, timeLevs + scalarsField(i) % block => block + scalarsField(i) % fieldName = 'scalars_tend' + scalarsField(i) % dimNames(1) = 'num_scalars_tend' + scalarsField(i) % dimNames(2) = 'nVertLevels' + scalarsField(i) % dimNames(3) = 'nCells' + scalarsField(i) % defaultValue = 0.0 + scalarsField(i) % missingValue = -1.0 + scalarsField(i) % isDecomposed = .true. + scalarsField(i) % hasTimeDimension = .true. + scalarsField(i) % isActive = .true. + scalarsField(i) % isVarArray = .true. + scalarsField(i) % isPersistent = .true. + + allocate(scalarsField(i) % constituentNames(num_scalars)) + + allocate(scalarsField(i) % attLists(num_scalars)) + do j = 1, num_scalars + allocate(scalarsField(i) % attLists(j) % attList) + end do + + end do + + call mpas_pool_add_field(tendPool, 'scalars_tend', scalarsField) + call mpas_pool_add_field(block % allFields, 'scalars_tend', scalarsField) + + end function atm_allocate_scalars + #include "setup_immutable_streams.inc" #include "block_dimension_routines.inc" diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index faf6b98d40..22e7e22b1e 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,15 +4,16 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif -all: lookup_tables core_physics_init core_physics_wrf core_physics +all: lookup_tables core_physics_init core_physics_mmm core_physics_wrf core_physics dummy: echo "****** compiling physics ******" OBJS_init = \ - mpas_atmphys_constants.o \ - mpas_atmphys_date_time.o \ - mpas_atmphys_functions.o \ + ccpp_kinds.o \ + mpas_atmphys_constants.o \ + mpas_atmphys_date_time.o \ + mpas_atmphys_functions.o \ mpas_atmphys_utilities.o OBJS = \ @@ -48,7 +49,10 @@ OBJS = \ lookup_tables: ./checkout_data_files.sh -core_physics_wrf: core_physics_init +core_physics_mmm: core_physics_init + (cd physics_mmm; $(MAKE) all) + +core_physics_wrf: core_physics_init core_physics_mmm (cd physics_wrf; $(MAKE) all COREDEF="$(COREDEF)") core_physics_init: $(OBJS_init) @@ -194,6 +198,7 @@ mpas_atmphys_update.o: \ clean: $(RM) *.o *.mod *.f90 libphys.a ( cd physics_wrf; $(MAKE) clean ) + ( cd physics_mmm; $(MAKE) clean ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i @@ -202,7 +207,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/ccpp_kinds.F b/src/core_atmosphere/physics/ccpp_kinds.F new file mode 100644 index 0000000000..af633a84ee --- /dev/null +++ b/src/core_atmosphere/physics/ccpp_kinds.F @@ -0,0 +1,4 @@ +module ccpp_kinds + use mpas_kind_types,only: kind_phys => RKIND + contains +end module ccpp_kinds diff --git a/src/core_atmosphere/physics/checkout_data_files.sh b/src/core_atmosphere/physics/checkout_data_files.sh index c0b7b92c45..55043fee70 100755 --- a/src/core_atmosphere/physics/checkout_data_files.sh +++ b/src/core_atmosphere/physics/checkout_data_files.sh @@ -23,7 +23,7 @@ ################################################################################ -mpas_vers="7.0" +mpas_vers="8.0" github_org="MPAS-Dev" # GitHub organization where the MPAS-Data repository is found. # For physics development, it can be helpful for a developer diff --git a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F index e2c8aabcf8..48cb5a4413 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F @@ -16,6 +16,7 @@ module mpas_atmphys_camrad_init use mpas_dmpar use mpas_kind_types use mpas_pool_routines + use mpas_io_units use mpas_atmphys_constants,only: cp,degrad,ep_2,gravity,R_d,R_v,stbolt use mpas_atmphys_utilities @@ -298,7 +299,6 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) real(r8):: tdbl integer:: i,istat,cam_abs_unit - logical:: opened character(len=StrKIND):: errmess integer:: i_te,i_rh @@ -330,16 +330,9 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) fwc2 = 4.5 ! See eq(33) and eq(34) in R&D fc1 = 2.6 ! See eq(34) R&D - istat = -999 if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened) then - cam_abs_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(cam_abs_unit, unformatted = .true.) + if(cam_abs_unit < 0) & call physics_error_fatal('module_ra_cam: radaeinit: Cannot find unused '//& 'fortran unit to read in lookup table.') endif @@ -375,7 +368,10 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) DM_BCAST_MACRO(ln_ah2ow) DM_BCAST_MACRO(ln_eh2ow) - if(dminfo % my_proc_id == IO_NODE) close(cam_abs_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(cam_abs_unit) + call mpas_release_unit(cam_abs_unit) + end if ! Set up table of H2O saturation vapor pressures for use in calculation effective path RH. ! Need separate table from table in wv_saturation because: @@ -595,7 +591,6 @@ subroutine aer_optics_initialize(dminfo) real(r8):: dummy(nspint) integer:: i,istat,cam_aer_unit - logical:: opened character(len=StrKIND):: errmess !----------------------------------------------------------------------------------------------------------------- @@ -603,16 +598,9 @@ subroutine aer_optics_initialize(dminfo) !call mpas_log_write('--- enter subroutine aer_optics_initialize:') !READ AEROSOL OPTICS DATA: - istat = -999 if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened) then - cam_aer_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(cam_aer_unit, unformatted = .true.) + if(cam_aer_unit < 0) & call physics_error_fatal('module_ra_cam: aer_optics_initialize: Cannot find unused '//& 'fortran unit to read in lookup table.') endif @@ -685,7 +673,10 @@ subroutine aer_optics_initialize(dminfo) DM_BCAST_MACRO(wvolc) DM_BCAST_MACRO(gvolc) - if(dminfo % my_proc_id == IO_NODE) close(cam_aer_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(cam_aer_unit) + call mpas_release_unit(cam_aer_unit) + end if ! map OPAC aerosol species onto CAM aerosol species ! CAM name OPAC name @@ -764,9 +755,7 @@ subroutine oznini(mesh,atm_input) real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: - integer,parameter:: pin_unit = 27 - integer,parameter:: lat_unit = 28 - integer,parameter:: oz_unit = 29 + integer:: read_unit integer,parameter:: open_ok = 0 integer:: i,i1,i2,istat,k,j,m @@ -789,30 +778,35 @@ subroutine oznini(mesh,atm_input) call mpas_pool_get_array(atm_input,'ozmixm',ozmixm) !-- read in ozone pressure data: - open(pin_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) + call mpas_new_unit(read_unit) + if(read_unit < 0) & + call physics_error_fatal('module_ra_cam: oznini: Cannot find unused '//& + 'fortran unit to read in lookup table.') + + open(read_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & 'failure opening OZONE_PLEV.TBL') do k = 1,levsiz - read(pin_unit,*) pin(k) + read(read_unit,*) pin(k) pin(k) = pin(k)*100. ! call mpas_log_write('$r', realArgs=(/pin(k)/)) enddo - close(pin_unit) + close(read_unit) !-- read in ozone lat data: - open(lat_unit, file='OZONE_LAT.TBL',action='READ',status='OLD',iostat=istat) + open(read_unit, file='OZONE_LAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & 'failure opening OZONE_LAT.TBL') do j = 1, latsiz - read(lat_unit,*) lat_ozone(j) + read(read_unit,*) lat_ozone(j) ! call mpas_log_write('$i $r', intArgs=(/j/), realArgs=(/lat_ozone(j)/)) enddo - close(lat_unit) + close(read_unit) !-- read in ozone data: - open(oz_unit,file='OZONE_DAT.TBL',action='READ',status='OLD',iostat=istat) + open(read_unit,file='OZONE_DAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & 'failure opening OZONE_DAT.TBL') @@ -822,12 +816,14 @@ subroutine oznini(mesh,atm_input) do j=1,latsiz ! latsiz=64 do k=1,levsiz ! levsiz=59 do i=1,lonsiz ! lonsiz=1 - read(oz_unit,*) ozmixin(i,k,j,m) + read(read_unit,*) ozmixin(i,k,j,m) enddo enddo enddo enddo - close(oz_unit) + close(read_unit) + + call mpas_release_unit(read_unit) !INTERPOLATION OF INPUT OZONE DATA TO MPAS GRID: !call mpas_log_write('max latCell= $r', realArgs=(/maxval(latCell)/degrad/)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_constants.F b/src/core_atmosphere/physics/mpas_atmphys_constants.F index 12433a699b..65270f78f8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_constants.F +++ b/src/core_atmosphere/physics/mpas_atmphys_constants.F @@ -75,6 +75,14 @@ module mpas_atmphys_constants real(kind=RKIND),parameter:: epsilon = 1.e-15 real(kind=RKIND),parameter:: psat = 610.78 + real(kind=RKIND),parameter:: re_qc_bg = 2.49e-6 ! effective radius of cloud water for background (m) + real(kind=RKIND),parameter:: re_qi_bg = 4.99e-6 ! effective radius of cloud ice for background (m) + real(kind=RKIND),parameter:: re_qs_bg = 9.99e-6 ! effective radius of snow for background (m) + + real(kind=RKIND),parameter:: re_qc_max = 50.e-6 ! maximum effective radius of cloud water (m) + real(kind=RKIND),parameter:: re_qi_max = 125.e-6 ! maximum effective radius of cloud ice (m) + real(kind=RKIND),parameter:: re_qs_max = 999.e-6 ! maximum radius of snow (m) + !constants specific to long- and short-wave radiation codes: !real(kind=RKIND),parameter:: solcon_0 = 1365. !solar constant [W/m2] real(kind=RKIND),parameter:: solcon_0 = 1370. !solar constant [W/m2] diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 9b7a08c5e0..b37a512a2e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -72,6 +72,10 @@ module mpas_atmphys_control ! * modified logic in subroutine physics_tables_init so that the Thompson microphysics tables are read in each ! MPI task. ! Laura D. Fowler (laura@ucar.edu) / 2016-12-30. +! * added the option sf_monin_obukhov_rev to run the revised surface layer scheme with the YSU PBL scheme. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. +! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. contains @@ -127,7 +131,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_sw_scheme) == 'suite') config_radt_sw_scheme = 'rrtmg_sw' if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov' - if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'noah' + if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' else if (trim(config_physics_suite) == 'convection_permitting') then @@ -139,7 +143,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_sw_scheme) == 'suite') config_radt_sw_scheme = 'rrtmg_sw' if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_mynn' - if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'noah' + if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' else if (trim(config_physics_suite) == 'none') then @@ -255,9 +259,10 @@ subroutine physics_namelist_check(configs) endif !surface-layer scheme: - if(.not. (config_sfclayer_scheme .eq. 'off' .or. & - config_sfclayer_scheme .eq. 'sf_mynn' .or. & - config_sfclayer_scheme .eq. 'sf_monin_obukhov')) then + if(.not. (config_sfclayer_scheme .eq. 'off' .or. & + config_sfclayer_scheme .eq. 'sf_mynn' .or. & + config_sfclayer_scheme .eq. 'sf_monin_obukhov' .or. & + config_sfclayer_scheme .eq. 'sf_monin_obukhov_rev')) then write(mpas_err_message,'(A,A10)') 'illegal value for surface layer scheme: ', & trim(config_sfclayer_scheme) @@ -266,7 +271,12 @@ subroutine physics_namelist_check(configs) if(config_pbl_scheme == 'bl_mynn') then config_sfclayer_scheme = 'sf_mynn' elseif(config_pbl_scheme == 'bl_ysu') then - config_sfclayer_scheme = 'sf_monin_obukhov' + if(config_sfclayer_scheme /= 'sf_monin_obukhov' .and. & + config_sfclayer_scheme /= 'sf_monin_obukhov_rev') then + write(mpas_err_message,'(A,A10)') 'wrong choice for surface layer scheme with YSU PBL: ', & + trim(config_sfclayer_scheme) + call physics_error_fatal(mpas_err_message) + endif endif endif @@ -278,7 +288,7 @@ subroutine physics_namelist_check(configs) 'set config_sfclayer_scheme different than off') elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & - config_lsm_scheme .eq. 'noah')) then + config_lsm_scheme .eq. 'sf_noah')) then write(mpas_err_message,'(A,A10)') 'illegal value for land surface scheme: ', & trim(config_lsm_scheme) @@ -349,7 +359,7 @@ subroutine physics_registry_init(mesh,configs,sfc_input) lsm_select: select case(trim(config_lsm_scheme)) - case("noah") + case("sf_noah") !initialize the thickness of the soil layers for the Noah scheme: do iCell = 1, nCells dzs(1,iCell) = 0.10_RKIND @@ -448,6 +458,9 @@ subroutine physics_compatibility_check(dminfo, blockList, streamManager, ierr) real (kind=RKIND) :: maxvar2d_local, maxvar2d_global real (kind=RKIND), dimension(:), pointer :: var2d integer, pointer :: nCellsSolve + integer, pointer :: iswater_lu + integer, pointer, dimension(:) :: ivgtyp + integer :: all_water, iall_water character (len=StrKIND), pointer :: gwdo_scheme type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool @@ -473,7 +486,22 @@ subroutine physics_compatibility_check(dminfo, blockList, streamManager, ierr) call mpas_dmpar_max_real(dminfo, maxvar2d_local, maxvar2d_global) - if (maxvar2d_global <= 0.0_RKIND) then + ! + ! The GWDO check below can fail on regional simulations that are completely above + ! water. So, check to see if the simulation is completely above water and do not + ! throw the error if it is. + ! + call mpas_pool_get_array(sfc_inputPool, 'iswater', iswater_lu) + call mpas_pool_get_array(sfc_inputPool, 'ivgtyp', ivgtyp) + if (all(ivgtyp(1:nCellsSolve) == iswater_lu)) then + all_water = 1 ! All water + else + all_water = 0 ! Land present + end if + + call mpas_dmpar_min_int(dminfo, all_water, iall_water) + + if (maxvar2d_global <= 0.0_RKIND .and. iall_water /= 1) then call mpas_log_write('*******************************************************************************', & messageType=MPAS_LOG_ERR) call mpas_log_write('The GWDO scheme requires valid var2d, con, oa{1,2,3,4}, and ol{1,2,3,4} fields,', & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index 58f9bfaefc..3310f1c801 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -19,7 +19,7 @@ module mpas_atmphys_driver_convection use module_cu_gf use module_cu_kfeta use module_cu_tiedtke - use module_cu_ntiedtke + use module_cu_ntiedtke,only: cu_ntiedtke_driver implicit none private @@ -435,10 +435,18 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ real(kind=RKIND):: cudt real(kind=RKIND):: cudtacttime +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_convection:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_gfconv_closure_deep',gfconv_closure_deep) call mpas_pool_get_config(configs,'config_gfconv_closure_shallow',gfconv_closure_shallow) call mpas_pool_get_config(configs,'config_len_disp' ,len_disp ) @@ -569,8 +577,8 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ call mpas_timer_stop('Tiedtke') case("cu_ntiedtke") - call mpas_timer_start('New_Tiedtke') - call cu_ntiedtke( & + call mpas_timer_start('cu_ntiedtke') + call cu_ntiedtke_driver( & pcps = pres_hyd_p , p8w = pres2_hyd_p , & t3d = t_p , dz8w = dz_p , & dt = dt_dyn , itimestep = initflag , & @@ -588,12 +596,16 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ f_qs = f_qs , rthcuten = rthcuten_p , & rqvcuten = rqvcuten_p , rqccuten = rqccuten_p , & rqicuten = rqicuten_p , rucuten = rucuten_p , & - rvcuten = rvcuten_p , & + rvcuten = rvcuten_p , grav = gravity , & + xlf = xlf , xls = xls , & + xlv = xlv , rd = R_d , & + rv = R_v , cp = cp , & + errmsg = errmsg , errflg = errflg , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kds , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('New_Tiedtke') + call mpas_timer_stop('cu_ntiedtke') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index 29ba7ef0c7..d783cc831b 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -60,6 +60,8 @@ module mpas_atmphys_driver_gwdo ! * modified the call to subroutine gwdo following the update of module_gwdo.F to that ! of WRF version 4.0.2. ! Laura D. Fowler (laura@ucar.edu) / 2019-01-30. +! * added the flags errmsg and errflg in the call to subroutine gwdo for compliance with the CCPP framework. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. contains @@ -285,10 +287,18 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic integer:: i,iCell,iEdge real(kind=RKIND),dimension(:),allocatable:: dx_max +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_gwdo:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_gwdo_scheme',gwdo_scheme) !copy MPAS arrays to local arrays: @@ -301,7 +311,7 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic call gwdo ( & p3d = pres_hydd_p , p3di = pres2_hydd_p , pi3d = pi_p , & u3d = u_p , v3d = v_p , t3d = t_p , & - qv3d = qv_p , z = z_p , rublten = rublten_p , & + qv3d = qv_p , z = zmid_p , rublten = rublten_p , & rvblten = rvblten_p , dtaux3d = dtaux3d_p , dtauy3d = dtauy3d_p , & dusfcg = dusfcg_p , dvsfcg = dvsfcg_p , kpbl2d = kpbl_p , & itimestep = itimestep , dt = dt_pbl , dx = dx_p , & @@ -311,6 +321,7 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic oa2d2 = oa2_p , oa2d3 = oa3_p , oa2d4 = oa4_p , & ol2d1 = ol1_p , ol2d2 = ol2_p , ol2d3 = ol3_p , & ol2d4 = ol4_p , sina = sina_p , cosa = cosa_p , & + errmsg = errmsg , errflg = errflg , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F index 6b431b3cc5..5231645a29 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -93,6 +93,12 @@ module mpas_atmphys_driver_lsm ! * added call to seaice_noah to include the parameterization of seaice for the updated Noah land surface ! scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-19. +! * the initialization of the variable albsi_p is switched from sfc_albedo_seaice (which is originally +! initialized to albbck to seaice_albedo_default. Note that albsi_p is not used if seaice_albedo_opt = 0. +! Laura D. Fowler (laura@ucar.edu) / 2020-05-10. +! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. + ! ! DOCUMENTATION: @@ -162,6 +168,8 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(snowc_p) ) allocate(snowc_p(ims:ime,jms:jme) ) if(.not.allocated(snowh_p) ) allocate(snowh_p(ims:ime,jms:jme) ) if(.not.allocated(sr_p) ) allocate(sr_p(ims:ime,jms:jme) ) + if(.not.allocated(swddir_p) ) allocate(swddir_p(ims:ime,jms:jme) ) + if(.not.allocated(swddif_p) ) allocate(swddif_p(ims:ime,jms:jme) ) if(.not.allocated(swdown_p) ) allocate(swdown_p(ims:ime,jms:jme) ) if(.not.allocated(tmn_p) ) allocate(tmn_p(ims:ime,jms:jme) ) if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) @@ -181,9 +189,6 @@ subroutine allocate_lsm(config_frac_seaice) if(.not.allocated(frc_urb_p) ) allocate(frc_urb_p(ims:ime,jms:jme) ) if(.not.allocated(ust_urb_p) ) allocate(ust_urb_p(ims:ime,jms:jme) ) if(.not.allocated(utype_urb_p) ) allocate(utype_urb_p(ims:ime,jms:jme) ) - if(.not.allocated(infxsrt_p) ) allocate(infxsrt_p(ims:ime,jms:jme) ) - if(.not.allocated(sfcheadrt_p) ) allocate(sfcheadrt_p(ims:ime,jms:jme) ) - if(.not.allocated(soldrain_p) ) allocate(soldrain_p(ims:ime,jms:jme) ) if(config_frac_seaice) then if(.not.allocated(tsk_sea) ) allocate(tsk_sea(ims:ime,jms:jme) ) @@ -250,6 +255,8 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(snowc_p) ) deallocate(snowc_p ) if(allocated(snowh_p) ) deallocate(snowh_p ) if(allocated(sr_p) ) deallocate(sr_p ) + if(allocated(swddir_p) ) deallocate(swddir_p ) + if(allocated(swddif_p) ) deallocate(swddif_p ) if(allocated(swdown_p) ) deallocate(swdown_p ) if(allocated(tmn_p) ) deallocate(tmn_p ) if(allocated(tsk_p) ) deallocate(tsk_p ) @@ -269,9 +276,6 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(frc_urb_p) ) deallocate(frc_urb_p ) if(allocated(ust_urb_p) ) deallocate(ust_urb_p ) if(allocated(utype_urb_p) ) deallocate(utype_urb_p ) - if(allocated(infxsrt_p) ) deallocate(infxsrt_p ) - if(allocated(sfcheadrt_p) ) deallocate(sfcheadrt_p ) - if(allocated(soldrain_p) ) deallocate(soldrain_p ) if(config_frac_seaice) then if(allocated(chs_sea) ) deallocate(chs_sea ) @@ -313,8 +317,8 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) real(kind=RKIND),dimension(:),pointer :: acsnom,acsnow,canwat,chs,chs2,chklowq,cpm,cqs2,glw, & grdflx,gsw,hfx,lai,lh,noahres,potevp,qfx,qgh,qsfc, & - br,sfc_albedo,sfc_albedo_seaice,sfc_emibck,sfc_emiss, & - sfcrunoff,smstav,smstot,snotime,snopcx,sr,udrunoff, & + br,sfc_albedo,sfc_emibck,sfc_emiss,sfcrunoff,smstav, & + smstot,snotime,snopcx,sr,swddif,swddir,udrunoff, & z0,znt real(kind=RKIND),dimension(:),pointer :: shdmin,shdmax,snoalb,sfc_albbck,snow,snowc,snowh,tmn, & skintemp,vegfra,xice,xland @@ -354,7 +358,6 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) call mpas_pool_get_array(diag_physics,'br' ,br ) call mpas_pool_get_array(diag_physics,'sfc_albedo' ,sfc_albedo ) - call mpas_pool_get_array(diag_physics,'sfc_albedo_seaice',sfc_albedo_seaice) call mpas_pool_get_array(diag_physics,'sfc_emibck' ,sfc_emibck ) call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) call mpas_pool_get_array(diag_physics,'sfcrunoff' ,sfcrunoff ) @@ -362,6 +365,8 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) call mpas_pool_get_array(diag_physics,'smstot' ,smstot ) call mpas_pool_get_array(diag_physics,'snotime' ,snotime ) call mpas_pool_get_array(diag_physics,'snopcx' ,snopcx ) + call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) + call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) call mpas_pool_get_array(diag_physics,'z0' ,z0 ) call mpas_pool_get_array(diag_physics,'znt' ,znt ) @@ -436,6 +441,8 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) smstot_p(i,j) = smstot(i) snotime_p(i,j) = snotime(i) snopcx_p(i,j) = snopcx(i) + swddif_p(i,j) = swddif(i) + swddir_p(i,j) = swddir(i) udrunoff_p(i,j) = udrunoff(i) z0_p(i,j) = z0(i) znt_p(i,j) = znt(i) @@ -469,13 +476,8 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !initialization of arrays to run the Noah LSM urban parameterization (not currently frc_urb_p(i,j) = 0._RKIND ust_urb_p(i,j) = 0._RKIND - utype_urb_p(i,j) = low_density_residential + utype_urb_p(i,j) = 0 - !initialization of arrays to run the Noah LSM hydrological parameterization (not currently - !implemented in MPAS): - infxsrt_p(i,j) = 0._RKIND - sfcheadrt_p(i,j) = 0._RKIND - soldrain_p(i,j) = 0._RKIND enddo enddo @@ -507,7 +509,7 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) !seaice thickness. do j = jts,jte do i = its,ite - albsi_p(i,j) = sfc_albedo_seaice(i) + albsi_p(i,j) = seaice_albedo_default icedepth_p(i,j) = seaice_thickness_default snowsi_p(i,j) = seaice_snowdepth_min enddo @@ -760,7 +762,7 @@ subroutine init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) lsm_select: select case (trim(lsm_scheme)) - case ("noah") + case ("sf_noah") call noah_init_forMPAS(dminfo,mesh,configs,diag_physics,sfc_input) case default @@ -807,8 +809,8 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) !call to land-surface scheme: lsm_select: select case (trim(lsm_scheme)) - case("noah") - call mpas_timer_start('Noah') + case("sf_noah") + call mpas_timer_start('sf_noah') call lsm( & dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & qv3d = qv_p , xland = xland_p , xice = xice_p , & @@ -835,18 +837,21 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) opt_thcnd = opt_thcnd , ua_phys = ua_phys , flx4_2d = flxsnow_p , & fvb_2d = fvbsnow_p , fbur_2d = fbursnow_p , fgsn_2d = fgsnsnow_p , & utype_urb2d = utype_urb_p , frc_urb2d = frc_urb_p , ust_urb2d = ust_urb_p , & - infxsrt = infxsrt_p , sfcheadrt = sfcheadrt_p , soldrain = soldrain_p , & - fasdas = fasdas , julian = 0 , julyr = 0 , & + swddir = swddir_p , swddif = swddif_p , fasdas = fasdas , & + julian = 0 , julyr = 0 , & + num_soil_layers = num_soils , & xice_threshold = xice_threshold , & usemonalb = config_sfc_albedo , & - mminlu = mminlu , & - num_soil_layers = num_soils , & - num_roof_layers = num_soils , & - num_wall_layers = num_soils , & - num_road_layers = num_soils , & - num_urban_layers = num_soils , & - num_urban_hi = num_soils , & - sf_urban_physics = sf_urban_physics , & + mminlu = mminlu , & + sf_urban_physics = sf_urban_physics , & + num_roof_layers = nurb , num_wall_layers = nurb , & + num_road_layers = nurb , num_urban_hi = nurb , & + num_urban_ndm = nurb , urban_map_zrd = nurb , & + urban_map_zwd = nurb , urban_map_gd = nurb , & + urban_map_zd = nurb , urban_map_zdf = nurb , & + urban_map_bd = nurb , urban_map_wd = nurb , & + urban_map_gbd = nurb , urban_map_fbd = nurb , & + urban_map_zgrd = nurb , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & @@ -893,7 +898,7 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('Noah') + call mpas_timer_stop('sf_noah') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_shared.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_shared.F new file mode 100644 index 0000000000..fdac7ed20c --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_shared.F @@ -0,0 +1,65 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and the University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html +! +!================================================================================================================= + module mpas_atmphys_driver_lsm_shared + use mpas_kind_types + + + implicit none + private + public:: correct_tsk_over_seaice + + + contains + + +!================================================================================================================= + subroutine correct_tsk_over_seaice(ims,ime,jms,jme,its,ite,jts,jte,xice_thresh,xice,tsk,tsk_sea,tsk_ice) +!================================================================================================================= + +!input arguments: + integer,intent(in):: ims,ime,its,ite,jms,jme,jts,jte + real(kind=RKIND),intent(in):: xice_thresh + real(kind=RKIND),intent(in),dimension(ims:ime,jms:jme):: tsk,xice + +!inout arguments: + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme):: tsk_sea,tsk_ice + +!local variables: + integer:: i,j + +!----------------------------------------------------------------------------------------------------------------- + +!initialize the local sea-surface temperature and local sea-ice temperature to the local surface +!temperature: + do j = jts,jte + do i = its,ite + tsk_sea(i,j) = tsk(i,j) + tsk_ice(i,j) = tsk(i,j) + + if(xice(i,j).ge.xice_thresh .and. xice(i,j).le.1._RKIND) then + !over sea-ice grid cells, limit sea-surface temperatures to temperatures warmer than 271.4: + tsk_sea(i,j) = max(tsk_sea(i,j),271.4_RKIND) + + !over sea-ice grid cells, avoids unphysically too cold sea-ice temperatures for grid cells + !with small sea-ice fractions: + if(xice(i,j).lt.0.2_RKIND .and. tsk_ice(i,j).lt.253.15_RKIND) tsk_ice(i,j) = 253.15_RKIND + if(xice(i,j).lt.0.1_RKIND .and. tsk_ice(i,j).lt.263.15_RKIND) tsk_ice(i,j) = 263.15_RKIND + endif + enddo + enddo + + end subroutine correct_tsk_over_seaice + +!================================================================================================================= + end module mpas_atmphys_driver_lsm_shared +!================================================================================================================= + + + + diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 27fc07e768..41ae9ef795 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -19,7 +19,9 @@ module mpas_atmphys_driver_microphysics !wrf physics: use module_mp_kessler use module_mp_thompson - use module_mp_wsm6 + use module_mp_wsm6,only: wsm6 + use mp_wsm6,only: mp_wsm6_init,refl10cm_wsm6 + implicit none private @@ -256,8 +258,16 @@ subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) !local pointer: character(len=StrKIND),pointer:: microp_scheme +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) microp_select: select case(microp_scheme) @@ -267,7 +277,8 @@ subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) call init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) case("mp_wsm6") - call wsm6init(rho_a,rho_r,rho_s,cliq,cpv,hail_opt,.false.) + call mp_wsm6_init(den0=rho_a,denr=rho_r,dens=rho_s,cl=cliq,cpv=cpv, & + hail_opt=hail_opt,errmsg=errmsg,errflg=errflg) case default @@ -299,35 +310,20 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten character(len=StrKIND),pointer:: microp_scheme !local variables and arrays: - logical:: log_microphysics - integer:: i,icell,icount,istep,j,k,kk - -!Calculate dtheta_dt_mp (NS: 2018-04-24) -!Store theta, call microphysics->updates theta, calculate tendency - integer, pointer :: nCells, nVertLevels, index_qv - real(kind=RKIND), dimension(:,:), pointer :: dtheta_dt_mp, theta_m - real (kind=RKIND), dimension(:,:,:), pointer :: scalars - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - - call mpas_pool_get_array(state, 'theta_m', theta_m, time_lev) - call mpas_pool_get_array(diag, 'dtheta_dt_mp', dtheta_dt_mp) - call mpas_pool_get_array(state, 'scalars', scalars, time_lev) - - !initialize to theta before microphysics call. - !I think the physics call actually updates variables, not generate a tendency. - do icell=1,nCells - do k=1,nVertLevels - dtheta_dt_mp(k,icell) = theta_m(k,icell) / (1._RKIND + rvord * scalars(index_qv,k,icell)) - end do - end do + integer:: istep + +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('---enter subroutine driver_microphysics:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) !... allocation of microphysics arrays: @@ -386,27 +382,30 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten call mpas_timer_stop('Thompson') case ("mp_wsm6") - call mpas_timer_start('WSM6') + call mpas_timer_start('mp_wsm6') call wsm6( & - th = th_p , q = qv_p , qc = qc_p , & - qr = qr_p , qi = qi_p , qs = qs_p , & - qg = qg_p , den = rho_p , pii = pi_p , & - p = pres_p , delz = dz_p , delt = dt_microp , & - g = gravity , cpd = cp , cpv = cpv , & - rd = R_d , rv = R_v , t0c = svpt0 , & - ep1 = ep_1 , ep2 = ep_2 , qmin = epsilon , & - xls = xls , xlv0 = xlv , xlf0 = xlf , & - den0 = rho_a , denr = rho_w , cliq = cliq , & - cice = cice , psat = psat , rain = rainnc_p , & - rainncv = rainncv_p , snow = snownc_p , snowncv = snowncv_p , & - graupel = graupelnc_p , graupelncv = graupelncv_p , sr = sr_p , & - re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & - has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & - ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & - ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & - its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + th = th_p , q = qv_p , qc = qc_p , & + qr = qr_p , qi = qi_p , qs = qs_p , & + qg = qg_p , den = rho_p , pii = pi_p , & + p = pres_p , delz = dz_p , delt = dt_microp , & + g = gravity , cpd = cp , cpv = cpv , & + rd = R_d , rv = R_v , t0c = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , qmin = epsilon , & + xls = xls , xlv0 = xlv , xlf0 = xlf , & + den0 = rho_a , denr = rho_w , cliq = cliq , & + cice = cice , psat = psat , rain = rainnc_p , & + rainncv = rainncv_p , snow = snownc_p , snowncv = snowncv_p , & + graupel = graupelnc_p , graupelncv = graupelncv_p , sr = sr_p , & + re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & + has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & + re_qc_bg = re_qc_bg , re_qi_bg = re_qi_bg , re_qs_bg = re_qs_bg , & + re_qc_max = re_qc_max , re_qi_max = re_qi_max , re_qs_max = re_qs_max , & + errmsg = errmsg , errflg = errflg , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('WSM6') + call mpas_timer_stop('mp_wsm6') case default @@ -438,14 +437,6 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten ! dynamics grid: call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) -!Calculate dtheta_dt_mp (NS: 2018-04-24) -!From stored dtheta_dt_mp, calculate changeInTheta/timeStep - do icell=1,nCells - do k=1,nVertLevels - dtheta_dt_mp(k,icell) = (theta_m(k,icell)/(1._RKIND+rvord*scalars(index_qv,k,icell)) - dtheta_dt_mp(k,icell))/(dt_dyn) - end do - end do - !... deallocation of all microphysics arrays: !$OMP BARRIER !$OMP MASTER @@ -671,7 +662,7 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) zp(k) = z_p(i,k,j) - z_p(i,1,j)+0.5*dz_p(i,1,j) ! height AGL enddo - call refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d,kts,kte,i,j) + call refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d,kts,kte) kp = 1 do k = kts,kte diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F index eaa898f980..5f2a860089 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F @@ -127,7 +127,7 @@ subroutine driver_oml1d(configs,mesh,diag,diag_physics,sfc_input) ! if ocean point, call the 1d ocean mixed layer model if( xland(iCell) .gt. 1.5) then - f_coriolis = 2.*omega*cos(latCell(iCell)) + f_coriolis = 2.*omega*sin(latCell(iCell)) call oml1d( t_oml(iCell), t_oml_initial(iCell), h_oml(iCell), h_oml_initial(iCell), & hu_oml(iCell), hv_oml(iCell), skintemp(iCell), hfx(iCell), & lh(iCell), gsw(iCell), glw(iCell), t_oml_200m_initial(iCell), & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 437d1525d1..c5ee085954 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F @@ -60,7 +60,7 @@ module mpas_atmphys_driver_pbl ! * for the mynn parameterization, change the definition of dx_p to match that used in other physics ! parameterizations. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. -! * updated the call to subroutine ysu in comjunction with updating module_bl_ysu.F from WRF version 3.6.1 to +! * updated the call to subroutine ysu in conjunction with updating module_bl_ysu.F from WRF version 3.6.1 to ! WRF version 3.8.1 ! Laura D. Fowler (laura@ucar.edu) / 2016-10-27. ! * since we removed the local variable pbl_scheme from mpas_atmphys_vars.F, now defines pbl_scheme as a pointer @@ -69,6 +69,10 @@ module mpas_atmphys_driver_pbl ! * after updating module_bl_ysu.F to WRF version 4.0.3, corrected call to subroutine ysu to output diagnostics of ! exchange coefficients exch_h and exch_m. ! Laura D. Fowler (laura@ucar.edu) / 2019-03-12. +! * updated the call to subroutine ysu after updating the YSU PBL scheme to that in WRF 4.4.1. added the flags +! errmsg and errflg in the call to subroutine ysu for compliance with the CCPP framework. also removed local +! variable regime_p which is no longer needed in the call to subroutine ysu. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. contains @@ -124,7 +128,6 @@ subroutine allocate_pbl(configs) if(.not.allocated(ctopo2_p)) allocate(ctopo2_p(ims:ime,jms:jme) ) if(.not.allocated(psih_p) ) allocate(psih_p(ims:ime,jms:jme) ) if(.not.allocated(psim_p) ) allocate(psim_p(ims:ime,jms:jme) ) - if(.not.allocated(regime_p)) allocate(regime_p(ims:ime,jms:jme) ) if(.not.allocated(u10_p) ) allocate(u10_p(ims:ime,jms:jme) ) if(.not.allocated(v10_p) ) allocate(v10_p(ims:ime,jms:jme) ) if(.not.allocated(exch_p) ) allocate(exch_p(ims:ime,kms:kme,jms:jme)) @@ -212,7 +215,6 @@ subroutine deallocate_pbl(configs) if(allocated(ctopo2_p)) deallocate(ctopo2_p) if(allocated(psih_p) ) deallocate(psih_p ) if(allocated(psim_p) ) deallocate(psim_p ) - if(allocated(regime_p)) deallocate(regime_p) if(allocated(u10_p) ) deallocate(u10_p ) if(allocated(v10_p) ) deallocate(v10_p ) if(allocated(exch_p) ) deallocate(exch_p ) @@ -274,7 +276,7 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it !local pointers for YSU scheme: logical,pointer:: config_ysu_pblmix - real(kind=RKIND),dimension(:),pointer:: br,fh,fm,regime,u10,v10 + real(kind=RKIND),dimension(:),pointer:: br,fh,fm,u10,v10 real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw !local pointers for MYNN scheme: @@ -325,7 +327,6 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it call mpas_pool_get_array(diag_physics,'br' ,br ) call mpas_pool_get_array(diag_physics,'fm' ,fm ) call mpas_pool_get_array(diag_physics,'fh' ,fh ) - call mpas_pool_get_array(diag_physics,'regime',regime) call mpas_pool_get_array(diag_physics,'u10' ,u10 ) call mpas_pool_get_array(diag_physics,'v10' ,v10 ) @@ -341,7 +342,6 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it br_p(i,j) = br(i) psim_p(i,j) = fm(i) psih_p(i,j) = fh(i) - regime_p(i,j) = regime(i) u10_p(i,j) = u10(i) v10_p(i,j) = v10(i) !initialization for YSU PBL scheme: @@ -598,10 +598,18 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics integer:: initflag integer:: i,k,j +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_pbl:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme ) @@ -614,14 +622,14 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") - call mpas_timer_start('YSU') + call mpas_timer_start('bl_ysu') call ysu ( & p3d = pres_hyd_p , p3di = pres2_hyd_p , psfc = psfc_p , & - th3d = th_p , t3d = t_p , dz8w = dz_p , & - pi3d = pi_p , u3d = u_p , v3d = v_p , & - qv3d = qv_p , qc3d = qc_p , qi3d = qi_p , & - rublten = rublten_p , rvblten = rvblten_p , rthblten = rthblten_p , & - rqvblten = rqvblten_p , rqcblten = rqcblten_p , rqiblten = rqiblten_p , & + t3d = t_p , dz8w = dz_p , pi3d = pi_p , & + u3d = u_p , v3d = v_p , qv3d = qv_p , & + qc3d = qc_p , qi3d = qi_p , rublten = rublten_p , & + rvblten = rvblten_p , rthblten = rthblten_p , rqvblten = rqvblten_p , & + rqcblten = rqcblten_p , rqiblten = rqiblten_p , flag_qc = f_qc , & flag_qi = f_qi , cp = cp , g = gravity , & rovcp = rcp , rd = R_d , rovg = rdg , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & @@ -633,13 +641,14 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics exch_m = kzm_p , wstar = wstar_p , delta = delta_p , & uoce = uoce_p , voce = voce_p , rthraten = rthraten_p , & u10 = u10_p , v10 = v10_p , ctopo = ctopo_p , & - ctopo2 = ctopo2_p , regime = regime_p , & + ctopo2 = ctopo2_p , flag_bep = flag_bep , idiff = idiff , & ysu_topdown_pblmix = ysu_pblmix , & + errmsg = errmsg , errflg = errflg , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) - call mpas_timer_stop('YSU') + call mpas_timer_stop('bl_ysu') case("bl_mynn") call mpas_timer_start('MYNN_pbl') diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F index 35f5a42c1c..fc3b712966 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -82,7 +82,9 @@ module mpas_atmphys_driver_radiation_sw ! Laura D. Fowler (laura@ucar.edu) / 2017-02-10. ! * since we removed the local variable radt_sw_scheme from mpas_atmphys_vars.F, now defines radt_sw_scheme ! as a pointer to config_radt_sw_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * added the variables swddir,swddni,swddif for use in the updated version of the Noah LSM. +! Laura D. Fowler (laura@ucar.edu) / 2023-04-21. contains @@ -145,6 +147,10 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(swnirdir_p) ) allocate(swnirdir_p(ims:ime,jms:jme) ) if(.not.allocated(swnirdif_p) ) allocate(swnirdif_p(ims:ime,jms:jme) ) + if(.not.allocated(swddir_p) ) allocate(swddir_p(ims:ime,jms:jme) ) + if(.not.allocated(swddni_p) ) allocate(swddni_p(ims:ime,jms:jme) ) + if(.not.allocated(swddif_p) ) allocate(swddif_p(ims:ime,jms:jme) ) + if(.not.allocated(swdnflx_p) ) allocate(swdnflx_p(ims:ime,kms:kme+1,jms:jme) ) if(.not.allocated(swdnflxc_p) ) allocate(swdnflxc_p(ims:ime,kms:kme+1,jms:jme) ) if(.not.allocated(swupflx_p) ) allocate(swupflx_p(ims:ime,kms:kme+1,jms:jme) ) @@ -249,6 +255,14 @@ subroutine deallocate_radiation_sw(configs) if(allocated(alswvisdif_p) ) deallocate(alswvisdif_p ) if(allocated(alswnirdir_p) ) deallocate(alswnirdir_p ) if(allocated(alswnirdif_p) ) deallocate(alswnirdif_p ) + if(allocated(swvisdir_p) ) deallocate(swvisdir_p ) + if(allocated(swvisdif_p) ) deallocate(swvisdif_p ) + if(allocated(swnirdir_p) ) deallocate(swnirdir_p ) + if(allocated(swnirdif_p) ) deallocate(swnirdif_p ) + + if(allocated(swddir_p) ) deallocate(swddir_p ) + if(allocated(swddni_p) ) deallocate(swddni_p ) + if(allocated(swddif_p) ) deallocate(swddif_p ) if(allocated(swdnflx_p) ) deallocate(swdnflx_p ) if(allocated(swdnflxc_p) ) deallocate(swdnflxc_p ) @@ -400,6 +414,9 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i swupbc_p(i,j) = 0.0_RKIND swupt_p(i,j) = 0.0_RKIND swuptc_p(i,j) = 0.0_RKIND + swddir_p(i,j) = 0.0_RKIND + swddni_p(i,j) = 0.0_RKIND + swddif_p(i,j) = 0.0_RKIND enddo do k = kts,kte @@ -589,10 +606,13 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) !local pointers: real(kind=RKIND),dimension(:),pointer :: coszr,gsw,swcf,swdnb,swdnbc,swdnt,swdntc, & - swupb,swupbc,swupt,swuptc + swupb,swupbc,swupt,swuptc,swddir,swddni, & + swddif real(kind=RKIND),dimension(:,:),pointer:: rthratensw !----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine radiation_sw_to_MPAS:') call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) @@ -602,9 +622,12 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'swdnt' ,swdnt ) call mpas_pool_get_array(diag_physics,'swdntc' ,swdntc ) call mpas_pool_get_array(diag_physics,'swupb' ,swupb ) - call mpas_pool_get_array(diag_physics,'swupbc' , swupbc ) + call mpas_pool_get_array(diag_physics,'swupbc' ,swupbc ) call mpas_pool_get_array(diag_physics,'swupt' ,swupt ) call mpas_pool_get_array(diag_physics,'swuptc' ,swuptc ) + call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) + call mpas_pool_get_array(diag_physics,'swddni' ,swddni ) + call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) do j = jts,jte @@ -621,6 +644,9 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) swupbc(i) = swupbc_p(i,j) swupt(i) = swupt_p(i,j) swuptc(i) = swuptc_p(i,j) + swddir(i) = swddir_p(i,j) + swddni(i) = swddni_p(i,j) + swddif(i) = swddif_p(i,j) enddo do k = kts,kte @@ -631,6 +657,9 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) enddo +!call mpas_log_write('--- enter subroutine radiation_sw_to_MPAS:') +!call mpas_log_write(' ') + end subroutine radiation_sw_to_MPAS !================================================================================================================= @@ -760,6 +789,7 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic re_snow = resnow_p , swupt = swupt_p , swuptc = swuptc_p , & swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p , & swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p , & + swddir = swddir_p , swddni = swddni_p , swddif = swddif_p , & ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F index c5ace58d06..ae3314c32f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -17,6 +17,8 @@ module mpas_atmphys_driver_sfclayer !wrf physics: use module_sf_mynn use module_sf_sfclay + use module_sf_sfclayrev,only: sfclayrev + use sf_sfclayrev,only: sf_sfclayrev_init implicit none private @@ -78,7 +80,13 @@ module mpas_atmphys_driver_sfclayer ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. ! * since we removed the local variable sfclayer_scheme from mpas_atmphys_vars.F, now defines sfclayer_scheme ! as a pointer to config_sfclayer_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine driver_sfclayer, replaced the call to sfclay with a call to sfclayrev to use the revised +! version of the MONIN-OBUKHOV surface layer scheme. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. +! * added the option sf_monin_obukhov_rev to run the revised surface layer scheme with the YSU PBL scheme. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. + contains @@ -184,7 +192,7 @@ subroutine allocate_sfclayer(configs) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") if(.not.allocated(fh_p)) allocate(fh_p(ims:ime,jms:jme)) if(.not.allocated(fm_p)) allocate(fm_p(ims:ime,jms:jme)) if(config_frac_seaice) then @@ -192,6 +200,17 @@ subroutine allocate_sfclayer(configs) if(.not.allocated(fm_sea)) allocate(fm_sea(ims:ime,jms:jme)) endif + sfclayer2_select: select case(sfclayer_scheme) + + case("sf_monin_obukhov_rev") + if(.not.allocated(waterdepth_p)) allocate(waterdepth_p(ims:ime,jms:jme)) + if(.not.allocated(lakedepth_p) ) allocate(lakedepth_p(ims:ime,jms:jme) ) + if(.not.allocated(lakemask_p) ) allocate(lakemask_p(ims:ime,jms:jme) ) + + case default + + end select sfclayer2_select + case("sf_mynn") if(.not.allocated(snowh_p)) allocate(snowh_p(ims:ime,jms:jme)) if(.not.allocated(ch_p) ) allocate(ch_p(ims:ime,jms:jme) ) @@ -301,7 +320,7 @@ subroutine deallocate_sfclayer(configs) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") if(allocated(fh_p)) deallocate(fh_p) if(allocated(fm_p)) deallocate(fm_p) if(config_frac_seaice) then @@ -309,6 +328,17 @@ subroutine deallocate_sfclayer(configs) if(allocated(fm_sea)) deallocate(fm_sea) endif + sfclayer2_select: select case(sfclayer_scheme) + + case("sf_monin_obukhov_rev") + if(allocated(waterdepth_p)) deallocate(waterdepth_p) + if(allocated(lakedepth_p) ) deallocate(lakedepth_p ) + if(allocated(lakemask_p) ) deallocate(lakemask_p ) + + case default + + end select sfclayer2_select + case("sf_mynn") if(allocated(snowh_p)) deallocate(snowh_p) if(allocated(ch_p) ) deallocate(ch_p ) @@ -516,7 +546,7 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") call mpas_pool_get_array(diag_physics,'fh',fh) call mpas_pool_get_array(diag_physics,'fm',fm) @@ -531,6 +561,22 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo + sfclayer2_select: select case(sfclayer_scheme) + + case("sf_monin_obukhov_rev") + + do j = jts,jte + do i = its,ite + waterdepth_p(i,j) = 0._RKIND + lakedepth_p(i,j) = 0._RKIND + lakemask_p(i,j) = 0._RKIND + enddo + enddo + + case default + + end select sfclayer2_select + case("sf_mynn") !input variables: call mpas_pool_get_array(diag_physics,'qcg' ,qcg ) @@ -733,7 +779,7 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") call mpas_pool_get_array(diag_physics,'fh',fh) call mpas_pool_get_array(diag_physics,'fm',fm) @@ -791,8 +837,16 @@ subroutine init_sfclayer(configs) logical, parameter:: allowed_to_read = .false. !actually not used in subroutine sfclayinit. character(len=StrKIND),pointer:: sfclayer_scheme +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme) sfclayer_select: select case (trim(sfclayer_scheme)) @@ -800,6 +854,9 @@ subroutine init_sfclayer(configs) case("sf_monin_obukhov") call sfclayinit(allowed_to_read) + case("sf_monin_obukhov_rev") + call sf_sfclayrev_init(errmsg,errflg) + case("sf_mynn") call mynn_sf_init_driver(allowed_to_read) @@ -833,10 +890,18 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite integer:: initflag real(kind=RKIND):: dx +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) @@ -854,12 +919,12 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite sfclayer_select: select case (trim(sfclayer_scheme)) case("sf_monin_obukhov") - call mpas_timer_start('Monin-Obukhov') + call mpas_timer_start('sf_monin_obukhov') call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & dz8w = dz_p , cp = cp , g = gravity , & - rovcp = rcp , R = R_d , xlv = xlv , & + rovcp = rcp , R = R_d , xlv = xlv , & chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , & cpm = cpm_p , znt = znt_p , ust = ust_p , & pblh = hpbl_p , mavail = mavail_p , zol = zol_p , & @@ -912,7 +977,76 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & ) endif - call mpas_timer_stop('Monin-Obukhov') + call mpas_timer_stop('sf_monin_obukhov') + + case("sf_monin_obukhov_rev") + call mpas_timer_start('sf_monin_obukhov_rev') + call mpas_log_write('--- enter subroutine sfclayrev:') + call sfclayrev( & + p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & + u3d = u_p , v3d = v_p , qv3d = qv_p , & + dz8w = dz_p , cp = cp , g = gravity , & + rovcp = rcp , R = R_d , xlv = xlv , & + chs = chs_p , chs2 = chs2_p , cqs2 = cqs2_p , & + cpm = cpm_p , znt = znt_p , ust = ust_p , & + pblh = hpbl_p , mavail = mavail_p , zol = zol_p , & + mol = mol_p , regime = regime_p , psim = psim_p , & + psih = psih_p , fm = fm_p , fh = fh_p , & + xland = xland_p , hfx = hfx_p , qfx = qfx_p , & + lh = lh_p , tsk = tsk_p , flhc = flhc_p , & + flqc = flqc_p , qgh = qgh_p , qsfc = qsfc_p , & + rmol = rmol_p , u10 = u10_p , v10 = v10_p , & + th2 = th2m_p , t2 = t2m_p , q2 = q2_p , & + gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & + svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , karman = karman , & + eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & + ustm = ustm_p , ck = ck_p , cka = cka_p , & + cd = cd_p , cda = cda_p , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , shalwater_z0 = shalwater_flag , shalwater_depth = shalwater_depth , & + water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & + errmsg = errmsg , errflg = errflg , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + call mpas_log_write('--- end subroutine sfclayrev:') + + if(config_frac_seaice) then + call mpas_log_write('--- enter subroutine sfclayrev seaice:') + call sfclayrev( & + p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & + u3d = u_p , v3d = v_p , qv3d = qv_p , & + dz8w = dz_p , cp = cp , g = gravity , & + rovcp = rcp , R = R_d , xlv = xlv , & + chs = chs_sea , chs2 = chs2_sea , cqs2 = cqs2_sea , & + cpm = cpm_sea , znt = znt_sea , ust = ust_sea , & + pblh = hpbl_p , mavail = mavail_sea , zol = zol_sea , & + mol = mol_sea , regime = regime_sea , psim = psim_sea , & + psih = psih_sea , fm = fm_sea , fh = fh_sea , & + xland = xland_sea , hfx = hfx_sea , qfx = qfx_sea , & + lh = lh_sea , tsk = tsk_sea , flhc = flhc_sea , & + flqc = flqc_sea , qgh = qgh_sea , qsfc = qsfc_sea , & + rmol = rmol_sea , u10 = u10_sea , v10 = v10_sea , & + th2 = th2m_sea , t2 = t2m_sea , q2 = q2_sea , & + gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & + svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , karman = karman , & + eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & + ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & + cd = cd_sea , cda = cda_sea , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , shalwater_z0 = shalwater_flag , shalwater_depth = shalwater_depth , & + water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & + errmsg = errmsg , errflg = errflg , & + ids = ids , ide = ide , jds = jds , jde = jde , kds = kds , kde = kde , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + call mpas_log_write('--- end subroutine sfclayrev seaice:') + endif + call mpas_timer_stop('sf_monin_obukhov_rev') case("sf_mynn") call mpas_timer_start('MYNN_sfclay') diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 92112da785..b58ee369d4 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -341,8 +341,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ endif !read the input files that contain the monthly-mean ozone climatology on fixed pressure levels: - if(config_o3climatology .and. (.not. config_do_restart)) & - call init_o3climatology(mesh,atm_input) + if(config_o3climatology) call init_o3climatology(mesh,atm_input) !initialization of global surface properties. set here for now, but may be moved when time !manager is implemented: diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index eae7dd844d..d6dc1bc0c1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -52,6 +52,13 @@ module mpas_atmphys_initialize_real ! * In subroutine physics_init_seaice, removed the initialization of isice_lu since it is now defined in ! Registry.xml and initialized in subroutine init_atm_static. ! Laura D. Fowler (laura@ucar.edu) / 2017-01-12. +! * In subroutine physics_init_seaice, added the initialization of the annual maximum snow albedo over seaice +! points to 0.75. +! * Laura D. Fowler (laura@ucar.edu) / 2022-03-15). +! * In subroutine physics_init_seaice, corrected the initialization of seaice points when the surface +! temperature was originally colder than 271K. We now use the seaice threshold config_tsk_seaice_threshold +! that has a default value set to 100K. This leads to decreased seaice at high latitudes. +! Laura D. Fowler (laura@ucar.edu) / 2022-03-25. contains @@ -596,8 +603,9 @@ subroutine physics_init_seaice(mesh, input, dims, configs) real(kind=RKIND):: xice_threshold real(kind=RKIND):: mid_point_depth + real(kind=RKIND),pointer:: tsk_seaice_threshold real(kind=RKIND),dimension(:),pointer :: vegfra - real(kind=RKIND),dimension(:),pointer :: seaice,xice + real(kind=RKIND),dimension(:),pointer :: seaice,snoalb,xice real(kind=RKIND),dimension(:),pointer :: skintemp,tmn,xland real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel @@ -608,15 +616,15 @@ subroutine physics_init_seaice(mesh, input, dims, configs) !note that this threshold is also defined in module_physics_vars.F.It is defined here to avoid !adding "use module_physics_vars" since this subroutine is only used for the initialization of !a "real" forecast with $CORE = init_nhyd_atmos. - real(kind=RKIND),parameter:: xice_tsk_threshold = 271. real(kind=RKIND),parameter:: total_depth = 3. ! 3-meter soil depth. !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter physics_init_seaice:') - call mpas_pool_get_config(configs, 'config_frac_seaice', config_frac_seaice) - call mpas_pool_get_config(configs, 'config_landuse_data', config_landuse_data) + call mpas_pool_get_config(configs, 'config_frac_seaice' , config_frac_seaice) + call mpas_pool_get_config(configs, 'config_tsk_seaice_threshold', tsk_seaice_threshold) + call mpas_pool_get_config(configs, 'config_landuse_data' , config_landuse_data) call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(dims, 'nSoilLevels', nSoilLevels) @@ -625,6 +633,7 @@ subroutine physics_init_seaice(mesh, input, dims, configs) call mpas_pool_get_array(mesh, 'landmask', landmask) call mpas_pool_get_array(mesh, 'lu_index', ivgtyp) call mpas_pool_get_array(mesh, 'soilcat_top', isltyp) + call mpas_pool_get_array(mesh, 'snoalb', snoalb) call mpas_pool_get_array(input, 'seaice', seaice) call mpas_pool_get_array(input, 'xice', xice) @@ -656,19 +665,21 @@ subroutine physics_init_seaice(mesh, input, dims, configs) endif call mpas_log_write('--- config_frac_seaice : $l', logicArgs=(/config_frac_seaice/)) call mpas_log_write('--- xice_threshold : $r', realArgs=(/xice_threshold/)) + call mpas_log_write('--- tsk_seaice_threshold : $r', realArgs=(/tsk_seaice_threshold/)) !convert seaice points to land points when the sea-ice fraction is greater than the !prescribed threshold: num_seaice_changes = 0 do iCell = 1, nCellsSolve if(xice(iCell) .ge. xice_threshold .or. & - (landmask(iCell).eq.0 .and. skintemp(iCell).lt.xice_tsk_threshold)) then + (landmask(iCell).eq.0 .and. skintemp(iCell).lt.tsk_seaice_threshold)) then num_seaice_changes = num_seaice_changes + 1 !... sea-ice points are converted to land points: if(landmask(iCell) .eq. 0) tmn(iCell) = 271.4_RKIND ivgtyp(iCell) = isice_lu isltyp(iCell) = 16 + snoalb(iCell) = 0.75 vegfra(iCell) = 0._RKIND xland(iCell) = 1._RKIND diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index 1f5410b3a8..5da88ebc29 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -638,6 +638,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te real(kind=RKIND),dimension(:,:),pointer :: zz,exner,exner_b,pressure_b,rtheta_p,rtheta_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p real(kind=RKIND),dimension(:,:),pointer :: rt_diabatic_tend + real(kind=RKIND),dimension(:,:),pointer :: dtheta_dt_mp real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg real(kind=RKIND),dimension(:,:),pointer :: ni,nr real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod @@ -663,6 +664,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(diag,'rtheta_base' ,rtheta_b ) call mpas_pool_get_array(diag,'rtheta_p' ,rtheta_p ) call mpas_pool_get_array(diag,'surface_pressure',surface_pressure) + call mpas_pool_get_array(diag,'dtheta_dt_mp' ,dtheta_dt_mp ) call mpas_pool_get_array(diag_physics,'rainprod',rainprod) call mpas_pool_get_array(diag_physics,'evapprod',evapprod) @@ -695,14 +697,21 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te do j = jts,jte do k = kts,kte do i = its,ite + + !initializes tendency of coupled potential temperature potential temperature, and + !potential temperature heating rate from microphysics: + rt_diabatic_tend(k,i) = theta_m(k,i) + dtheta_dt_mp(k,i) = theta_m(k,i)/(1._RKIND+rvord*qv(k,i)) + + !updates water vapor, cloud liquid water, rain mixing ratios, modified potential temperature, + !tendency of coupled potential temperature, and potential temperature heating rate from microphysics: qv(k,i) = qv_p(i,k,j) qc(k,i) = qc_p(i,k,j) qr(k,i) = qr_p(i,k,j) - !potential temperature and diabatic forcing: - rt_diabatic_tend(k,i) = theta_m(k,i) - theta_m(k,i) = th_p(i,k,j) * (1. + R_v/R_d * qv_p(i,k,j)) - rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i)) / dt_dyn + theta_m(k,i) = th_p(i,k,j) * (1._RKIND+rvord*qv_p(i,k,j)) + rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i))/dt_dyn + dtheta_dt_mp(k,i) = (theta_m(k,i)/(1._RKIND+rvord*qv(k,i))-dtheta_dt_mp(k,i))/(dt_dyn) !density-weighted perturbation potential temperature: rtheta_p(k,i) = rho_zz(k,i) * theta_m(k,i) - rtheta_b(k,i) diff --git a/src/core_atmosphere/physics/mpas_atmphys_landuse.F b/src/core_atmosphere/physics/mpas_atmphys_landuse.F index c482565cf1..a153d09948 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_landuse.F +++ b/src/core_atmosphere/physics/mpas_atmphys_landuse.F @@ -14,6 +14,7 @@ module mpas_atmphys_landuse use mpas_dmpar use mpas_kind_types use mpas_pool_routines + use mpas_io_units use mpas_atmphys_utilities use mpas_atmphys_vars @@ -108,13 +109,13 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu real(kind=RKIND),dimension(:),pointer:: latCell real(kind=RKIND),dimension(:),pointer:: snoalb,snowc,xice real(kind=RKIND),dimension(:),pointer:: albbck,embck,xicem,xland,z0 - real(kind=RKIND),dimension(:),pointer:: mavail,sfc_albedo,sfc_albedo_seaice,sfc_emiss,thc,ust,znt + real(kind=RKIND),dimension(:),pointer:: mavail,sfc_albedo,sfc_emiss,thc,ust,znt !local variables: character(len=StrKIND) :: lutype character(len=StrKIND):: mess - integer,parameter:: land_unit = 15 + integer:: land_unit integer,parameter:: open_ok = 0 integer,parameter:: max_cats = 100 integer,parameter:: max_seas = 12 @@ -155,7 +156,6 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu call mpas_pool_get_array(diag_physics,'sfc_emibck' ,embck ) call mpas_pool_get_array(diag_physics,'mavail' ,mavail ) call mpas_pool_get_array(diag_physics,'sfc_albedo' ,sfc_albedo ) - call mpas_pool_get_array(diag_physics,'sfc_albedo_seaice',sfc_albedo_seaice) call mpas_pool_get_array(diag_physics,'sfc_emiss' ,sfc_emiss ) call mpas_pool_get_array(diag_physics,'thc' ,thc ) call mpas_pool_get_array(diag_physics,'ust' ,ust ) @@ -170,6 +170,11 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu !reads in the landuse properties from landuse.tbl: if(dminfo % my_proc_id == IO_NODE) then + !get a unit to open init file: + call mpas_new_unit(land_unit) + if ( land_unit < 0 ) & + call physics_error_fatal('landuse_init_forMPAS: All file units are taken. Change maxUnits in mpas_io_units.F') + open(land_unit,file='LANDUSE.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine landuse_init_forMPAS: ' // & @@ -204,13 +209,16 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu therin(ic,is),scfx(ic,is),sfhc(ic,is) enddo ! do ic = 1, lucats -! call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/ic/), & +! call mpas_log_write('$i $r $r $r $r $r $r $r', intArgs=(/ic/), & ! realArgs=(/albd(ic,is),slmo(ic,is),sfem(ic,is),sfz0(ic,is), & ! therin(ic,is),scfx(ic,is),sfhc(ic,is)/)) ! enddo ! if(is .lt. luseas) call mpas_log_write('') enddo + close(land_unit) + call mpas_release_unit(land_unit) + !defines the index isurban as a function of sfc_input_data: sfc_input_select: select case(trim(lutype)) case('OLD') @@ -286,7 +294,6 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu if(xice(iCell) .ge. xice_threshold) then albbck(iCell) = albd(isice,isn) / 100. embck(iCell) = sfem(isice,isn) - sfc_albedo_seaice(iCell) = albbck(iCell) if(config_frac_seaice) then !0.08 is the albedo over open water. !0.98 is the emissivity over open water. @@ -301,9 +308,6 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu znt(iCell) = z0(iCell) if(associated(mavail)) mavail(iCell) = slmo(isice,isn) - else - !over seaice-free cells, initialize sfc_albedo_seaice with the background surface albedo: - sfc_albedo_seaice(iCell) = albbck(iCell) endif enddo diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F index 1f85b7de07..07481fd6ff 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F @@ -16,6 +16,7 @@ module mpas_atmphys_lsm_noahinit use mpas_dmpar use mpas_kind_types use mpas_pool_routines + use mpas_io_units use mpas_atmphys_constants use mpas_atmphys_utilities @@ -214,11 +215,13 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) character(len=*),intent(inout):: mminlu, mminsl !local variables: - character*128:: mess , message + character*128:: mess,message + character*128:: astring - integer,parameter:: open_ok = 0 + integer,parameter:: open_ok = 0 + integer,parameter:: loop_max = 10 integer:: lumatch,iindex,lc,num_slope - integer:: istat + integer:: istat,loop_count,read_unit !-----SPECIFY VEGETATION RELATED CHARACTERISTICS : !ALBBCK: SFC albedo (in percentage) @@ -249,16 +252,23 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !read in the vegetation properties from vegparm.tbl: if(dminfo % my_proc_id == IO_NODE) then - open(16,file='VEGPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) + !get a unit to open init file: + call mpas_new_unit(read_unit) + if ( read_unit < 0 ) & + call physics_error_fatal('soil_veg_gen_parm: All file units are taken. Change maxUnits in mpas_io_units.F') + + open(read_unit,file='VEGPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine soil_veg_gen_arm: ' // & 'failure opening VEGPARM.TBL') lumatch=0 + + loop_count = 0 + read(read_unit,fmt='(A)',end=2002) astring find_lutype : do while (lumatch == 0) - read(16,*,end=2002) - read(16,*,end=2002) lutype - read(16,*) lucats,iindex + read(read_unit,*,end=2002) lutype + read(read_unit,*) lucats,iindex if(lutype.eq.trim(mminlu))then write(mess,*) ' landuse type = ' // trim ( lutype ) // ' found', & @@ -266,10 +276,17 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) call physics_message(mess) lumatch=1 else + loop_count = loop_count + 1 call physics_message(' skipping over lutype = ' // trim ( lutype )) - do lc = 1, lucats+20 - read(16,*) - enddo + + find_vegetation_parameter_flag: do + read(read_unit,fmt='(A)',end=2002) astring + if(astring(1:21) .eq. 'Vegetation Parameters') then + exit find_vegetation_parameter_flag + elseif(loop_count .ge. loop_max) then + call physics_error_fatal('too many loops in VEGPARM.TBL') + endif + enddo find_vegetation_parameter_flag endif enddo find_lutype @@ -296,35 +313,52 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) if(lutype.eq.mminlu)then do lc = 1, lucats - read(16,*) iindex,shdtbl(lc),nrotbl(lc),rstbl(lc),rgltbl(lc),hstbl(lc),snuptbl(lc), & + read(read_unit,*) iindex,shdtbl(lc),nrotbl(lc),rstbl(lc),rgltbl(lc),hstbl(lc),snuptbl(lc), & maxalb(lc),laimintbl(lc),laimaxtbl(lc),emissmintbl(lc),emissmaxtbl(lc), & albedomintbl(lc),albedomaxtbl(lc),z0mintbl(lc),z0maxtbl(lc),ztopvtbl(lc), & zbotvtbl(lc) enddo - read (16,*) - read (16,*)topt_data - read (16,*) - read (16,*)cmcmax_data - read (16,*) - read (16,*)cfactr_data - read (16,*) - read (16,*)rsmax_data - read (16,*) - read (16,*)bare - read (16,*) - read (16,*)natural - read (16,*) - read (16,*) - read (16,*) - read (16,*)low_density_residential - read (16,*) - read (16,*)high_density_residential - read (16,*) - read (16,*)high_intensity_industrial + + read (read_unit,*) + read (read_unit,*)topt_data + read (read_unit,*) + read (read_unit,*)cmcmax_data + read (read_unit,*) + read (read_unit,*)cfactr_data + read (read_unit,*) + read (read_unit,*)rsmax_data + read (read_unit,*) + read (read_unit,*)bare + read (read_unit,*) + read (read_unit,*)natural + read (read_unit,*) + read (read_unit,*) + read (read_unit,*) + read (read_unit,*)lcz_1 + read (read_unit,*) + read (read_unit,*)lcz_2 + read (read_unit,*) + read (read_unit,*)lcz_3 + read (read_unit,*) + read (read_unit,*)lcz_4 + read (read_unit,*) + read (read_unit,*)lcz_5 + read (read_unit,*) + read (read_unit,*)lcz_6 + read (read_unit,*) + read (read_unit,*)lcz_7 + read (read_unit,*) + read (read_unit,*)lcz_8 + read (read_unit,*) + read (read_unit,*)lcz_9 + read (read_unit,*) + read (read_unit,*)lcz_10 + read (read_unit,*) + read (read_unit,*)lcz_11 endif 2002 continue - close (16) + close (read_unit) if(lumatch == 0) & call physics_error_fatal ('land use dataset '''//mminlu//''' not found in VEGPARM.TBL.') @@ -358,9 +392,17 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) DM_BCAST_REAL(rsmax_data) DM_BCAST_INTEGER(bare) DM_BCAST_INTEGER(natural) - DM_BCAST_INTEGER(low_density_residential) - DM_BCAST_INTEGER(high_density_residential) - DM_BCAST_INTEGER(high_intensity_industrial) + DM_BCAST_INTEGER(lcz_1) + DM_BCAST_INTEGER(lcz_2) + DM_BCAST_INTEGER(lcz_3) + DM_BCAST_INTEGER(lcz_4) + DM_BCAST_INTEGER(lcz_5) + DM_BCAST_INTEGER(lcz_6) + DM_BCAST_INTEGER(lcz_7) + DM_BCAST_INTEGER(lcz_8) + DM_BCAST_INTEGER(lcz_9) + DM_BCAST_INTEGER(lcz_10) + DM_BCAST_INTEGER(lcz_11) !call mpas_log_write(' LUTYPE = '//trim(lutype)) !call mpas_log_write(' LUCATS = $i',intArgs=(/lucats/)) @@ -373,23 +415,31 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !call mpas_log_write(' RSMAX_DATA = $r',realArgs=(/rsmax_data/)) !call mpas_log_write(' BARE = $i',intArgs=(/bare/)) !call mpas_log_write(' NATURAL = $i',intArgs=(/natural/)) -!call mpas_log_write(' LOW_DENSITY_RESIDENTIAL = $i , intArgs=(/low_density_residential/)) -!call mpas_log_write(' HIGH_DENSITY_RESIDENTIAL = $i , intArgs=(/high_density_residential/)) -!call mpas_log_write(' HIGH_DENSITY_INDUSTRIAL = $i , intArgs=(/high_density_industrial/)) +!call mpas_log_write(' LCZ_1 = $i', intArgs=(/lcz_1/)) +!call mpas_log_write(' LCZ_2 = $i', intArgs=(/lcz_2/)) +!call mpas_log_write(' LCZ_3 = $i', intArgs=(/lcz_3/)) +!call mpas_log_write(' LCZ_4 = $i', intArgs=(/lcz_4/)) +!call mpas_log_write(' LCZ_5 = $i', intArgs=(/lcz_5/)) +!call mpas_log_write(' LCZ_6 = $i', intArgs=(/lcz_6/)) +!call mpas_log_write(' LCZ_7 = $i', intArgs=(/lcz_7/)) +!call mpas_log_write(' LCZ_8 = $i', intArgs=(/lcz_8/)) +!call mpas_log_write(' LCZ_9 = $i', intArgs=(/lcz_9/)) +!call mpas_log_write(' LCZ_10 = $i', intArgs=(/lcz_10/)) +!call mpas_log_write(' LCZ_11 = $i', intArgs=(/lcz_11/)) !call mpas_log_write('') !do lc = 1, lucats ! call mpas_log_write('$i $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r', intArgs=(/lc/), & ! realArgs=(/shdtbl(lc),float(nrotbl(lc)),rstbl(lc),rgltbl(lc),hstbl(lc),snuptbl(lc), & ! maxalb(lc),laimintbl(lc),laimaxtbl(lc),emissmintbl(lc),emissmaxtbl(lc), & ! albedomintbl(lc),albedomaxtbl(lc),z0mintbl(lc),z0maxtbl(lc),ztopvtbl(lc), & -! zbottvtbl(lc)/)) +! zbotvtbl(lc)/)) !enddo call mpas_log_write(' end read VEGPARM.TBL') !read in soil properties from soilparm.tbl: if(dminfo % my_proc_id == IO_NODE) then - open(16,file='SOILPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) + open(read_unit,file='SOILPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('module_sf_noahlsm.F: soil_veg_gen_parm: ' // & 'failure opening SOILPARM.TBL' ) @@ -398,10 +448,10 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) call physics_message(mess) lumatch=0 - read(16,*) - read(16,2000,end=2003) sltype + read(read_unit,*) + read(read_unit,2000,end=2003) sltype 2000 format(a4) - read(16,*)slcats,iindex + read(read_unit,*)slcats,iindex if(sltype.eq.mminsl)then write(mess,*) ' soil texture classification = ', trim ( sltype ) , ' found', & slcats,' categories' @@ -424,13 +474,13 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) endif if(sltype.eq.mminsl) then do lc = 1, slcats - read(16,*) iindex,bb(lc),drysmc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & + read(read_unit,*) iindex,bb(lc),drysmc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & satdk(lc),satdw(lc),wltsmc(lc),qtz(lc) enddo endif 2003 continue - close(16) + close(read_unit) if(lumatch.eq.0)then call physics_message( 'soil texture in input file does not ' ) call physics_message( 'match soilparm table' ) @@ -472,13 +522,13 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !read in general parameters from genparm.tbl: if(dminfo % my_proc_id == IO_NODE) then - open(16,file='GENPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) + open(read_unit,file='GENPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('module_sf_noahlsm.F: soil_veg_gen_parm: ' // & 'failure opening GENPARM.TBL' ) - read(16,*) - read(16,*) - read(16,*) num_slope + read(read_unit,*) + read(read_unit,*) + read(read_unit,*) num_slope slpcats=num_slope !prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008: @@ -487,33 +537,34 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) 'in module_sf_noahdrv') do lc = 1, slpcats - read(16,*)slope_data(lc) + read(read_unit,*)slope_data(lc) enddo - read(16,*) - read(16,*)sbeta_data - read(16,*) - read(16,*)fxexp_data - read(16,*) - read(16,*)csoil_data - read(16,*) - read(16,*)salp_data - read(16,*) - read(16,*)refdk_data - read(16,*) - read(16,*)refkdt_data - read(16,*) - read(16,*)frzk_data - read(16,*) - read(16,*)zbot_data - read(16,*) - read(16,*)czil_data - read(16,*) - read(16,*)smlow_data - read(16,*) - read(16,*)smhigh_data - read(16,*) - read(16,*)lvcoef_data - close(16) + read(read_unit,*) + read(read_unit,*)sbeta_data + read(read_unit,*) + read(read_unit,*)fxexp_data + read(read_unit,*) + read(read_unit,*)csoil_data + read(read_unit,*) + read(read_unit,*)salp_data + read(read_unit,*) + read(read_unit,*)refdk_data + read(read_unit,*) + read(read_unit,*)refkdt_data + read(read_unit,*) + read(read_unit,*)frzk_data + read(read_unit,*) + read(read_unit,*)zbot_data + read(read_unit,*) + read(read_unit,*)czil_data + read(read_unit,*) + read(read_unit,*)smlow_data + read(read_unit,*) + read(read_unit,*)smhigh_data + read(read_unit,*) + read(read_unit,*)lvcoef_data + close(read_unit) + call mpas_release_unit(read_unit) endif DM_BCAST_INTEGER(num_slope) diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index fe8ee5c27c..1056896f8c 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -124,6 +124,8 @@ module mpas_atmphys_manager ! * in subroutine physics_run_init, removed the initialization of the local variable microp_scheme. ! microp_scheme is no longer needed and can be replaced with config_microp_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. contains @@ -672,7 +674,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) num_months = nMonths num_soils = nSoilLevels - if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 + if(trim(config_lsm_scheme) .eq. "sf_noah") sf_surface_physics = 2 !initialization of local physics time-steps: !... dynamics: diff --git a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F index 04d4f7f5bc..2c0497e168 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F +++ b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F @@ -12,6 +12,7 @@ module mpas_atmphys_o3climatology use mpas_atmphys_date_time use mpas_atmphys_constants use mpas_atmphys_utilities + use mpas_io_units, only: mpas_new_unit, mpas_release_unit !wrf physics: use module_ra_cam_support, only: r8, getfactors @@ -74,9 +75,7 @@ subroutine init_o3climatology(mesh,atm_input) real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: - integer,parameter:: pin_unit = 27 - integer,parameter:: lat_unit = 28 - integer,parameter:: oz_unit = 29 + integer :: pin_unit, lat_unit, oz_unit integer,parameter:: open_ok = 0 integer:: i,i1,i2,istat,k,j,m @@ -100,6 +99,7 @@ subroutine init_o3climatology(mesh,atm_input) call mpas_pool_get_array(mesh,'lonCell',lonCell) !-- read in ozone pressure data: + call mpas_new_unit(pin_unit) open(pin_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & @@ -108,8 +108,10 @@ subroutine init_o3climatology(mesh,atm_input) read(pin_unit,*) pin(k) enddo close(pin_unit) + call mpas_release_unit(pin_unit) !-- read in ozone lat data: + call mpas_new_unit(lat_unit) open(lat_unit, file='OZONE_LAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & @@ -119,8 +121,10 @@ subroutine init_o3climatology(mesh,atm_input) ! call mpas_log_write('$i $r', intArgs=(/j/), realArgs=(/lat_ozone(j)/)) enddo close(lat_unit) + call mpas_release_unit(lat_unit) !-- read in ozone data: + call mpas_new_unit(oz_unit) open(oz_unit,file='OZONE_DAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & @@ -137,6 +141,7 @@ subroutine init_o3climatology(mesh,atm_input) enddo enddo close(oz_unit) + call mpas_release_unit(oz_unit) !INTERPOLATION OF INPUT OZONE DATA TO MPAS GRID: !call mpas_log_write('max latCell=$r', realArgs=(/maxval(latCell)/degrad/)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F index 2ba79151f1..3e546e2a3a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F @@ -15,6 +15,7 @@ module mpas_atmphys_rrtmg_lwinit use mpas_atmphys_constants use mpas_atmphys_utilities use mpas_log, only : mpas_log_write + use mpas_io_units !wrf physics use module_ra_rrtmg_lw @@ -71,16 +72,9 @@ subroutine rrtmg_lwlookuptable(dminfo) !----------------------------------------------------------------------------------------------------------------- !get a unit to open init file: - istat = -999 if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened ) then - rrtmg_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(rrtmg_unit, unformatted = .true.) + if(rrtmg_unit < 0) & call physics_error_fatal('module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// & 'find unused fortran unit to read in lookup table.' ) @@ -121,7 +115,10 @@ subroutine rrtmg_lwlookuptable(dminfo) call lw_kgb15(rrtmg_unit,dminfo) call lw_kgb16(rrtmg_unit,dminfo) - if(dminfo % my_proc_id == IO_NODE) close(rrtmg_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(rrtmg_unit) + call mpas_release_unit(rrtmg_unit) + end if end subroutine rrtmg_lwlookuptable diff --git a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F index 7811454bd2..7ad8284e41 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F @@ -17,6 +17,7 @@ module mpas_atmphys_rrtmg_swinit use mpas_atmphys_constants use mpas_atmphys_utilities use mpas_log, only : mpas_log_write + use mpas_io_units !wrf physics use module_ra_rrtmg_sw @@ -73,14 +74,8 @@ subroutine rrtmg_swlookuptable(dminfo) !get a unit to open init file: if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened) then - rrtmg_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(rrtmg_unit, unformatted = .true.) + if(rrtmg_unit < 0) & call physics_error_fatal('module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// & 'find unused fortran unit to read in lookup table.' ) endif @@ -120,7 +115,10 @@ subroutine rrtmg_swlookuptable(dminfo) call sw_kgb28(rrtmg_unit,dminfo) call sw_kgb29(rrtmg_unit,dminfo) - if(dminfo % my_proc_id == IO_NODE) close(rrtmg_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(rrtmg_unit) + call mpas_release_unit(rrtmg_unit) + end if end subroutine rrtmg_swlookuptable diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index c7baeb213a..6d5b9bba13 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -43,21 +43,34 @@ module mpas_atmphys_todynamics ! Laura D. Fowler (laura@ucar.edu) / 2016-03-22. ! * modified the sourcecode to accomodate the packages "cu_kain_fritsch_in" and "cu_tiedtke_in". ! Laura D. Fowler (laura@ucar.edu) / 2016-03-24. -! * added the calculation of rthdynten which is the tendency of potential temperature due to horizontal and -! vertical advections needed in the Grell-Freitas scheme. -! Laura D. Fowler (laura@ucar.edu) / 2016-03-30. ! * added the option bl_mynn for the calculation of the tendency for the cloud ice number concentration. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-11. ! * in subroutine physics_get_tend_work, added the option cu_ntiedtke in the calculation of rucuten_Edge. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-28. + ! + ! Abstract interface for routine used to communicate halos of fields + ! in a named group + ! + abstract interface + subroutine halo_exchange_routine(domain, halo_group, ierr) + + use mpas_derived_types, only : domain_type + + type (domain_type), intent(inout) :: domain + character(len=*), intent(in) :: halo_group + integer, intent(out), optional :: ierr + + end subroutine halo_exchange_routine + end interface + contains !================================================================================================================= subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, configs, rk_step, dynamics_substep, & - tend_ru_physics, tend_rtheta_physics, tend_rho_physics ) + tend_ru_physics, tend_rtheta_physics, tend_rho_physics, exchange_halo_group ) !================================================================================================================= use mpas_atm_dimensions @@ -69,6 +82,7 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi type(mpas_pool_type),intent(in):: configs integer, intent(in):: rk_step integer, intent(in):: dynamics_substep + procedure (halo_exchange_routine) :: exchange_halo_group !inout variables: type(mpas_pool_type),intent(inout):: diag @@ -97,11 +111,9 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi rqrcuten,rqicuten,rqscuten, & rucuten,rvcuten real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw - real(kind=RKIND),dimension(:,:),pointer:: rthdynten - real(kind=RKIND),dimension(:,:),pointer:: tend_rtheta_adv real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys !nick - real(kind=RKIND),dimension(:,:),pointer :: tend_theta,tend_theta_euler,tend_diabatic,tend_u + real(kind=RKIND),dimension(:,:),pointer :: tend_theta,tend_theta_euler,tend_u real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars real(kind=RKIND):: coeff @@ -127,8 +139,6 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi call mpas_pool_get_array(state, 'rho_zz', mass, 2) call mpas_pool_get_array(diag , 'rho_edge', mass_edge) - call mpas_pool_get_array(diag , 'tend_rtheta_adv', tend_rtheta_adv) - call mpas_pool_get_array(diag , 'tend_u_phys', tend_u_phys) !nick call mpas_pool_get_dimension(state, 'index_qv', index_qv) @@ -157,9 +167,6 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi call mpas_pool_get_array(tend_physics, 'rqrcuten', rqrcuten) call mpas_pool_get_array(tend_physics, 'rqicuten', rqicuten) call mpas_pool_get_array(tend_physics, 'rqscuten', rqscuten) - call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - - call mpas_pool_get_array(tend,'rt_diabatic_tend',tend_diabatic) call mpas_pool_get_array(tend_physics, 'rthratenlw', rthratenlw) call mpas_pool_get_array(tend_physics, 'rthratensw', rthratensw) @@ -192,7 +199,6 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi if (.not. associated(rqrcuten)) allocate(rqrcuten(0,0)) if (.not. associated(rqscuten)) allocate(rqscuten(0,0)) if (.not. associated(rniblten)) allocate(rniblten(0,0)) - if (.not. associated(rthdynten)) allocate(rthdynten(0,0)) if (.not. associated(rublten)) allocate(rublten(0,0)) if (.not. associated(rvblten)) allocate(rvblten(0,0)) if (.not. associated(rthblten)) allocate(rthblten(0,0)) @@ -213,11 +219,12 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi rucuten, rvcuten, rucuten_Edge, & tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rniblten, & rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & - rthratenlw, rthratensw, rthdynten, & - tend_u_phys, tend_rtheta_adv, tend_diabatic, & + rthratenlw, rthratensw, & + tend_u_phys, & theta_m, scalars, & tend_rtheta_physics, & - tend_theta_euler & + tend_theta_euler, & + exchange_halo_group & ) ! @@ -229,7 +236,6 @@ subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, confi if (size(rqrcuten) == 0) deallocate(rqrcuten) if (size(rqscuten) == 0) deallocate(rqscuten) if (size(rniblten) == 0) deallocate(rniblten) - if (size(rthdynten) == 0) deallocate(rthdynten) if (size(rublten) == 0) deallocate(rublten) if (size(rvblten) == 0) deallocate(rvblten) if (size(rthblten) == 0) deallocate(rthblten) @@ -270,9 +276,10 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge rucuten, rvcuten, rucuten_Edge, & tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rniblten, & rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & - rthratenlw, rthratensw, rthdynten, & - tend_u_phys, tend_rtheta_adv, tend_diabatic, & - theta_m, scalars, tend_theta, tend_theta_euler & + rthratenlw, rthratensw, & + tend_u_phys, & + theta_m, scalars, tend_theta, tend_theta_euler, & + exchange_halo_group & ) !================================================================================================== @@ -313,14 +320,12 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqscuten real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthratenlw real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthratensw - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: rthdynten real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: tend_u_phys - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_rtheta_adv - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_diabatic real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_theta_euler + procedure (halo_exchange_routine) :: exchange_halo_group integer :: i, k real (kind=RKIND) :: coeff @@ -328,6 +333,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge !add coupled tendencies due to PBL processes: if (config_pbl_scheme .ne. 'off') then if (rk_step == 1 .and. dynamics_substep == 1) then + call exchange_halo_group(block % domain, 'physics:blten') call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) !MGD for PV budget? should a similar line be in the cumulus section below? @@ -388,6 +394,7 @@ subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdge case('cu_tiedtke','cu_ntiedtke') if (rk_step == 1 .and. dynamics_substep == 1) then + call exchange_halo_group(block % domain, 'physics:cuten') call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & @@ -448,14 +455,11 @@ subroutine tend_toEdges(block,mesh,Ux_tend,Uy_tend,U_tend) real(kind=RKIND),intent(out),dimension(:,:):: U_tend !local variables: - type (field2DReal), pointer :: tempField - type (field2DReal), target :: tempFieldTarget integer:: iCell,iEdge,k,j integer:: cell1, cell2 integer,pointer:: nCells,nCellsSolve,nEdges integer,dimension(:,:),pointer:: cellsOnEdge - real(kind=RKIND),dimension(:,:),pointer:: Ux_tend_halo,Uy_tend_halo real(kind=RKIND), dimension(:,:), pointer :: east, north, edgeNormalVectors @@ -471,42 +475,22 @@ subroutine tend_toEdges(block,mesh,Ux_tend,Uy_tend,U_tend) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - Ux_tend_halo => Ux_tend - Uy_tend_halo => Uy_tend - - tempField => tempFieldTarget - tempField % block => block - tempField % dimSizes(1) = nVertLevels - tempField % dimSizes(2) = nCellsSolve - tempField % sendList => block % parinfo % cellsToSend - tempField % recvList => block % parinfo % cellsToRecv - tempField % copyList => block % parinfo % cellsToCopy - tempField % prev => null() - tempField % next => null() - tempField % isActive = .true. - - tempField % array => Ux_tend_halo - call mpas_dmpar_exch_halo_field(tempField) - - tempField % array => Uy_tend_halo - call mpas_dmpar_exch_halo_field(tempField) - do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - U_tend(:,iEdge) = Ux_tend_halo(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell1) & - + edgeNormalVectors(2,iEdge) * east(2,cell1) & - + edgeNormalVectors(3,iEdge) * east(3,cell1)) & - + Uy_tend_halo(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell1) & - + edgeNormalVectors(2,iEdge) * north(2,cell1) & - + edgeNormalVectors(3,iEdge) * north(3,cell1)) & - + Ux_tend_halo(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell2) & - + edgeNormalVectors(2,iEdge) * east(2,cell2) & - + edgeNormalVectors(3,iEdge) * east(3,cell2)) & - + Uy_tend_halo(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell2) & - + edgeNormalVectors(2,iEdge) * north(2,cell2) & - + edgeNormalVectors(3,iEdge) * north(3,cell2)) + U_tend(:,iEdge) = Ux_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell1) & + + edgeNormalVectors(2,iEdge) * east(2,cell1) & + + edgeNormalVectors(3,iEdge) * east(3,cell1)) & + + Uy_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell1) & + + edgeNormalVectors(2,iEdge) * north(2,cell1) & + + edgeNormalVectors(3,iEdge) * north(3,cell1)) & + + Ux_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell2) & + + edgeNormalVectors(2,iEdge) * east(2,cell2) & + + edgeNormalVectors(3,iEdge) * east(3,cell2)) & + + Uy_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell2) & + + edgeNormalVectors(2,iEdge) * north(2,cell2) & + + edgeNormalVectors(3,iEdge) * north(3,cell2)) end do end subroutine tend_toEdges diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 28c72579f5..985d46111e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -110,6 +110,18 @@ module mpas_atmphys_vars ! * added the local variables cosa_p and sina_p needed in call to subroutine gwdo after updating module_bl_gwdo.F ! to that of WRF version 4.0.2 ! Laura D. Fowler (laura@ucar.edu) / 2019-01-30. +! * reverted the option seaice_albedo_opt = 2 to seaic_albedo_opt = 0 since MPAS does not currently support the +! input of "observed" 2D seaice albedos. In conjunction with this update, we also change the initialization of +! albsi from albbck to seaice_albedo_default. +! Laura D. Fowler (laura@ucar.edu) / 2022-05-10. +! * added the local parameters flag_bep and idiff in the call to subroutine ysu to update the YSU PBL scheme to +! that of WRF version 4.4.1. +! * added local flags and variables needed to initialize and run the revised version of the MONIN-OBUKHOV surface +! layer scheme from the WRF version 4.4.1. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. +! * added the local variables swddir,swddni,and swddif which are output to subroutine rrtmg_swrad and now input +! to the updated module_sf_noahdrv.F. +! Laura D. Fowler (laura@ucar.edu) / 2023-04-21. !================================================================================================================= @@ -344,6 +356,14 @@ module mpas_atmphys_vars !... variables and arrays related to parameterization of pbl: !================================================================================================================= + logical,parameter:: & + flag_bep = .false. !flag to use BEP/BEP+BEM for use in the YSU PBL scheme (with urban physics). since we do + !not run urban physics, flag_bep is always set to false. + + integer,parameter:: & + idiff = 0 !BEP/BEM+BEM diffusion flag for use in the YSU PBL scheme (with urban physics). since we + !do not run urban physics, idiff is set to zero. + integer:: ysu_pblmix integer,dimension(:,:),allocatable:: & @@ -475,6 +495,26 @@ module mpas_atmphys_vars fh_p, &!integrated stability function for heat [-] fm_p !integrated stability function for momentum [-] +!... variables and arrays only in the revised version of monin_obukhov (module_sf_sfclayrev.F) to include the +! shallow water roughness scheme: + integer,parameter:: & + bathymetry_flag = 0!this flag is set to 1 if input bathymetry data is available (this option is not available + !in MPAS and therefore set to 0 by default. + integer,parameter:: & + shalwater_flag = 0!this flag is set to 1 to run the shallow water roughness scheme (this option is not + !available in MPAS and therefore set to 0 by default. + integer,parameter:: & + lakemodel_flag = 0!this flag is set to 1 to run the lake model physics (this option is not available in MPAS + !and therefore set to 0 by default. + + real(kind=RKIND),parameter:: & + shalwater_depth = 0!constant shallow water depth needed to run the shallow water roughness scheme. + + real(kind=RKIND),dimension(:,:),allocatable:: & + waterdepth_p, &!depth of water needed to run the shallow water roughness scheme. + lakedepth_p, &!depth of lakes needed to run the lake model physics. + lakemask_p !mask needed to detect the location of lakes to run the lake model physics. + !... arrays only in mynn surface layer scheme (module_sf_mynn.F): real(kind=RKIND),dimension(:,:),allocatable:: & ch_p, &!surface exchange coeff for heat [m/s] @@ -489,10 +529,12 @@ module mpas_atmphys_vars !================================================================================================================= !... variables and arrays related to parameterization of seaice: +!... the options set for seaice_albedo_opt, seaice_thickness_opt, and seaicesnowdepth_opt must not be changed +! since they are the only ones currently available. !================================================================================================================= integer,parameter:: & - seaice_albedo_opt = 2 !option to set albedo over sea ice. + seaice_albedo_opt = 0 !option to set albedo over sea ice. !0 = seaice albedo is constant set in seaice_albedo_default. !1 = seaice albedo is f(Tair,Tskin,Tsnow), following Mill (2011). !2 = seaice albedo is read in from input variable albsi. @@ -542,6 +584,11 @@ module mpas_atmphys_vars swnirdir_p, &!near-IR direct downward flux [W m-2] swnirdif_p !near-IR diffuse downward flux [W m-2] + real(kind=RKIND),dimension(:,:),allocatable:: & + swddir_p, &! + swddni_p, &! + swddif_p ! + real(kind=RKIND),dimension(:,:,:),allocatable:: & swdnflx_p, &! swdnflxc_p, &! @@ -641,7 +688,7 @@ module mpas_atmphys_vars !================================================================================================================= logical,parameter:: & - ua_phys=.false. !option to activate UA Noah changes: a different snow-cover physics in the land-surface + ua_phys = .false. !option to activate UA Noah changes: a different snow-cover physics in the land-surface !scheme. That option is not currently implemented in MPAS. integer,parameter:: & @@ -652,6 +699,9 @@ module mpas_atmphys_vars integer,parameter:: & fasdas = 0 !for WRF surface data assimilation system (not used in MPAS). + integer,parameter:: & + nurb = 1 !generic dimension for all dimensions needed to run the urban physics. + integer,public:: & sf_surface_physics !used to define the land surface scheme by a number instead of name. It !is only needed in module_ra_rrtmg_sw.F to define the spectral surface @@ -720,13 +770,6 @@ module mpas_atmphys_vars frc_urb_p, &!urban fraction [-] ust_urb_p !urban u* in similarity theory [m/s] -!.. arrays needed in the argument list in the call to the Noah LSM hydrology model: note that these arrays are -!.. initialized to zero since we do not run a hydrology model: - real(kind=RKIND),dimension(:,:),allocatable:: & - infxsrt_p, &!timestep infiltration excess [mm] - sfcheadrt_p, &!surface water detph [mm] - soldrain_p !soil column drainage [mm] - !================================================================================================================= !.. variables and arrays related to surface characteristics: !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/Makefile b/src/core_atmosphere/physics/physics_mmm/Makefile new file mode 100644 index 0000000000..0af279de6c --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/Makefile @@ -0,0 +1,41 @@ +.SUFFIXES: .F .o + +all: dummy physics_mmm + +dummy: + echo "****** compiling physics_mmm ******" + +OBJS = \ + bl_gwdo.o \ + bl_ysu.o \ + cu_ntiedtke.o \ + sf_sfclayrev.o \ + module_libmassv.o \ + mp_radar.o \ + mp_wsm6_effectRad.o \ + mp_wsm6.o + +physics_mmm: $(OBJS) + ar -ru ./../libphys.a $(OBJS) + +# DEPENDENCIES: +mp_wsm6_effectRad.o: \ + mp_wsm6.o + +mp_wsm6.o: \ + mp_radar.o \ + module_libmassv.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F.o: +ifeq "$(GEN_F90)" "true" + $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 +else + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 +endif diff --git a/src/core_atmosphere/physics/physics_mmm/bl_gwdo.F b/src/core_atmosphere/physics/physics_mmm/bl_gwdo.F new file mode 100644 index 0000000000..dfb337091c --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/bl_gwdo.F @@ -0,0 +1,659 @@ +module bl_gwdo +use ccpp_kinds,only: kind_phys +!=============================================================================== + IMPLICIT NONE + PRIVATE + PUBLIC :: bl_gwdo_run + PUBLIC :: bl_gwdo_init + PUBLIC :: bl_gwdo_final + PUBLIC :: bl_gwdo_timestep_init + PUBLIC :: bl_gwdo_timestep_final + +contains +!------------------------------------------------------------------------------- +!------------------------------------------------------------------------------- + subroutine bl_gwdo_run(sina, cosa, & + rublten,rvblten, & + dtaux3d,dtauy3d, & + dusfcg,dvsfcg, & + uproj, vproj, & + t1, q1, & + prsi, prsl, prslk, zl, & + var, oc1, & + oa2d1, oa2d2, & + oa2d3, oa2d4, & + ol2d1, ol2d2, & + ol2d3, ol2d4, & + g_, cp_, rd_, rv_, fv_, pi_, & + dxmeter, deltim, & + its, ite, kte, kme, & + errmsg, errflg ) +!------------------------------------------------------------------------------- +! +! abstract : +! this code handles the time tendencies of u v due to the effect of +! mountain induced gravity wave drag from sub-grid scale orography. +! this routine not only treats the traditional upper-level wave breaking due +! to mountain variance (alpert 1988), but also the enhanced +! lower-tropospheric wave breaking due to mountain convexity and asymmetry +! (kim and arakawa 1995). thus, in addition to the terrain height data +! in a model grid gox, additional 10-2d topographic statistics files are +! needed, including orographic standard deviation (var), convexity (oc1), +! asymmetry (oa4) and ol (ol4). these data sets are prepared based on the +! 30 sec usgs orography (hong 1999). the current scheme was implmented as in +! choi and hong (2015), which names kim gwdo since it was developed by +! kiaps staffs for kiaps integrated model system (kim). the scheme +! additionally includes the effects of orographic anisotropy and +! flow-blocking drag. +! coded by song-you hong and young-joon kim and implemented by song-you hong +! +! history log : +! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy +! +! references : +! choi and hong (2015), j. geophys. res. +! hong et al. (2008), wea. forecasting +! kim and doyle (2005), q. j. r. meteor. soc. +! kim and arakawa (1995), j. atmos. sci. +! alpet et al. (1988), NWP conference +! hong (1999), NCEP office note 424 +! +! input : +! dudt, dvdt - non-lin tendency for u and v wind component +! uproj, vproj - projection-relative U and V m/sec +! u1, v1 - zonal and meridional wind m/sec at t0-dt +! t1 - temperature deg k at t0-dt +! q1 - mixing ratio at t0-dt +! deltim - time step (s) +! del - positive increment of pressure across layer (pa) +! prslk, zl, prsl, prsi - pressure and height variables +! oa4, ol4, omax, var, oc1 - orographic statistics +! +! output : +! dudt, dvdt - wind tendency due to gwdo +! dtaux2d, dtauy2d - diagnoised orographic gwd +! dusfc, dvsfc - gw stress +! +!------------------------------------------------------------------------------- + use ccpp_kinds, only: kind_phys + implicit none +! + integer, parameter :: kts = 1 + integer , intent(in ) :: its, ite, kte, kme + real(kind=kind_phys) , intent(in ) :: g_, pi_, rd_, rv_, fv_,& + cp_, deltim + real(kind=kind_phys), dimension(its:ite) , intent(in ) :: dxmeter + real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(inout) :: rublten, rvblten + real(kind=kind_phys), dimension(its:ite,kts:kte) , intent( out) :: dtaux3d, dtauy3d + real(kind=kind_phys), dimension(its:ite) , intent( out) :: dusfcg, dvsfcg + real(kind=kind_phys), dimension(its:ite) , intent(in ) :: sina, cosa + real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(in ) :: uproj, vproj + real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(in ) :: t1, q1, prslk, zl +! + real(kind=kind_phys), dimension(its:ite,kts:kte) , intent(in ) :: prsl + real(kind=kind_phys), dimension(its:ite,kts:kme) , intent(in ) :: prsi +! + real(kind=kind_phys), dimension(its:ite) , intent(in ) :: var, oc1, & + oa2d1, oa2d2, oa2d3, oa2d4, & + ol2d1, ol2d2, ol2d3, ol2d4 + character(len=*) , intent( out) :: errmsg + integer , intent( out) :: errflg +! + real(kind=kind_phys), parameter :: ric = 0.25 ! critical richardson number + real(kind=kind_phys), parameter :: dw2min = 1. + real(kind=kind_phys), parameter :: rimin = -100. + real(kind=kind_phys), parameter :: bnv2min = 1.0e-5 + real(kind=kind_phys), parameter :: efmin = 0.0 + real(kind=kind_phys), parameter :: efmax = 10.0 + real(kind=kind_phys), parameter :: xl = 4.0e4 + real(kind=kind_phys), parameter :: critac = 1.0e-5 + real(kind=kind_phys), parameter :: gmax = 1. + real(kind=kind_phys), parameter :: veleps = 1.0 + real(kind=kind_phys), parameter :: frc = 1.0 + real(kind=kind_phys), parameter :: ce = 0.8 + real(kind=kind_phys), parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 +! +! local variables +! + integer :: kpblmax + integer :: latd,lond + integer :: i,k,lcap,lcapp1,nwd,idir, & + klcap,kp1,ikount,kk +! + real(kind=kind_phys) :: fdir,cs,rcsks, & + wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & + wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & + temv,dtaux,dtauy +! + real(kind=kind_phys), dimension(its:ite,kts:kte) :: dudt, dvdt + real(kind=kind_phys), dimension(its:ite,kts:kte) :: dtaux2d, dtauy2d + real(kind=kind_phys), dimension(its:ite) :: dusfc, dvsfc + logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 + real(kind=kind_phys), dimension(its:ite) :: coefm +! + real(kind=kind_phys), dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & + ulow, rulow, bnv, oa, ol, rhobar, & + dtfac, brvf, xlinv, delks,delks1, & + zlowtop,cleff + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taup + real(kind=kind_phys), dimension(its:ite,kts:kte-1) :: velco + real(kind=kind_phys), dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj + real(kind=kind_phys), dimension(its:ite,kts:kte) :: del + real(kind=kind_phys), dimension(its:ite,kts:kte) :: u1, v1 + real(kind=kind_phys), dimension(its:ite,4) :: oa4, ol4 +! + integer, dimension(its:ite) :: kbl, klowtop + integer, parameter :: mdir=8 + integer, dimension(mdir) :: nwdir + data nwdir/6,7,5,8,2,3,1,4/ +! +! variables for flow-blocking drag +! + real(kind=kind_phys), parameter :: frmax = 10. + real(kind=kind_phys), parameter :: olmin = 1.0e-5 + real(kind=kind_phys), parameter :: odmin = 0.1 + real(kind=kind_phys), parameter :: odmax = 10. +! + real(kind=kind_phys) :: fbdcd + real(kind=kind_phys) :: zblk, tautem + real(kind=kind_phys) :: fbdpe, fbdke + real(kind=kind_phys), dimension(its:ite) :: delx, dely + real(kind=kind_phys), dimension(its:ite,4) :: dxy4, dxy4p + real(kind=kind_phys), dimension(4) :: ol4p + real(kind=kind_phys), dimension(its:ite) :: dxy, dxyp, olp, od + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: taufb +! + integer, dimension(its:ite) :: komax + integer :: kblk +!------------------------------------------------------------------------------- +! +! constants +! + lcap = kte + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi_) +! +! initialize CCPP error flag and message +! + errmsg = '' + errflg = 0 +! +! calculate length of grid for flow-blocking drag +! + delx(its:ite) = dxmeter(its:ite) + dely(its:ite) = dxmeter(its:ite) + dxy4(its:ite,1) = delx(its:ite) + dxy4(its:ite,2) = dely(its:ite) + dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) + dxy4(its:ite,4) = dxy4(its:ite,3) + dxy4p(its:ite,1) = dxy4(its:ite,2) + dxy4p(its:ite,2) = dxy4(its:ite,1) + dxy4p(its:ite,3) = dxy4(its:ite,4) + dxy4p(its:ite,4) = dxy4(its:ite,3) +! + cleff(its:ite) = dxmeter(its:ite) +! +! initialize arrays, array syntax is OK for OpenMP since these are local +! + ldrag = .false. ; icrilv = .false. ; flag = .true. +! + klowtop = 0 ; kbl = 0 +! + dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. + ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. + oa = 0. ; ol = 0. ; taub = 0. +! + usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. + taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. +! + dtfac = 1.0 ; xlinv = 1.0/xl +! + komax = 0 + taufb = 0.0 +! + do k = kts,kte + do i = its,ite + vtj(i,k) = t1(i,k) * (1.+fv_*q1(i,k)) + vtk(i,k) = vtj(i,k) / prslk(i,k) + + ! Density (kg/m^3) + + rho(i,k) = 1./rd_ * prsl(i,k) / vtj(i,k) + + ! Delta p (positive) between interfaces levels (Pa) + + del(i,k) = prsi(i,k) - prsi(i,k+1) + + ! Earth-relative zonal and meridional winds (m/s) + + u1(i,k) = uproj(i,k)*cosa(i) - vproj(i,k)*sina(i) + v1(i,k) = uproj(i,k)*sina(i) + vproj(i,k)*cosa(i) + + enddo + enddo + +! + do i = its,ite + zlowtop(i) = 2. * var(i) + enddo +! + do i = its,ite + kloop1(i) = .true. + enddo +! + do k = kts+1,kte + do i = its,ite + if(zlowtop(i) .gt. 0.) then + if (kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then + klowtop(i) = k+1 + kloop1(i) = .false. + endif + endif + enddo + enddo +! + kpblmax = kte + do i = its,ite + kbl(i) = klowtop(i) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) + enddo +! +! determine the level of maximum orographic height +! + komax(:) = kbl(:) +! + do i = its,ite + delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) + delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) + enddo +! +! compute low level averages within pbl +! + do k = kts,kpblmax + do i = its,ite + if (k.lt.kbl(i)) then + rcsks = del(i,k) * delks(i) + rdelks = del(i,k) * delks(i) + ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean + vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho mean + endif + enddo + enddo +! +! figure out low-level horizontal wind direction +! +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se +! + do i = its,ite + oa4(i,1) = oa2d1(i) + oa4(i,2) = oa2d2(i) + oa4(i,3) = oa2d3(i) + oa4(i,4) = oa2d4(i) + ol4(i,1) = ol2d1(i) + ol4(i,2) = ol2d2(i) + ol4(i,3) = ol2d3(i) + ol4(i,4) = ol2d4(i) + wdir = atan2(ubar(i),vbar(i)) + pi_ + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) + ol(i) = ol4(i,mod(nwd-1,4)+1) +! +! compute orographic width along (ol) and perpendicular (olp) the wind direction +! + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) +! +! compute orographic direction (horizontal orographic aspect ratio) +! + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) +! +! compute length of grid in the along(dxy) and cross(dxyp) wind directions +! + dxy(i) = dxy4(i,MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) + enddo +! +! saving richardson number in usqj for migwdi +! + do k = kts,kte-1 + do i = its,ite + ti = 2.0 / (t1(i,k)+t1(i,k+1)) + rdz = 1./(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = tem1*tem1 + tem2*tem2 + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g_*(g_/cp_+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = 2.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + enddo + enddo +! +! compute the "low level" or 1/3 wind magnitude (m/s) +! + do i = its,ite + ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) + rulow(i) = 1./ulow(i) + enddo +! + do k = kts,kte-1 + do i = its,ite + velco(i,k) = 0.5 * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) + if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then + velco(i,k) = veleps + endif + enddo + enddo +! +! no drag when critical level in the base layer +! + do i = its,ite + ldrag(i) = velco(i,1).le.0. + enddo +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. + enddo + enddo +! +! the low level weighted average ri is stored in usqj(1,1; im) +! the low level weighted average n**2 is stored in bnv2(1,1; im) +! this is called bnvl2 in phy_gwd_alpert_sub not bnv2 +! rdelks (del(k)/delks) vert ave factor so we can * instead of / +! + do i = its,ite + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) + enddo +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) then + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks + usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks + endif + enddo + enddo +! + do i = its,ite + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 + ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 + ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 + enddo +! +! set all ri low level values to the low level value +! + do k = kpblmin,kpblmax + do i = its,ite + if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) + enddo + enddo +! + do i = its,ite + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * var(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) + endif + enddo +! +! compute the base level stress and store it in taub +! calculate enhancement factor, number of mountains & aspect +! ratio const. use simplified relationship between standard +! deviation & critical hgt +! + do i = its,ite + if (.not. ldrag(i)) then + efact = (oa(i) + 2.) ** (ce*fr(i)/frc) + efact = min( max(efact,efmin), efmax ) + coefm(i) = (1. + ol(i)) ** (oa(i)+1.) + xlinv(i) = coefm(i) / cleff(i) + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + taub(i) = xlinv(i) * rhobar(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else + taub(i) = 0.0 + xn(i) = 0.0 + yn(i) = 0.0 + endif + enddo +! +! now compute vertical structure of the stress. +! + do k = kts,kpblmax + do i = its,ite + if (k .le. kbl(i)) taup(i,k) = taub(i) + enddo + enddo +! + do k = kpblmin, kte-1 ! vertical level k loop! + kp1 = k + 1 + do i = its,ite +! +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! + if (k .ge. kbl(i)) then + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & + .or. (velco(i,k) .le. 0.0) + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + endif + enddo +! + do i = its,ite + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then + temv = 1.0 / velco(i,k) + tem1 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(i,k))*brvf(i)*velco(i,k)*0.5 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv +! +! rim is the minimum-richardson number by shutts (1985) +! + tem2 = sqrt(usqj(i,k)) + tem = 1. + tem2 * fro + rim = usqj(i,k) * (1.-fro) / (tem * tem) +! +! check stability to employ the 'saturation hypothesis' +! of lindzen (1981) except at tropospheric downstream regions +! + if (rim .le. ric) then ! saturation hypothesis! + if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then + temc = 2.0 + 1.0 / tem2 + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) + taup(i,kp1) = tem1 * hd * hd + endif + else ! no wavebreaking! + taup(i,kp1) = taup(i,k) + endif + endif + endif + enddo + enddo +! + if (lcap.lt.kte) then + do klcap = lcapp1,kte + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + do i = its,ite + if (.not.ldrag(i)) then +! +! determine the height of flow-blocking layer +! + kblk = 0 + fbdpe = 0.0 + fbdke = 0.0 + do k = kte, kpblmin, -1 + if (kblk.eq.0 .and. k.le.kbl(i)) then + fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & + *del(i,k)/g_/rho(i,k) + fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) +! +! apply flow-blocking drag when fbdpe >= fbdke +! + if (fbdpe.ge.fbdke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + endif + endif + enddo + if (kblk.ne.0) then +! +! compute flow-blocking stress +! + fbdcd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter(i)**2*fbdcd*dxyp(i) & + *olp(i)*zblk*ulow(i)**2 + tautem = taufb(i,kts)/real(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +! sum orographic GW stress and flow-blocking stress +! + taup(i,:) = taup(i,:) + taufb(i,:) + endif + endif + enddo +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,kte + do i = its,ite + taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * g_ / del(i,k) + enddo + enddo +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + do i = its,ite + if (k .le. kbl(i)) then + if (taud(i,k).ne.0.) & + dtfac(i) = min(dtfac(i),abs(velco(i,k)/(deltim*taud(i,k)))) + endif + enddo + enddo +! + do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + enddo +! + do k = kts,kte + do i = its,ite + taud(i,k) = taud(i,k) * dtfac(i) + dtaux = taud(i,k) * xn(i) + dtauy = taud(i,k) * yn(i) + dtaux2d(i,k) = dtaux + dtauy2d(i,k) = dtauy + dudt(i,k) = dtaux + dvdt(i,k) = dtauy + dusfc(i) = dusfc(i) + dtaux * del(i,k) + dvsfc(i) = dvsfc(i) + dtauy * del(i,k) + enddo + enddo +! + do i = its,ite + dusfc(i) = (-1./g_) * dusfc(i) + dvsfc(i) = (-1./g_) * dvsfc(i) + enddo +! +! rotate tendencies from zonal/meridional back to model grid +! + do k = kts,kte + do i = its,ite + rublten(i,k) = rublten(i,k)+dudt(i,k)*cosa(i) + dvdt(i,k)*sina(i) + rvblten(i,k) = rvblten(i,k)-dudt(i,k)*sina(i) + dvdt(i,k)*cosa(i) + dtaux3d(i,k) = dtaux2d(i,k)*cosa(i) + dtauy2d(i,k)*sina(i) + dtauy3d(i,k) =-dtaux2d(i,k)*sina(i) + dtauy2d(i,k)*cosa(i) + enddo + enddo + do i = its,ite + dusfcg(i) = dusfc(i)*cosa(i) + dvsfc(i)*sina(i) + dvsfcg(i) =-dusfc(i)*sina(i) + dvsfc(i)*cosa(i) + enddo + return + end subroutine bl_gwdo_run + +!------------------------------------------------------------------------------- + subroutine bl_gwdo_init (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_gwdo_init + +!------------------------------------------------------------------------------- + subroutine bl_gwdo_final (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_gwdo_final + +!------------------------------------------------------------------------------- + subroutine bl_gwdo_timestep_init (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_gwdo_timestep_init + +!------------------------------------------------------------------------------- + subroutine bl_gwdo_timestep_final (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_gwdo_timestep_final + +!------------------------------------------------------------------------------- +end module bl_gwdo diff --git a/src/core_atmosphere/physics/physics_mmm/bl_ysu.F b/src/core_atmosphere/physics/physics_mmm/bl_ysu.F new file mode 100644 index 0000000000..5483574e28 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/bl_ysu.F @@ -0,0 +1,1708 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 +!================================================================================================================= + module bl_ysu + use ccpp_kinds,only: kind_phys + + implicit none + private + public:: bl_ysu_run , & + bl_ysu_init , & + bl_ysu_final , & + bl_ysu_timestep_init, & + bl_ysu_timestep_final + + + contains + + +!================================================================================================================= + subroutine bl_ysu_run(ux,vx,tx,qvx,qcx,qix,nmix,qmix,p2d,p2di,pi2d, & + f_qc,f_qi, & + utnp,vtnp,ttnp,qvtnp,qctnp,qitnp,qmixtnp, & + cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & + dz8w2d,psfcpa, & + znt,ust,hpbl,psim,psih, & + xland,hfx,qfx,wspd,br, & + dt,kpbl1d, & + exch_hx,exch_mx, & + wstar,delta, & + u10,v10, & + uox,vox, & + rthraten, & + ysu_topdown_pblmix, & + ctopo,ctopo2, & + a_u,a_v,a_t,a_q,a_e, & + b_u,b_v,b_t,b_q,b_e, & + sfk,vlk,dlu,dlg,frcurb, & + flag_bep, & + its,ite,kte,kme, & + errmsg,errflg & + ) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! this code is a revised vertical diffusion package ("ysupbl") +! with a nonlocal turbulent mixing in the pbl after "mrfpbl". +! the ysupbl (hong et al. 2006) is based on the study of noh +! et al.(2003) and accumulated realism of the behavior of the +! troen and mahrt (1986) concept implemented by hong and pan(1996). +! the major ingredient of the ysupbl is the inclusion of an explicit +! treatment of the entrainment processes at the entrainment layer. +! this routine uses an implicit approach for vertical flux +! divergence and does not require "miter" timesteps. +! it includes vertical diffusion in the stable atmosphere +! and moist vertical diffusion in clouds. +! +! mrfpbl: +! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) +! fall 1996 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! further modifications : +! an enhanced stable layer mixing, april 2008 +! ==> increase pbl height when sfc is stable (hong 2010) +! pressure-level diffusion, april 2009 +! ==> negligible differences +! implicit forcing for momentum with clean up, july 2009 +! ==> prevents model blowup when sfc layer is too low +! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 +! ==> prevents model blowup when delz is extremely large +! revised prandtl number at surface, peggy lemone, feb 2010 +! ==> increase kh, decrease mixing due to counter-gradient term +! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 +! ==> reduce the thermal strength when z1 < 0.1 h +! revised prandtl number for free convection, dudhia, mar 2012 +! ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced +! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 +! ==> weaker mixing when stable, and les resolution in vertical +! gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012 +! ==> consider thermal z0 when differs from mechanical z0 +! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 +! ==> wscale becomes small with height, and less mixing in stable bl +! revision in background diffusion (kzo), jan 2016 +! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for +! internal wave mixing of large et al. (1994), songyou hong, feb 2016 +! ==> alleviate superious excessive mixing when delz is large +! add multilayer urban canopy models of BEP and BEP+BEM, jan 2021 +! +! references: +! +! hendricks, knievel, and wang (2020), j. appl. meteor. clim. +! hong (2010) quart. j. roy. met. soc +! hong, noh, and dudhia (2006), mon. wea. rev. +! hong and pan (1996), mon. wea. rev. +! noh, chun, hong, and raasch (2003), boundary layer met. +! troen and mahrt (1986), boundary layer met. +! +!------------------------------------------------------------------------------- +! + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. + real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 + real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + integer,parameter :: imvdif = 1 + real(kind=kind_phys),parameter :: rcl = 1.0 + integer,parameter :: kts=1, kms=1 +! + integer, intent(in ) :: its,ite,kte,kme + + integer, intent(in) :: ysu_topdown_pblmix +! + integer, intent(in) :: nmix +! + real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv +! + real(kind=kind_phys), intent(in ) :: ep1,ep2,karman +! + logical, intent(in ) :: f_qc, f_qi +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in) :: dz8w2d, & + pi2d +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: tx, & + qvx, & + qcx, & + qix +! + real(kind=kind_phys), dimension( its:ite, kts:kte, nmix ) , & + intent(in ) :: qmix +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(out ) :: utnp, & + vtnp, & + ttnp, & + qvtnp, & + qctnp, & + qitnp +! + real(kind=kind_phys), dimension( its:ite, kts:kte, nmix ) , & + intent(out ) :: qmixtnp +! + real(kind=kind_phys), dimension( its:ite, kms:kme ) , & + intent(in ) :: p2di +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: p2d +! + real(kind=kind_phys), dimension( its:ite ) , & + intent(out ) :: hpbl +! + real(kind=kind_phys), dimension( its:ite ) , & + intent(in ) :: ust, & + znt + real(kind=kind_phys), dimension( its:ite ) , & + intent(in ) :: xland, & + hfx, & + qfx +! + real(kind=kind_phys), dimension( its:ite ), intent(in ) :: wspd + real(kind=kind_phys), dimension( its:ite ), intent(in ) :: br +! + real(kind=kind_phys), dimension( its:ite ), intent(in ) :: psim, & + psih +! + real(kind=kind_phys), dimension( its:ite ), intent(in ) :: psfcpa + integer, dimension( its:ite ), intent(out ) :: kpbl1d +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: ux, & + vx, & + rthraten + real(kind=kind_phys), dimension( its:ite ) , & + optional , & + intent(in ) :: ctopo, & + ctopo2 +! + logical, intent(in ) :: flag_bep + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + optional , & + intent(in ) :: a_u, & + a_v, & + a_t, & + a_q, & + a_e, & + b_u, & + b_v, & + b_t, & + b_q, & + b_e, & + sfk, & + vlk, & + dlu, & + dlg + real(kind=kind_phys), dimension( its:ite ) , & + optional , & + intent(in ) :: frcurb +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! +! local vars +! + real(kind=kind_phys), dimension( its:ite ) :: hol + real(kind=kind_phys), dimension( its:ite, kms:kme ) :: zq +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za +! + real(kind=kind_phys), dimension( its:ite ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamt,hgamq, & + brdn,brup, & + phim,phih, & + dusfc,dvsfc, & + dtsfc,dqsfc, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzh,xkzm,xkzq, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + zfac, & + rhox2, & + hgamt2, & + ad1,adm,adv +! +!jdf added exch_hx +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(out ) :: exch_hx, & + exch_mx +! + real(kind=kind_phys), dimension( its:ite ) , & + intent(inout) :: u10, & + v10 + real(kind=kind_phys), dimension( its:ite ), optional , & + intent(in ) :: uox, & + vox + real(kind=kind_phys), dimension( its:ite ) :: uoxl, & + voxl + real(kind=kind_phys), dimension( its:ite ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys), dimension( its:ite, kts:kte) :: r3,f3 + integer, dimension( its:ite ) :: kpbl,kpblold +! + logical, dimension( its:ite ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl +! +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc +! + + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: wscalek,wscalek2 + real(kind=kind_phys), dimension( its:ite ), intent(out) :: wstar, & + delta + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: qcxl, & + qixl + real(kind=kind_phys), dimension( its:ite ) :: ust3, & + wstar3, & + wstar3_2, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & + rcldb,bruptmp,radflux,vconvlim,vconvnew,fluxc,vconvc,vconv +!topo-corr + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: fric, & + tke_ysu,& + el_ysu,& + shear_ysu,& + buoy_ysu + real(kind=kind_phys), dimension( its:ite) :: pblh_ysu,& + vconvfx +! + real(kind=kind_phys) :: bepswitch + + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: & + a_u2d,a_v2d,a_t2d,a_q2d,a_e2d,b_u2d,b_v2d,b_t2d,b_q2d,b_e2d, & + sfk2d,vlk2d,dlu2d,dlg2d + real(kind=kind_phys), dimension( its:ite ) :: & + frc_urb1d + + real(kind=kind_phys), dimension( kts:kte ) :: thvx_1d,tke_1d,dzq_1d + real(kind=kind_phys), dimension( kts:kte+1) :: zq_1d + +! +!------------------------------------------------------------------------------- +! + klpbl = kte +! + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! +! k-start index for tracer diffusion +! + if(f_qc) then + do k = kts,kte + do i = its,ite + qcxl(i,k) = qcx(i,k) + enddo + enddo + else + do k = kts,kte + do i = its,ite + qcxl(i,k) = 0. + enddo + enddo + endif +! + if(f_qi) then + do k = kts,kte + do i = its,ite + qixl(i,k) = qix(i,k) + enddo + enddo + else + do k = kts,kte + do i = its,ite + qixl(i,k) = 0. + enddo + enddo + endif +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qcxl(i,k)/cp-2.834E6*qixl(i,k)/cp)/pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qvx(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + if ( present(uox) .and. present(vox) ) then + do i =its,ite + uoxl(i) = uox(i) + voxl(i) = vox(i) + enddo + else + do i =its,ite + uoxl(i) = 0 + voxl(i) = 0 + enddo + endif +! + do i = its,ite + tvcon = (1.+ep1*qvx(i,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + enddo +! + if(present(a_u) .and. present(a_v) .and. present(a_t) .and. & + present(a_q) .and. present(a_t) .and. present(a_e) .and. & + present(b_u) .and. present(b_v) .and. present(b_t) .and. & + present(b_q) .and. present(b_e) .and. present(dlg) .and. & + present(dlu) .and. present(sfk) .and. present(vlk) .and. & + present(frcurb) .and. flag_bep) then + + bepswitch=1.0 + do k = kts, kte + do i = its,ite + a_u2d(i,k) = a_u(i,k) + a_v2d(i,k) = a_v(i,k) + a_t2d(i,k) = a_t(i,k) + a_q2d(i,k) = a_q(i,k) + a_e2d(i,k) = a_e(i,k) + b_u2d(i,k) = b_u(i,k) + b_v2d(i,k) = b_v(i,k) + b_t2d(i,k) = b_t(i,k) + b_q2d(i,k) = b_q(i,k) + b_e2d(i,k) = b_e(i,k) + dlg2d(i,k) = dlg(i,k) + dlu2d(i,k) = dlu(i,k) + vlk2d(i,k) = vlk(i,k) + sfk2d(i,k) = sfk(i,k) + enddo + enddo + do i = its, ite + frc_urb1d(i) = frcurb(i) + enddo + else + bepswitch=0.0 + do k = kts, kte + do i = its,ite + a_u2d(i,k) = 0.0 + a_v2d(i,k) = 0.0 + a_t2d(i,k) = 0.0 + a_q2d(i,k) = 0.0 + a_e2d(i,k) = 0.0 + b_u2d(i,k) = 0.0 + b_v2d(i,k) = 0.0 + b_t2d(i,k) = 0.0 + b_q2d(i,k) = 0.0 + b_e2d(i,k) = 0.0 + dlg2d(i,k) = 0.0 + dlu2d(i,k) = 0.0 + vlk2d(i,k) = 1.0 + sfk2d(i,k) = 1.0 + enddo + enddo + do i = its, ite + frc_urb1d(i) = 0.0 + enddo + endif +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do i = its,ite + zq(i,1) = 0. + enddo +! + do k = kts,kte + do i = its,ite + zq(i,k+1) = dz8w2d(i,k)+zq(i,k) + tvcon = (1.+ep1*qvx(i,k)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) + enddo + enddo +! + do k = kts,kte + do i = its,ite + za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + enddo + enddo +! + do i = its,ite + dza(i,1) = za(i,1) + enddo +! + do k = kts+1,kte + do i = its,ite + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo +! +!-----initialize output and local exchange coefficents: + do k = kts,kte + do i = its,ite + exch_hx(i,k) = 0. + exch_mx(i,k) = 0. + xkzh(i,k) = 0. + xkzhl(i,k) = 0. + xkzm(i,k) = 0. + xkzml(i,k) = 0. + xkzq(i,k) = 0. + enddo + enddo +! + do i = its,ite + wspd1(i) = sqrt( (ux(i,1)-uoxl(i))*(ux(i,1)-uoxl(i)) + (vx(i,1)-voxl(i))*(vx(i,1)-voxl(i)) )+1.e-9 + enddo +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt + dt2 = 2.*dtstep + rdt = 1./dt2 +! + do i = its,ite + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + wstar3_2(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo + do k = kts,klpbl-1 + do i = its,ite + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh + enddo + enddo +! + do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = its,ite + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + thermalli(i) = thlix(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. + sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = its,ite + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = its,ite + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) + hfx0 = max(hfx(i)/rhox(i)/cp,0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = its,ite + if(sfcflg(i).and.sflux(i).gt.0.0)then + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = its,ite + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = its,ite + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! +! enhance pbl by theta-li +! + if (ysu_topdown_pblmix.eq.1)then + do i = its,ite + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), kte-1 + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 + stable(i) = bruptmp.ge.brcr(i) + if (definebrup) then + kpbl(i) = k + brup(i) = bruptmp + definebrup=.false. + endif + if (.not.stable(i)) then !overwrite brup brdn values + brdn(i)=bruptmp + definebrup=.true. + pblflg(i)=.true. + endif + enddo + enddo + endif + + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! stable boundary layer +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = its,ite + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = its,ite + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + cloudflg(i)=.false. + if(pblflg(i)) then + k = kpbl(i) - 1 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + if((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then + if ( kpbl(i) .ge. 2) then + cloudflg(i)=.true. + templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) + temps=templ + ((qvx(i,k)+qcxl(i,k))-rvls)/(cp/xlv + & + ep2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) + rcldb=max((qvx(i,k)+qcxl(i,k))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qvx(i,k+2)+qcxl(i,k+2))) & + - (thlix(i,k) + thx(i,k) *ep1*(qvx(i,k) +qcxl(i,k))) + dthvx(i) = max(dthvx(i),0.1) + tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) + ent_eff = 0.2 * 8. * tmp1 +0.2 + + radsum=0. + do kk = 1,kpbl(i)-1 + radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p2di(i,kk)-p2di(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !recompute entrainment from sfc thermals + bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) + bfx0 = max(sflux(i),0.0) + wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) + wm2(i) = wm2(i)+wm3**h2 + bfxpbl(i) = - ent_eff * bfx0 + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) + we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + + !wstar3_2 + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) + !recompute hgamt + wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + gamfac = bfac/rhox2(i,k)/wscale(i) + hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) + hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + endif + endif + prpbl(i) = 1.0 + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qvx(i,k+1)-qvx(i,k),0.0) + hfxpbl(i) = we(i)*dthx + qfxpbl(i) = we(i)*dqx +! + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = kts,klpbl + do i = its,ite + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & + wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac + !Do not include xkzm at kpbl-1 since it changes entrainment + if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then + xkzm(i,k) = 0.0 + endif + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & + +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & + /(dza(i,k+1)*dza(i,k+1))+1.e-9 + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1)then + if((qcxl(i,k)+qixl(i,k)).gt.0.01e-3.and. & + (qcxl(i,k+1)+qixl(i,k+1)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qvx(i,k)+qvx(i,k+1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean + ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+(1.0-bepswitch)*hfx(i)/cont/del(i,1)*dt2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzh(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_hx(i,k+1) = xkzh(i,k) + enddo + enddo +! +! add bep/bep+bem forcing for heat if flag_bep=.true. +! + do k = kts,kte + do i = its,ite + ad(i,k) = ad(i,k) - a_t2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_t2d(i,k)*dt2 + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) +! +! recover tendencies of heat +! + do k = kte,kts,-1 + do i = its,ite +#if (NEED_B4B_DURING_CCPP_TESTING == 1) + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) +#elif (NEED_B4B_DURING_CCPP_TESTING != 1) + ttend = (f1(i,k)-thx(i,k)+300.)*rdt + ttnp(i,k) = ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) +#endif + enddo + enddo +! + +!--- compute tridiagonal matrix elements for water vapor, cloud water, and cloud ice: + !--- initialization of k-coefficient above the PBL. + do i = its,ite + do k = kts,kte-1 + if(k .ge. kpbl(i)) xkzq(i,k) = xkzh(i,k) + enddo + enddo + + !--- water vapor: + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + r1(i,k) = 0. + enddo + + k = 1 + ad(i,1) = 1. + f1(i,1) = qvx(i,1)+(1.0-bepswitch)*qfx(i)*g/del(i,1)*dt2 + + do k = kts,kte-1 + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzq(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzq + f1(i,k+1) = qvx(i,k+1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f1(i,k+1) = qvx(i,k+1) + else + f1(i,k+1) = qvx(i,k+1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo +! +! add bep/bep+bem forcing for water vapor if flag_bep=.true. +! + do k = kts,kte + adv(i,k) = ad(i,k) - a_q2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_q2d(i,k)*dt2 + enddo + + do k = kts,kte + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,adv,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qvx(i,k))*rdt + qvtnp(i,k) = qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo + + !--- cloud water: + if(f_qc) then + do i = its,ite + do k = kts,kte + f1(i,k) = qcxl(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qcxl(i,k))*rdt + qctnp(i,k) = qtend + enddo + enddo + endif + + !--- cloud ice: + if(f_qi) then + do i = its,ite + do k = kts,kte + f1(i,k) = qixl(i,k) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qixl(i,k))*rdt + qitnp(i,k) = qtend + enddo + enddo + endif + + !--- chemical species and/or passive tracers, meaning all variables that we want to + ! be vertically-mixed, if nmix=0 (number of tracers) then the loop is skipped + do n = 1, nmix + do i = its,ite + do k = kts,kte + f1(i,k) = qmix(i,k,n) + r1(i,k) = f1(i,k) + enddo + enddo + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) + + do i = its,ite + do k = kte,kts,-1 + qtend = (f1(i,k)-qmix(i,k,n))*rdt + qmixtnp(i,k,n) = qtend + enddo + enddo + enddo + +! +! compute tridiagonal matrix elements for momentum +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! +! paj: ctopo=1 if topo_wind=0 (default) +!raquel---paj tke code (could be replaced with shin-hong tke in future + do i = its,ite + do k= kts, kte-1 + shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & + + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) + buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) + + zk = karman*zq(i,k+1) + !over pbl + if (k.ge.kpbl(i)) then + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) + rlamdz = min(dza(i,k+1),rlamdz) + else + !in pbl + rlamdz = 150.0 + endif + el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) + tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)) + !q2 when q3 positive + if(tke_ysu(i,k).le.0) then + tke_ysu(i,k)=0.0 + else + tke_ysu(i,k)=(tke_ysu(i,k))**0.66 + endif + enddo + !Hybrid pblh of MYNN + !tke is q2 +! CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& +! & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) + do k = kts,kte + thvx_1d(k) = thvx(i,k) + tke_1d(k) = tke_ysu(i,k) + zq_1d(k) = zq(i,k) + dzq_1d(k) = dzq(i,k) + enddo + zq_1d(kte+1) = zq(i,kte+1) + call get_pblh(kts,kte,pblh_ysu(i),thvx_1d,tke_1d,zq_1d,dzq_1d,xland(i)) + +!--- end of paj tke +! compute vconv +! Use Beljaars over land + if (xland(i).lt.1.5) then + fluxc = max(sflux(i),0.0) + vconvc=1. + VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 + else +! for water there is no topo effect so vconv not needed + VCONV = 0. + endif + vconvfx(i) = vconv +!raquel +!ctopo stability correction + fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 + if(present(ctopo)) then + vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) + vconvlim = min(vconvnew,1.0) + ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim) + ad(i,1) = ad(i,1) - bepswitch*frc_urb1d(i)* & + (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) +! ad(i,1) = 1.+(1.-bepswitch*frc_urb1d(i))* & +! (fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)) + else + ad(i,1) = 1.+fric(i,1) + endif + f1(i,1) = ux(i,1)+uoxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + f2(i,1) = vx(i,1)+voxl(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = sfk2d(i,k)*dt2/del(i,k) + dtodsu = sfk2d(i,k)*dt2/del(i,k+1) + dsig = p2d(i,k)-p2d(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*xkzm(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) + dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2/vlk2d(i,k) + al(i,k) = -dtodsu*dsdz2/vlk2d(i,k) + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + exch_mx(i,k+1) = xkzm(i,k) + enddo + enddo +! +! add bep/bep+bem forcing for momentum if flag_bep=.true. +! + do k = kts,kte + do i = its,ite + ad1(i,k) = ad(i,k) + end do + end do + do k = kts,kte + do i = its,ite + ad(i,k) = ad(i,k) - a_u2d(i,k)*dt2 + ad1(i,k) = ad1(i,k) - a_v2d(i,k)*dt2 + f1(i,k) = f1(i,k) + b_u2d(i,k)*dt2 + f2(i,k) = f2(i,k) + b_v2d(i,k)*dt2 + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi2n(al,ad,ad1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) +! +! recover tendencies of momentum +! + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utend + vtnp(i,k) = vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! +! paj: ctopo2=1 if topo_wind=0 (default) +! + do i = its,ite + if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM + u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) + v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) + endif !mchen + enddo +! +!---- end of vertical diffusion +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! + errmsg = 'bl_ysu_run OK' + errflg = 0 +! + end subroutine bl_ysu_run + +!================================================================================================================= + subroutine bl_ysu_init (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_ysu_init + +!================================================================================================================= + subroutine bl_ysu_final (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_ysu_final + +!================================================================================================================= + subroutine bl_ysu_timestep_init (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_ysu_timestep_init + +!================================================================================================================= + subroutine bl_ysu_timestep_final (errmsg, errflg) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! This routine currently does nothing + + errmsg = '' + errflg = 0 + + end subroutine bl_ysu_timestep_final +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi2n(cl,cm,cm1,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + cm1, & + r1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm1(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo + + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm1(i,k)-cl(i,k)*au(i,k-1)) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm1(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,kts,-1 + do i = its,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi2n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: au, & + cm, & + cu + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 + + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + real(kind=kind_phys), dimension( its:ite, kts:kte ) :: aul + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,ite + do k = kts,kte + aul(i,k) = 0. + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + aul(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*aul(i,k-1)) + aul(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*aul(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-aul(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu + +!================================================================================================================= + subroutine get_pblh(kts,kte,zi,thetav1d,qke1d,zw1d,dz1d,landsea) +! Copied from MYNN PBL + + !--------------------------------------------------------------- + ! NOTES ON THE PBLH FORMULATION + ! + !The 1.5-theta-increase method defines PBL heights as the level at + !which the potential temperature first exceeds the minimum potential + !temperature within the boundary layer by 1.5 K. When applied to + !observed temperatures, this method has been shown to produce PBL- + !height estimates that are unbiased relative to profiler-based + !estimates (Nielsen-Gammon et al. 2008). However, their study did not + !include LLJs. Banta and Pichugina (2008) show that a TKE-based + !threshold is a good estimate of the PBL height in LLJs. Therefore, + !a hybrid definition is implemented that uses both methods, weighting + !the TKE-method more during stable conditions (PBLH < 400 m). + !A variable tke threshold (TKEeps) is used since no hard-wired + !value could be found to work best in all conditions. + !--------------------------------------------------------------- + + integer,intent(in) :: kts,kte + real(kind=kind_phys), intent(out) :: zi + real(kind=kind_phys), intent(in) :: landsea + real(kind=kind_phys), dimension(kts:kte), intent(in) :: thetav1d, qke1d, dz1d + real(kind=kind_phys), dimension(kts:kte+1), intent(in) :: zw1d + !local vars + real(kind=kind_phys) :: pblh_tke,qtke,qtkem1,wt,maxqke,tkeeps,minthv + real(kind=kind_phys) :: delt_thv !delta theta-v; dependent on land/sea point + real(kind=kind_phys), parameter :: sbl_lim = 200. !theta-v pbl lower limit of trust (m). + real(kind=kind_phys), parameter :: sbl_damp = 400. !damping range for averaging with tke-based pblh (m). + integer :: i,j,k,kthv,ktke + + !find max tke and min thetav in the lowest 500 m + k = kts+1 + kthv = 1 + ktke = 1 + maxqke = 0. + minthv = 9.e9 + + do while (zw1d(k) .le. 500.) + qtke =max(qke1d(k),0.) ! maximum qke + if (maxqke < qtke) then + maxqke = qtke + ktke = k + endif + if (minthv > thetav1d(k)) then + minthv = thetav1d(k) + kthv = k + endif + k = k+1 + enddo + !tkeeps = maxtke/20. = maxqke/40. + tkeeps = maxqke/40. + tkeeps = max(tkeeps,0.025) + tkeeps = min(tkeeps,0.25) + + !find thetav-based pblh (best for daytime). + zi=0. + k = kthv+1 + if((landsea-1.5).ge.0)then + ! water + delt_thv = 0.75 + else + ! land + delt_thv = 1.5 + endif + + zi=0. + k = kthv+1 + do while (zi .eq. 0.) + if (thetav1d(k) .ge. (minthv + delt_thv))then + zi = zw1d(k) - dz1d(k-1)* & + & min((thetav1d(k)-(minthv + delt_thv))/max(thetav1d(k)-thetav1d(k-1),1e-6),1.0) + endif + k = k+1 + if (k .eq. kte-1) zi = zw1d(kts+1) !exit safeguard + enddo + + !print*,"in get_pblh:",thsfc,zi + !for stable boundary layers, use tke method to complement the + !thetav-based definition (when the theta-v based pblh is below ~0.5 km). + !the tanh weighting function will make the tke-based definition negligible + !when the theta-v-based definition is above ~1 km. + !find tke-based pblh (best for nocturnal/stable conditions). + + pblh_tke=0. + k = ktke+1 + do while (pblh_tke .eq. 0.) + !qke can be negative (if ckmod == 0)... make tke non-negative. + qtke =max(qke1d(k)/2.,0.) ! maximum tke + qtkem1=max(qke1d(k-1)/2.,0.) + if (qtke .le. tkeeps) then + pblh_tke = zw1d(k) - dz1d(k-1)* & + & min((tkeeps-qtke)/max(qtkem1-qtke, 1e-6), 1.0) + !in case of near zero tke, set pblh = lowest level. + pblh_tke = max(pblh_tke,zw1d(kts+1)) + !print *,"pblh_tke:",i,j,pblh_tke, qke1d(k)/2., zw1d(kts+1) + endif + k = k+1 + if (k .eq. kte-1) pblh_tke = zw1d(kts+1) !exit safeguard + enddo + + !blend the two pblh types here: + + wt=.5*tanh((zi - sbl_lim)/sbl_damp) + .5 + zi=pblh_tke*(1.-wt) + zi*wt + + end subroutine get_pblh + +!================================================================================================================= + end module bl_ysu +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F b/src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F new file mode 100644 index 0000000000..041bb67456 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/cu_ntiedtke.F @@ -0,0 +1,3766 @@ +!================================================================================================================= + module cu_ntiedtke_common + use ccpp_kinds,only: kind_phys + + + implicit none + save + + real(kind=kind_phys):: alf + real(kind=kind_phys):: als + real(kind=kind_phys):: alv + real(kind=kind_phys):: cpd + real(kind=kind_phys):: g + real(kind=kind_phys):: rd + real(kind=kind_phys):: rv + + real(kind=kind_phys),parameter:: t13 = 1.0/3.0 + real(kind=kind_phys),parameter:: tmelt = 273.16 + real(kind=kind_phys),parameter:: c1es = 610.78 + real(kind=kind_phys),parameter:: c3les = 17.2693882 + real(kind=kind_phys),parameter:: c3ies = 21.875 + real(kind=kind_phys),parameter:: c4les = 35.86 + real(kind=kind_phys),parameter:: c4ies = 7.66 + + real(kind=kind_phys),parameter:: rtwat = tmelt + real(kind=kind_phys),parameter:: rtber = tmelt-5. + real(kind=kind_phys),parameter:: rtice = tmelt-23. + + integer,parameter:: momtrans = 2 + real(kind=kind_phys),parameter:: entrdd = 2.0e-4 + real(kind=kind_phys),parameter:: cmfcmax = 1.0 + real(kind=kind_phys),parameter:: cmfcmin = 1.e-10 + real(kind=kind_phys),parameter:: cmfdeps = 0.30 + real(kind=kind_phys),parameter:: zdnoprc = 2.0e4 + real(kind=kind_phys),parameter:: cprcon = 1.4e-3 + real(kind=kind_phys),parameter:: pgcoef = 0.7 + + real(kind=kind_phys):: rcpd + real(kind=kind_phys):: c2es + real(kind=kind_phys):: c5les + real(kind=kind_phys):: c5ies + real(kind=kind_phys):: r5alvcp + real(kind=kind_phys):: r5alscp + real(kind=kind_phys):: ralvdcp + real(kind=kind_phys):: ralsdcp + real(kind=kind_phys):: ralfdcp + real(kind=kind_phys):: vtmpc1 + real(kind=kind_phys):: zrg + + logical,parameter:: nonequil = .true. + logical,parameter:: lmfpen = .true. + logical,parameter:: lmfmid = .true. + logical,parameter:: lmfscv = .true. + logical,parameter:: lmfdd = .true. + logical,parameter:: lmfdudv = .true. + + +!================================================================================================================= + end module cu_ntiedtke_common +!================================================================================================================= + + module cu_ntiedtke + use ccpp_kinds,only: kind_phys + use cu_ntiedtke_common + + + implicit none + private + public:: cu_ntiedtke_run, & + cu_ntiedtke_init, & + cu_ntiedtke_final, & + cu_ntiedtke_timestep_init, & + cu_ntiedtke_timestep_final + + + contains + + +!================================================================================================================= + subroutine cu_ntiedtke_init(con_cp,con_rd,con_rv,con_xlv,con_xls,con_xlf,con_grav,errmsg,errflg) +!================================================================================================================= + +!input arguments: + real(kind=kind_phys),intent(in):: & + con_cp, & + con_rd, & + con_rv, & + con_xlv, & + con_xls, & + con_xlf, & + con_grav + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + alf = con_xlf + als = con_xls + alv = con_xlv + cpd = con_cp + g = con_grav + rd = con_rd + rv = con_rv + + rcpd = 1.0/con_cp + c2es = c1es*con_rd/con_rv + c5les = c3les*(tmelt-c4les) + c5ies = c3ies*(tmelt-c4ies) + r5alvcp = c5les*con_xlv*rcpd + r5alscp = c5ies*con_xls*rcpd + ralvdcp = con_xlv*rcpd + ralsdcp = con_xls*rcpd + ralfdcp = con_xlf*rcpd + vtmpc1 = con_rv/con_rd-1.0 + zrg = 1.0/con_grav + + errmsg = 'cu_ntiedtke_init OK' + errflg = 0 + + end subroutine cu_ntiedtke_init + +!================================================================================================================= + subroutine cu_ntiedtke_final(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'cu_ntiedtke_final OK' + errflg = 0 + + end subroutine cu_ntiedtke_final + +!================================================================================================================= + subroutine cu_ntiedtke_timestep_init(its,ite,kts,kte,im,kx,kx1,itimestep,stepcu,dt,grav,xland,dz,pres,presi, & + t,rho,qv,qc,qi,u,v,w,qvften,thften,qvftenz,thftenz,slimsk,delt,prsl,ghtl,tf,qvf,qcf, & + qif,uf,vf,prsi,ghti,omg,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: itimestep + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt,grav + real(kind=kind_phys),intent(in),dimension(its:ite):: xland + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: dz,pres,t,rho,qv,qc,qi,u,v + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvften,thften + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte+1):: presi,w + +!--- inout arguments: + integer,intent(inout):: im,kx,kx1 + integer,intent(inout),dimension(its:ite):: slimsk + + real(kind=kind_phys),intent(inout):: delt + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: tf,qvf,qcf,qif,uf,vf + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: ghtl,omg,prsl + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte+1):: ghti,prsi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys),dimension(its:ite,kts:kte):: zl,dot + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: zi + +!----------------------------------------------------------------------------------------------------------------- + + im = ite-its+1 + kx = kte-kts+1 + kx1 = kx+1 + + delt = dt*stepcu + + do i = its,ite + slimsk(i) = (abs(xland(i)-2.)) + enddo + + k = kts + do i = its,ite + zi(i,k) = 0. + enddo + do k = kts,kte + do i = its,ite + zi(i,k+1) = zi(i,k)+dz(i,k) + enddo + enddo + do k = kts,kte + do i = its,ite + zl(i,k) = 0.5*(zi(i,k)+zi(i,k+1)) + dot(i,k) = -0.5*grav*rho(i,k)*(w(i,k)+w(i,k+1)) + enddo + enddo + + pp = 0 + do k = kts,kte+1 + zz = kte + 1 - pp + do i = its,ite + ghti(i,zz) = zi(i,k) + prsi(i,zz) = presi(i,k) + enddo + pp = pp + 1 + enddo + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + ghtl(i,zz) = zl(i,k) + omg(i,zz) = dot(i,k) + prsl(i,zz) = pres(i,k) + enddo + pp = pp + 1 + enddo + + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + tf(i,zz) = t(i,k) + qvf(i,zz) = qv(i,k) + qcf(i,zz) = qc(i,k) + qif(i,zz) = qi(i,k) + uf(i,zz) = u(i,k) + vf(i,zz) = v(i,k) + enddo + pp = pp + 1 + enddo + + if(itimestep == 1) then + do k = kts,kte + do i = its,ite + qvftenz(i,k) = 0. + thftenz(i,k) = 0. + enddo + enddo + else + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + qvftenz(i,zz) = qvften(i,k) + thftenz(i,zz) = thften(i,k) + enddo + pp = pp + 1 + enddo + endif + + errmsg = 'cu_ntiedtke_timestep_init OK' + errflg = 0 + + end subroutine cu_ntiedtke_timestep_init + +!================================================================================================================= + subroutine cu_ntiedtke_timestep_final(its,ite,kts,kte,stepcu,dt,exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf,rn, & + raincv,pratec,rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(its:ite):: rn + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite):: raincv,pratec + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rqvcuten,rqccuten,rqicuten + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rthcuten,rucuten,rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys):: delt,rdelt + +!----------------------------------------------------------------------------------------------------------------- + + delt = dt*stepcu + rdelt = 1./delt + + do i = its,ite + raincv(i) = rn(i)/stepcu + pratec(i) = rn(i)/(stepcu*dt) + enddo + + pp = 0 + do k = kts,kte + zz = kte - pp + do i = its,ite + rthcuten(i,k) = (tf(i,zz)-t(i,k))/exner(i,k)*rdelt + rqvcuten(i,k) = (qvf(i,zz)-qv(i,k))*rdelt + rqccuten(i,k) = (qcf(i,zz)-qc(i,k))*rdelt + rqicuten(i,k) = (qif(i,zz)-qi(i,k))*rdelt + rucuten(i,k) = (uf(i,zz)-u(i,k))*rdelt + rvcuten(i,k) = (vf(i,zz)-v(i,k))*rdelt + enddo + pp = pp + 1 + enddo + + errmsg = 'cu_ntiedtke_timestep_final OK' + errflg = 0 + + end subroutine cu_ntiedtke_timestep_final + +!================================================================================================================= +! level 1 subroutine 'cu_ntiedkte_run' + subroutine cu_ntiedtke_run(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & + & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx,errmsg,errflg) +!================================================================================================================= +! this is the interface between the model and the mass flux convection module +! m.tiedtke e.c.m.w.f. 1989 +! j.morcrette 1992 +!-------------------------------------------- +! modifications +! C. zhang & Yuqing Wang 2011-2017 +! +! modified from IPRC IRAM - yuqing wang, university of hawaii (ICTP REGCM4.4). +! +! The current version is stable. There are many updates to the old Tiedtke scheme (cu_physics=6) +! update notes: +! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. +! the major differences to the old Tiedtke (cu_physics=6) scheme are, +! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; +! Bechtold et al. 2004, 2008, 2014). +! (b) Non-equilibrium situations are considered in the closure for deep convection +! (Bechtold et al. 2014). +! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). +! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). +! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). +! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; +! Wu and Yanai 1994) +! +! other reference: tiedtke (1989, mwr, 117, 1779-1800) +! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 +! +! Note for climate simulation of Tropical Cyclones +! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation +! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km +! Set: momtrans = 2. +! pgcoef = 0.7 to 1.0 is good depends on the basin +! nonequil = .false. + +! Note for the diurnal simulation of precipitaton +! When nonequil = .true., the CAPE is relaxed toward to a value from PBL +! It can improve the diurnal precipitation over land. + +!--- input arguments: + integer,intent(in):: lq,km,km1 + integer,intent(in),dimension(lq):: lndj + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(lq):: dx + real(kind=kind_phys),intent(in),dimension(lq):: evap,hfx + real(kind=kind_phys),intent(in),dimension(lq,km):: pqvf,ptf + real(kind=kind_phys),intent(in),dimension(lq,km):: poz,pomg,pap + real(kind=kind_phys),intent(in),dimension(lq,km1):: pzz,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(lq):: zprecc + real(kind=kind_phys),intent(inout),dimension(lq,km):: pu,pv,pt,pqv,pqc,pqi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + logical,dimension(lq):: locum + integer:: i,j,k + integer,dimension(lq):: icbot,ictop,ktype + + real(kind=kind_phys):: ztmst,fliq,fice,ztc,zalf,tt + real(kind=kind_phys):: ztpp1,zew,zqs,zcor + real(kind=kind_phys):: dxref + + real(kind=kind_phys),dimension(lq):: pqhfl,prsfc,pssfc,phhfl,zrain + real(kind=kind_phys),dimension(lq):: scale_fac,scale_fac2 + + real(kind=kind_phys),dimension(lq,km):: pum1,pvm1,ztt,ptte,pqte,pvom,pvol,pverv,pgeo + real(kind=kind_phys),dimension(lq,km):: zqq,pcte + real(kind=kind_phys),dimension(lq,km):: ztp1,zqp1,ztu,zqu,zlu,zlude,zmfu,zmfd,zqsat + real(kind=kind_phys),dimension(lq,km1):: pgeoh + +!----------------------------------------------------------------------------------------------------------------- +! + ztmst=dt +! +! set scale-dependency factor when dx is < 15 km +! + dxref = 15000. + do j=1,lq + if (dx(j).lt.dxref) then + scale_fac(j) = (1.06133+log(dxref/dx(j)))**3 + scale_fac2(j) = scale_fac(j)**0.5 + else + scale_fac(j) = 1.+1.33e-5*dx(j) + scale_fac2(j) = 1. + end if + end do +! +! masv flux diagnostics. +! + do j=1,lq + zrain(j)=0.0 + locum(j)=.false. + prsfc(j)=0.0 + pssfc(j)=0.0 + pqhfl(j)=evap(j) + phhfl(j)=hfx(j) + pgeoh(j,km1)=g*pzz(j,km1) + end do +! +! convert model variables for mflux scheme +! + do k=1,km + do j=1,lq + 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) + pgeoh(j,k)=g*pzz(j,k) + tt=ztp1(j,k) + zew = foeewm(tt) + zqs = zew/pap(j,k) + zqs = min(0.5,zqs) + zcor = 1./(1.-vtmpc1*zqs) + zqsat(j,k)=zqs*zcor + pqte(j,k)=pqvf(j,k) + zqq(j,k) =pqte(j,k) + ptte(j,k)=ptf(j,k) + ztt(j,k) =ptte(j,k) + end do + end do +! +!----------------------------------------------------------------------- +!* 2. call 'cumastrn'(master-routine for cumulus parameterization) +! + call cumastrn & + & (lq, km, km1, km-1, ztp1, & + & zqp1, pum1, pvm1, pverv, zqsat, & + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc, & + & pssfc, locum, & + & ktype, icbot, ictop, ztu, zqu, & + & zlu, zlude, zmfu, zmfd, zrain, & + & pcte, phhfl, lndj, pgeoh, dx, & + & scale_fac, scale_fac2) +! +! to include the cloud water and cloud ice detrained from convection +! + do k=1,km + do j=1,lq + if(pcte(j,k).gt.0.) then + fliq=foealfa(ztp1(j,k)) + 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 + endif + end do + end do +! + do k=1,km + do j=1,lq + pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(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)) + end do + end do + + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) + end do + + if (lmfdudv) then + do k=1,km + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k)*ztmst + end do + end do + endif +! + errmsg = 'cu_ntiedtke_run OK' + errflg = 0 +! + return + end subroutine cu_ntiedtke_run + +!############################################################# +! +! level 2 subroutines +! +!############################################################# +!*********************************************************** +! subroutine cumastrn +!*********************************************************** + subroutine cumastrn & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, puen, pven, pverv, pqsen, & + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc, & + & pssfc, ldcum, & + & ktype, kcbot, kctop, ptu, pqu, & + & plu, plude, pmfu, pmfd, prain, & + & pcte, phhfl, lndj, zgeoh, dx, & + & scale_fac, scale_fac2) + implicit none +! +!***cumastrn* master routine for cumulus massflux-scheme +! m.tiedtke e.c.m.w.f. 1986/1987/1989 +! modifications +! y.wang i.p.r.c 2001 +! c.zhang 2012 +!***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. +!***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 'cuinin' +! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, +! and specify cloud base massflux +! (4) do cloud ascent in 'cuascn' in absence of downdrafts +! (5) do downdraft calculations: +! (a) determine values at lfs in 'cudlfsn' +! (b) determine moist descent in 'cuddrafn' +! (c) recalculate cloud base massflux considering the +! effect of cu-downdrafts +! (6) do final adjusments to convective fluxes in 'cuflxn', +! do evaporation in subcloud layer +! (7) calculate increments of t and q in 'cudtdqn' +! (8) calculate increments of u and v in 'cududvn' +!***externals. +! ---------- +! cuinin: initializes values at vertical grid used in cu-parametr. +! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus +! cuascn: cloud ascent for entraining plume +! cudlfsn: determines values at lfs for downdrafts +! cuddrafn:does moist descent for cumulus downdrafts +! cuflxn: final adjustments to convective fluxes (also in pbl) +! cudqdtn: updates tendencies for t and q +! cududvn: updates tendencies for u and v +!***switches. +! -------- +! 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) +! ------------------------------------------------ +! entrdd entrainment rate for cumulus downdrafts +! 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) +!----------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klev,klon,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon):: dx + real(kind=kind_phys),intent(in),dimension(klon):: pqhfl,phhfl + real(kind=kind_phys),intent(in),dimension(klon):: scale_fac,scale_fac2 + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,puen,pven,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,zgeoh + +!--- inout arguments: + integer,intent(inout),dimension(klon):: ktype,kcbot,kctop + logical,intent(inout),dimension(klon):: ldcum + + real(kind=kind_phys),intent(inout),dimension(klon):: pqsen + real(kind=kind_phys),intent(inout),dimension(klon):: prsfc,pssfc,prain + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pcte,ptte,pqte,pvom,pvol + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,plude,pmfu,pmfd + +!--- local variables and arrays: + logical:: llo1 + logical,dimension(klon):: loddraf,llo2 + + integer:: jl,jk,ik + integer:: ikb,ikt,icum,itopm2 + integer,dimension(klon):: kdpl,idtop,ictop0,ilwmin + integer,dimension(klon,klev):: ilab + + real(kind=kind_phys):: zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax + real(kind=kind_phys):: zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat + real(kind=kind_phys):: zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed + real(kind=kind_phys):: zduten,zdvten,ztdis,pgf_u,pgf_v + real(kind=kind_phys):: zlon + real(kind=kind_phys):: ztau,zerate,zderate,zmfa + real(kind=kind_phys),dimension(klon):: zmfs + real(kind=kind_phys),dimension(klon):: zsfl,zcape,zcape1,zcape2,ztauc,ztaubl,zheat + real(kind=kind_phys),dimension(klon):: wup,zdqcv + real(kind=kind_phys),dimension(klon):: wbase,zmfuub + real(kind=kind_phys),dimension(klon):: upbl + real(kind=kind_phys),dimension(klon):: zhcbase,zmfub,zmfub1,zdhpbl + real(kind=kind_phys),dimension(klon):: zmfuvb,zsum12,zsum22 + real(kind=kind_phys),dimension(klon):: zrfl + real(kind=kind_phys),dimension(klev):: pmean + real(kind=kind_phys),dimension(klon,klev):: pmfude_rate,pmfdde_rate + real(kind=kind_phys),dimension(klon,klev):: zdpmel + real(kind=kind_phys),dimension(klon,klev):: zmfuus,zmfdus,zuv2,ztenu,ztenv + real(kind=kind_phys),dimension(klon,klev):: ztenh,zqenh,zqsenh,ztd,zqd + real(kind=kind_phys),dimension(klon,klev):: zmfus,zmfds,zmfuq,zmfdq,zdmfup,zdmfdp,zmful + real(kind=kind_phys),dimension(klon,klev):: zuu,zvu,zud,zvd,zlglac + real(kind=kind_phys),dimension(klon,klevp1):: pmflxr,pmflxs + +!------------------------------------------- +! 1. specify constants and parameters +!------------------------------------------- + zcons=1./(g*ztmst) + zcons2=3./(g*ztmst) + +!-------------------------------------------------------------- +!* 2. initialize values at vertical grid points in 'cuini' +!-------------------------------------------------------------- + call cuinin & + & (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 +!---------------------------------- +!* (a) determine cloud base values in 'cutypen', +! and the cumulus type 1 or 2 +! ------------------------------------------- + call cutypen & + & ( klon, klev, klevp1, klevm1, pqen, & + & ztenh, zqenh, zqsenh, zgeoh, paph, & + & phhfl, pqhfl, pgeo, pqsen, pap, & + & pten, lndj, ptu, pqu, ilab, & + & ldcum, kcbot, ictop0, ktype, wbase, & + & plu, kdpl) + +!* (b) assign the first guess mass flux at cloud base +! ------------------------------------------ + do jl=1,klon + zdhpbl(jl)=0.0 + upbl(jl) = 0.0 + idtop(jl)=0 + end do + + do jk=2,klev + do jl=1,klon + if(jk.ge.kcbot(jl) .and. ldcum(jl)) then + zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& + & *(paph(jl,jk+1)-paph(jl,jk)) + if(lndj(jl) .eq. 0) then + wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) + upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + if(ktype(jl) == 1) then + zmfub(jl)= 0.1*zmfmax + else if ( ktype(jl) == 2 ) then + zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) + zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) + zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe + zdh = g*max(zdh,1.e5*zdqmin) + if ( zdhpbl(jl) > 0. ) then + zmfub(jl) = zdhpbl(jl)/zdh + zmfub(jl) = min(zmfub(jl),zmfmax) + else + zmfub(jl) = 0.1*zmfmax + ldcum(jl) = .false. + end if + end if + else + zmfub(jl) = 0. + end if + end do +!------------------------------------------------------ +!* 4.0 determine cloud ascent for entraining plume +!------------------------------------------------------ +!* (a) do ascent in 'cuasc'in absence of downdrafts +!---------------------------------------------------------- + call cuascn & + & (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, & + & zmfus, zmfuq, zmful, plude, zdmfup, & + & kcbot, kctop, ictop0, icum, ztmst, & + & zqsenh, zlglac, lndj, wup, wbase, & + & kdpl, pmfude_rate) + +!* (b) check cloud depth and change entrainment rate accordingly +! calculate precipitation rate (for downdraft calculation) +!------------------------------------------------------------------ + do jl=1,klon + if ( ldcum(jl) ) then + ikb = kcbot(jl) + itopm2 = kctop(jl) + zpbmpt = paph(jl,ikb) - paph(jl,itopm2) + if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 + if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 + ictop0(jl) = kctop(jl) + end if + zrfl(jl)=zdmfup(jl,1) + end do + + do jk=2,klev + do jl=1,klon + zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) + end do + end do + + do jk = 1,klev + do jl = 1,klon + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + zdpmel(jl,jk) = 0. + end do + end do + +!----------------------------------------- +!* 6.0 cumulus downdraft calculations +!----------------------------------------- + if(lmfdd) then +!* (a) determine lfs in 'cudlfsn' +!-------------------------------------- + call cudlfsn & + & (klon, klev,& + & kcbot, kctop, lndj, ldcum, & + & ztenh, zqenh, puen, pven, & + & pten, pqsen, pgeo, & + & zgeoh, paph, ptu, pqu, plu, & + & zuu, zvu, zmfub, zrfl, & + & ztd, zqd, zud, zvd, & + & pmfd, zmfds, zmfdq, zdmfdp, & + & idtop, loddraf) +!* (b) determine downdraft t,q and fluxes in 'cuddrafn' +!------------------------------------------------------------ + call cuddrafn & + & (klon, klev, loddraf, & + & ztenh, zqenh, puen, pven, & + & pgeo, zgeoh, paph, zrfl, & + & ztd, zqd, zud, zvd, pmfu, & + & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate) +!----------------------------------------------------------- + end if +! +!----------------------------------------------------------------------- +!* 6.0 closure and clean work +! ------ +!-- 6.1 recalculate cloud base massflux from a cape closure +! for deep convection (ktype=1) +! + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 1) then + ikb = kcbot(jl) + ikt = kctop(jl) + zheat(jl)=0.0 + zcape(jl)=0.0 + zcape1(jl)=0.0 + zcape2(jl)=0.0 + zmfub1(jl)=zmfub(jl) + + ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & + ((2.+ min(15.0,wup(jl)))*g) + if(lndj(jl) .eq. 0) then + upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) + ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) + ztaubl(jl) = min(300., ztaubl(jl)) + else + ztaubl(jl) = ztauc(jl) + end if + end if + end do +! + do jk = 1 , klev + do jl = 1 , klon + llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 + if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then + ikb = kcbot(jl) + zdz = pgeo(jl,jk-1)-pgeo(jl,jk) + zdp = pap(jl,jk)-pap(jl,jk-1) + zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & + ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & + (g*(pmfu(jl,jk)+pmfd(jl,jk))) + zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & + vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp + end if + + if ( llo1 .and. jk >= kcbot(jl) ) then + if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then + zdp = paph(jl,jk+1)-paph(jl,jk) + zcape2(jl) = zcape2(jl) + ztaubl(jl)* & + ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl).and.ktype(jl).eq.1) then + ikb = kcbot(jl) + ikt = kctop(jl) + ztauc(jl) = max(ztmst,ztauc(jl)) + ztauc(jl) = max(360.,ztauc(jl)) + ztauc(jl) = min(10800.,ztauc(jl)) + ztau = ztauc(jl) * scale_fac(jl) + if(nonequil) then + zcape2(jl)= max(0.,zcape2(jl)) + zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) + else + zcape(jl) = max(0.,min(zcape1(jl),5000.)) + end if + zheat(jl) = max(1.e-4,zheat(jl)) + zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) + zmfub1(jl) = max(zmfub1(jl),0.001) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub1(jl)=min(zmfub1(jl),zmfmax) + end if + end do +! +!* 6.2 recalculate convective fluxes due to effect of +! downdrafts on boundary layer moist static energy budget (ktype=2) +!-------------------------------------------------------- + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 2) then + ikb=kcbot(jl) + if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then + zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) + 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),cmfcmin) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 +! using moist static engergy closure instead of moisture closure + zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & + & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe + zdh=g*max(zdh,1.e5*zdqmin) + if(zdhpbl(jl).gt.0.)then + zmfub1(jl)=zdhpbl(jl)/zdh + else + zmfub1(jl) = zmfub(jl) + end if + zmfub1(jl) = zmfub1(jl)/scale_fac2(jl) + zmfub1(jl) = min(zmfub1(jl),zmfmax) + end if + +!* 6.3 mid-level convection - nothing special +!--------------------------------------------------------- + if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then + zmfub1(jl) = zmfub(jl) + end if + + end do + +!* 6.4 scaling the downdraft mass flux +!--------------------------------------------------------- + do jk=1,klev + do jl=1,klon + if( ldcum(jl) ) then + zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) + 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 + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac + end if + end do + end do + +!* 6.5 scaling the updraft mass flux +! -------------------------------------------------------- + do jl = 1,klon + if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + ikb = kcbot(jl) + if ( jk>ikb ) then + zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + pmfu(jl,jk) = pmfu(jl,ikb)*zdz + end if + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then + pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) + zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) + zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) + zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) + plude(jl,jk) = plude(jl,jk)*zmfs(jl) + pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + end if + end do + end do + +!* 6.6 if ktype = 2, kcbot=kctop is not allowed +! --------------------------------------------------- + do jl = 1,klon + if ( ktype(jl) == 2 .and. & + kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then + ldcum(jl) = .false. + ktype(jl) = 0 + end if + end do + + if ( .not. lmfscv .or. .not. lmfpen ) then + do jl = 1,klon + llo2(jl) = .false. + if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & + (.not. lmfpen .and. ktype(jl) == 1) ) then + llo2(jl) = .true. + ldcum(jl) = .false. + end if + end do + end if + +!* 6.7 set downdraft mass fluxes to zero above cloud top +!---------------------------------------------------- + do jl = 1,klon + if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then + idtop(jl) = kctop(jl) + 1 + end if + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) ) then + if ( jk < idtop(jl) ) then + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + else if ( jk == idtop(jl) ) then + pmfdde_rate(jl,jk) = 0. + end if + end if + end do + end do +!---------------------------------------------------------- +!* 7.0 determine final convective fluxes in 'cuflx' +!---------------------------------------------------------- + call cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ztenh, zqenh & + & , paph, pap, zgeoh, lndj, ldcum & + & , kcbot, kctop, idtop, itopm2 & + & , ktype, loddraf & + & , pmfu, pmfd, zmfus, zmfds & + & , zmfuq, zmfdq, zmful, plude & + & , zdmfup, zdmfdp, zdpmel, zlglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! some adjustments needed + do jl=1,klon + zmfs(jl) = 1. + zmfuub(jl)=0. + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zmfmax = pmfu(jl,jk)*0.98 + if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then + zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) + end if + end if + end do + end do + + do jk = 2 , klev + do jl = 1 , klon + if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then + pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) + zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) + zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) + zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) + pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) + zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) + end if + end do + end do + + do jk = 2 , klev - 1 + do jl = 1, klon + if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then + zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) + if ( zerate < 0. ) then + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate + end if + end if + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) + if ( zerate < 0. ) then + pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate + end if + zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & + pmflxr(jl,jk) - pmflxs(jl,jk) + zdmfdp(jl,jk) = 0. + end if + end do + end do + +! avoid negative humidities at ddraught top + do jl = 1,klon + if ( loddraf(jl) ) then + jk = idtop(jl) + ik = min(jk+1,klev) + if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then + zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) + end if + end if + end do + +! avoid negative humidities near cloud top because gradient of precip flux +! and detrainment / liquid water flux are too large + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then + zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) + zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & + zmfuq(jl,jk) - zmfdq(jl,jk) + & + zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) + zmfa = (zmfa-plude(jl,jk))*zdz + if ( pqen(jl,jk)+zmfa < 0. ) then + plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz + end if + if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. + end if + if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. + if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. + end do + end do + + do jl=1,klon + prsfc(jl) = pmflxr(jl,klev+1) + pssfc(jl) = pmflxs(jl,klev+1) + end do + +!---------------------------------------------------------------- +!* 8.0 update tendencies for t and q in subroutine cudtdq +!---------------------------------------------------------------- + call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & + ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & + zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & + zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) +!---------------------------------------------------------------- +!* 9.0 update tendencies for u and u in subroutine cududv +!---------------------------------------------------------------- + if(lmfdudv) then + do jk = klev-1 , 2 , -1 + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then + ikb = kdpl(jl) + zuu(jl,jk) = puen(jl,ikb-1) + zvu(jl,jk) = pven(jl,ikb-1) + else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then + zuu(jl,jk) = puen(jl,jk-1) + zvu(jl,jk) = pven(jl,jk-1) + end if + if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then + if(momtrans .eq. 1)then + zfac = 0. + if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. + if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. + zerate = pmfu(jl,jk) - pmfu(jl,ik) + & + (1.+zfac)*pmfude_rate(jl,jk) + zderate = (1.+zfac)*pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa + else + pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) + zderate = pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa + end if + end if + end if + end do + end do + + if(lmfdd) then + do jk = 3 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == idtop(jl) ) then + zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) + zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) + else if ( jk > idtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & + zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa + zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & + zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa + end if + end if + end do + end do + end if +! -------------------------------------------------- +! rescale massfluxes for stability in Momentum +!------------------------------------------------------------------------ + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons + if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + zmfuus(jl,jk) = pmfu(jl,jk) + zmfdus(jl,jk) = pmfd(jl,jk) + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + end if + end do + end do +!* 9.1 update u and v in subroutine cududvn +!------------------------------------------------------------------- + do jk = 1 , klev + do jl = 1, klon + ztenu(jl,jk) = pvom(jl,jk) + ztenv(jl,jk) = pvol(jl,jk) + end do + end do + + call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & + ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & + zud,zvu,zvd,pvom,pvol) + +! calculate KE dissipation + do jl = 1, klon + zsum12(jl) = 0. + zsum22(jl) = 0. + end do + do jk = 1 , klev + do jl = 1, klon + zuv2(jl,jk) = 0. + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zdz = (paph(jl,jk+1)-paph(jl,jk)) + zduten = pvom(jl,jk) - ztenu(jl,jk) + zdvten = pvol(jl,jk) - ztenv(jl,jk) + zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) + zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz + zsum12(jl) = zsum12(jl) - & + (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then + ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) + ptte(jl,jk) = ptte(jl,jk) + ztdis + end if + end do + end do + + end if + +!---------------------------------------------------------------------- +!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF +! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO +! --------------------------------------------------- + if ( .not. lmfscv .or. .not. lmfpen ) then + do jk = 2 , klev + do jl = 1, klon + if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then + ptu(jl,jk) = pten(jl,jk) + pqu(jl,jk) = pqen(jl,jk) + plu(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + end if + end do + end do + do jl = 1, klon + if ( llo2(jl) ) then + kctop(jl) = klev - 1 + kcbot(jl) = klev - 1 + end if + end do + end if + + return + end subroutine cumastrn + +!********************************************** +! level 3 subroutine cuinin +!********************************************** +! + subroutine cuinin & + & (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) + implicit none +! 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 +! ---------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon,klev,klevp1,klevm1 + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh + +!--- output arguments: + integer,intent(out),dimension(klon):: klwmin + integer,intent(out),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,ptd,pqu,pqd,plu + real(kind=kind_phys),intent(out),dimension(klon,klev):: puu,pud,pvu,pvd + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfd,pmfus,pmfds,pmfuq,pmfdq + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pdmfup,pdmfdp,plude,pdpmel + +!--- local variables and arrays: + logical,dimension(klon):: loflag + integer:: jl,jk + integer:: icall,ik + real(kind=kind_phys):: zzs + real(kind=kind_phys),dimension(klon):: zph,zwmax + +!------------------------------------------------------------ +!* 1. specify large scale parameters at half levels +!* adjust temperature fields if staticly unstable +!* find level of maximum vertical velocity +! ----------------------------------------------------------- + do jk=2,klev + do jl=1,klon + ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & + & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqenh(jl,jk) = pqen(jl,jk-1) + pqsenh(jl,jk)= pqsen(jl,jk-1) + zph(jl)=paph(jl,jk) + loflag(jl)=.true. + end do + + if ( jk >= klev-1 .or. jk < 2 ) cycle + ik=jk + icall=0 + call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) + do 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.) + end do + end do + + do 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) + klwmin(jl)=klev + zwmax(jl)=0. + end do + + do jk=klevm1,2,-1 + do 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 + end do + end do + + do jk=klev,3,-1 + do jl=1,klon + if(pverv(jl,jk).lt.zwmax(jl)) then + zwmax(jl)=pverv(jl,jk) + klwmin(jl)=jk + end if + end do + end do +!----------------------------------------------------------- +!* 2.0 initialize values for updrafts and downdrafts +!----------------------------------------------------------- + do jk=1,klev + ik=jk-1 + if(jk.eq.1) ik=1 + do 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) + klab(jl,jk)=0 + end do + end do + return + end subroutine cuinin + +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cutypen & + & ( klon, klev, klevp1, klevm1, pqen, & + & ptenh, pqenh, pqsenh, pgeoh, paph, & + & hfx, qfx, pgeo, pqsen, pap, & + & pten, lndj, cutu, cuqu, culab, & + & ldcum, cubot, cutop, ktype, wbase, & + & culu, kdpl) +! zhang & wang iprc 2011-2013 +!***purpose. +! -------- +! to produce first guess updraught for cu-parameterizations +! calculates condensation level, and sets updraught base variables and +! first guess cloud type +!***interface +! --------- +! this routine is called from *cumastr*. +! input are environm. values of t,q,p,phi at half levels. +! it returns cloud types as follows; +! ktype=1 for deep cumulus +! ktype=2 for shallow cumulus +!***method. +! -------- +! based on a simplified updraught equation +! partial(hup)/partial(z)=eta(h - hup) +! eta is the entrainment rate for test parcel +! h stands for dry static energy or the total water specific humidity +! references: christian jakob, 2003: a new subcloud model for +! mass-flux convection schemes +! influence on triggering, updraft properties, and model +! climate, mon.wea.rev. +! 131, 2765-2778 +! and +! ifs documentation - cy36r1,cy38r1 +!***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) +! rho - density of the lowest model level +! qfx - net upward moisture flux at the surface (kg/m^2/s) +! hfx - net upward heat flux at the surface (w/m^2) +!***variables output by cutype: +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon,klev,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + + real(kind=kind_phys),intent(in),dimension(klon):: qfx,hfx + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh + +!--- output arguments: + logical,intent(out),dimension(klon):: ldcum + + integer,intent(out),dimension(klon):: ktype + integer,intent(out),dimension(klon):: cubot,cutop,kdpl + integer,intent(out),dimension(klon,klev):: culab + + real(kind=kind_phys),intent(out),dimension(klon):: wbase + real(kind=kind_phys),intent(out),dimension(klon,klev):: cutu,cuqu,culu + +!--- local variables and arrays: + logical:: needreset + logical,dimension(klon):: lldcum + logical,dimension(klon):: loflag,deepflag,resetflag + + integer:: jl,jk,ik,icall,levels + integer:: nk,is,ikb,ikt + integer,dimension(klon):: kctop,kcbot + integer,dimension(klon):: zcbase,itoppacel + integer,dimension(klon,klev):: klab + + real(kind=kind_phys):: rho,part1,part2,root,conw,deltt,deltq + real(kind=kind_phys):: zz,zdken,zdq + real(kind=kind_phys):: fscale,crirh1,pp + real(kind=kind_phys):: atop1,atop2,abot + real(kind=kind_phys):: tmix,zmix,qmix,pmix + real(kind=kind_phys):: zlglac,dp + real(kind=kind_phys):: zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real(kind=kind_phys):: zpdifftop, zpdiffbot + + real(kind=kind_phys),dimension(klon):: eta,dz,coef,zqold,zph + real(kind=kind_phys),dimension(klon,klev):: dh,dhen,kup,vptu,vten + real(kind=kind_phys),dimension(klon,klev):: ptu,pqu,plu + real(kind=kind_phys),dimension(klon,klev):: zbuo,abuoy,plude + +!-------------------------------------------------------------- + do jl=1,klon + kcbot(jl)=klev + kctop(jl)=klev + kdpl(jl) =klev + ktype(jl)=0 + wbase(jl)=0. + ldcum(jl)=.false. + end do + +!----------------------------------------------------------- +! let's do test,and check the shallow convection first +! the first level is klev +! define deltat and deltaq +!----------------------------------------------------------- + do jk=1,klev + do jl=1,klon + plu(jl,jk)=culu(jl,jk) ! parcel liquid water + ptu(jl,jk)=cutu(jl,jk) ! parcel temperature + pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity + klab(jl,jk)=culab(jl,jk) + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + vten(jl,jk)=0.0 ! environment virtual temperature + zbuo(jl,jk)=0.0 ! parcel buoyancy + abuoy(jl,jk)=0.0 + end do + end do + + do jl=1,klon + zqold(jl) = 0. + lldcum(jl) = .false. + loflag(jl) = .true. + end do + +! check the levels from lowest level to second top level + do jk=klevm1,2,-1 + +! define the variables at the first level + if(jk .eq. klevm1) then + do jl=1,klon + rho=pap(jl,klev)/ & + & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) + part1 = 1.5*0.4*pgeo(jl,klev)/ & + & (rho*pten(jl,klev)) + part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) + root = 0.001-part1*part2 + if(part2 .lt. 0.) then + conw = 1.2*(root)**t13 + deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) + deltq = max(1.5*qfx(jl)/(rho*conw),0.) + kup(jl,klev) = 0.5*(conw**2) + pqu(jl,klev)= pqenh(jl,klev) + deltq + dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd + dh(jl,klev) = dhen(jl,klev) + deltt*cpd + ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd + vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) + vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) + zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) + klab(jl,klev) = 1 + else + loflag(jl) = .false. + end if + end do + end if + + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then + eta(jl) = 0.8/(pgeo(jl,jk)*zrg)+2.e-4 + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = min(plu(jl,jk),5.e-3) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot + +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 2 + ldcum(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = klev + else + cutop(jl) = -1 + cubot(jl) = -1 + kdpl(jl) = klev - 1 + ldcum(jl) = .false. + wbase(jl) = 0. + end if + end do + + do jk=klev,1,-1 + do jl=1,klon + ikt = kctop(jl) + if(jk .ge. ikt)then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + end if + end do + end do + +!----------------------------------------------------------- +! next, let's check the deep convection +! the first level is klevm1-1 +! define deltat and deltaq +!---------------------------------------------------------- +! we check the parcel starting level by level +! assume the mix-layer is 60hPa + deltt = 0.2 + deltq = 1.0e-4 + do jl=1,klon + deepflag(jl) = .false. + end do + + do jk=klev,1,-1 + do jl=1,klon + if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk + end do + end do + + do levels=klevm1-1,klev/2+1,-1 ! loop starts + do jk=1,klev + do jl=1,klon + plu(jl,jk)=0.0 ! parcel liquid water + ptu(jl,jk)=0.0 ! parcel temperature + pqu(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading + vten(jl,jk)=0.0 ! environment virtual temperature + abuoy(jl,jk)=0.0 + zbuo(jl,jk)=0.0 + klab(jl,jk)=0 + end do + end do + + do jl=1,klon + kcbot(jl) = levels + kctop(jl) = levels + zqold(jl) = 0. + lldcum(jl) = .false. + resetflag(jl)= .false. + loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) + end do + +! start the inner loop to search the deep convection points + do jk=levels,2,-1 + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! define the variables at the departure level + if(jk .eq. levels) then + do jl=1,klon + if(loflag(jl)) then + if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then + tmix=0. + qmix=0. + zmix=0. + pmix=0. + do nk=jk+2,jk,-1 + if(pmix < 50.e2) then + dp = paph(jl,nk) - paph(jl,nk-1) + tmix=tmix+dp*ptenh(jl,nk) + qmix=qmix+dp*pqenh(jl,nk) + zmix=zmix+dp*pgeoh(jl,nk) + pmix=pmix+dp + end if + end do + tmix=tmix/pmix + qmix=qmix/pmix + zmix=zmix/pmix + else + tmix=ptenh(jl,jk+1) + qmix=pqenh(jl,jk+1) + zmix=pgeoh(jl,jk+1) + end if + + pqu(jl,jk+1) = qmix + deltq + dhen(jl,jk+1)= zmix + tmix*cpd + dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd + ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd + kup(jl,jk+1) = 0.5 + klab(jl,jk+1)= 1 + vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) + vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) + zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) + end if + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then +! define the fscale + fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) + eta(jl) = 1.75e-3*fscale + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = 0.5*plu(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else + if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end if + end do + + end do ! end all the levels + + needreset = .false. + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 1 + ldcum(jl) = .true. + deepflag(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = levels+1 + needreset = .true. + resetflag(jl)= .true. + end if + end do + + if(needreset) then + do jk=klev,1,-1 + do jl=1,klon + if(resetflag(jl)) then + ikt = kctop(jl) + ikb = kdpl(jl) + if(jk .le. ikb .and. jk .ge. ikt )then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + else + culab(jl,jk) = 1 + cutu(jl,jk) = ptenh(jl,jk) + cuqu(jl,jk) = pqenh(jl,jk) + culu(jl,jk) = 0. + end if + if ( jk .lt. ikt ) culab(jl,jk) = 0 + end if + end do + end do + end if + + end do ! end all cycles + + return + end subroutine cutypen + +!----------------------------------------------------------------- +! level 3 subroutines 'cuascn' +!----------------------------------------------------------------- + subroutine cuascn & + & (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, & + & pmfus, pmfuq, pmful, plude, pdmfup, & + & kcbot, kctop, kctop0, kcum, ztmst, & + & pqsenh, plglac, lndj, wup, wbase, & + & kdpl, pmfude_rate) + + implicit none +! 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. +! c.zhang iprc 05/12 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 +! --------- +! *cuadjtqn* adjust t and q due to condensation in ascent +! *cuentrn* calculate entrainment/detrainment rates +! *cubasmcn* 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. +! 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 - cloud top level +! kctop0 [ictop0] - estimate of cloud top. (cumastr) +! kcum [icum] - flag to control the call + +!--- input arguments: + integer,intent(in):: klev,klon,klevp1,klevm1 + integer,intent(in),dimension(klon):: lndj + integer,intent(in),dimension(klon):: klwmin + integer,intent(in),dimension(klon):: kdpl + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon):: wbase + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,puen,pven,pqte,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: pap,pgeo + real(kind=kind_phys),intent(in),dimension(klon,klevp1):: paph,pgeoh + +!--- inout arguments: + logical,intent(inout),dimension(klon):: ldcum + + integer,intent(inout):: kcum + integer,intent(inout),dimension(klon):: kcbot,kctop,kctop0 + integer,intent(inout),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(inout),dimension(klon):: phcbase + real(kind=kind_phys),intent(inout),dimension(klon):: pmfub + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenh,pqenh,pqsenh + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptu,pqu,plu,puu,pvu + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful,plude,pdmfup + +!--- output arguments: + integer,intent(out),dimension(klon):: ktype + + real(kind=kind_phys),intent(out),dimension(klon):: wup + real(kind=kind_phys),intent(out),dimension(klon,klev):: plglac,pmfude_rate + +!--- local variables and arrays: + logical:: llo2,llo3 + logical,dimension(klon):: loflag,llo1 + + integer:: jl,jk + integer::ikb,icum,itopm2,ik,icall,is,jlm,jll + integer,dimension(klon):: jlx + + real(kind=kind_phys):: zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 + real(kind=kind_phys):: zmftest,zmfmax,zqeen,zseen,zscde,zqude + real(kind=kind_phys):: zmfusk,zmfuqk,zmfulk + real(kind=kind_phys):: zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco + real(kind=kind_phys):: zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold + real(kind=kind_phys):: zrnew,zz,zdmfeu,zdmfdu,dp + real(kind=kind_phys):: zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd + real(kind=kind_phys):: atop1,atop2,abot + + real(kind=kind_phys),dimension(klon):: eta,dz,zoentr,zdpmean + real(kind=kind_phys),dimension(klon):: zph,zdmfen,zdmfde,zmfuu,zmfuv,zpbase,zqold,zluold,zprecip + real(kind=kind_phys),dimension(klon,klev):: zlrain,zbuo,kup,zodetr,pdmfen + +!-------------------------------- +!* 1. specify parameters +!-------------------------------- + zcons2=3./(g*ztmst) + zfacbuo = 0.5/(1.+0.5) + zprcdgw = cprcon*zrg + z_cldmax = 5.e-3 + z_cwifrac = 0.5 + z_cprc2 = 0.5 + z_cwdrag = (3.0/8.0)*0.506/0.2 +!--------------------------------- +! 2. set default values +!--------------------------------- + llo3 = .false. + do jl=1,klon + zluold(jl)=0. + wup(jl)=0. + zdpmean(jl)=0. + zoentr(jl)=0. + if(.not.ldcum(jl)) then + ktype(jl)=0 + kcbot(jl) = -1 + pmfub(jl) = 0. + pqu(jl,klev) = 0. + end if + end do + + ! initialize variout quantities + do jk=1,klev + do jl=1,klon + if(jk.ne.kcbot(jl)) plu(jl,jk)=0. + pmfu(jl,jk)=0. + pmfus(jl,jk)=0. + pmfuq(jl,jk)=0. + pmful(jl,jk)=0. + plude(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk)=0. + zlrain(jl,jk)=0. + zbuo(jl,jk)=0. + kup(jl,jk)=0. + pdmfen(jl,jk) = 0. + pmfude_rate(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 + end do + end do + + do jl = 1,klon + if ( ktype(jl) == 3 ) ldcum(jl) = .false. + end do +!------------------------------------------------ +! 3.0 initialize values at cloud base level +!------------------------------------------------ + do jl=1,klon + kctop(jl)=kcbot(jl) + if(ldcum(jl)) then + ikb = kcbot(jl) + kup(jl,ikb) = 0.5*wbase(jl)**2 + pmfu(jl,ikb) = pmfub(jl) + pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) + pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) + pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) + end if + end do +! +!----------------------------------------------------------------- +! 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 *cuadjtqn*, +! then check for buoyancy and set flags accordingly +!----------------------------------------------------------------- +! + do jk=klevm1,3,-1 +! specify cloud base values for midlevel convection +! in *cubasmc* in case there is not already convection +! --------------------------------------------------------------------- + ik=jk + call cubasmcn& + & (klon, klev, klevm1, ik, pten, & + & pqen, pqsen, puen, pven, pverv, & + & pgeo, pgeoh, ldcum, ktype, klab, zlrain, & + & pmfu, pmfub, kcbot, ptu, & + & pqu, plu, puu, pvu, pmfus, & + & pmfuq, pmful, pdmfup) + is = 0 + jlm = 0 + do jl = 1,klon + loflag(jl) = .false. + zprecip(jl) = 0. + llo1(jl) = .false. + is = is + klab(jl,jk+1) + if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 + if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & + (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then + loflag(jl) = .true. + jlm = jlm + 1 + jlx(jlm) = jl + end if + zph(jl) = paph(jl,jk) + if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfub(jl) > 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 + pmfub(jl) = zmfmax + end if + pmfub(jl)=min(pmfub(jl),zmfmax) + end if + end do + + if(is.gt.0) llo3 = .true. +! +!* specify entrainment rates in *cuentr* +! ------------------------------------- + ik=jk + call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & + pgeoh,pmfu,zdmfen,zdmfde) +! +! do adiabatic ascent for entraining/detraining plume + if(llo3) then +! ------------------------------------------------------- +! + do jl = 1,klon + zqold(jl) = 0. + end do + do jll = 1 , jlm + jl = jlx(jll) + zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) + if ( jk == kcbot(jl) ) then + zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & + 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) + end if + if ( jk < kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + zxs = max(pmfu(jl,jk+1)-zmfmax,0.) + wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) + zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) + zdmfen(jl) = zoentr(jl) + if ( ktype(jl) >= 2 ) then + zdmfen(jl) = 2.0*zdmfen(jl) + zdmfde(jl) = zdmfen(jl) + end if + zdmfde(jl) = zdmfde(jl) * & + (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) + zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zchange = max(zmftest-zmfmax,0.) + zxe = max(zchange-zxs,0.) + zdmfen(jl) = zdmfen(jl) - zxe + zchange = zchange - zxe + zdmfde(jl) = zdmfde(jl) + zchange + end if + pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zqeen = pqenh(jl,jk+1)*zdmfen(jl) + zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) + zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) + zqude = pqu(jl,jk+1)*zdmfde(jl) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + 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) + zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & + (1./max(cmfcmin,pmfu(jl,jk))) + zluold(jl) = plu(jl,jk) + end do +! reset to environmental values if below departure level + do jl = 1,klon + if ( jk > kdpl(jl) ) then + ptu(jl,jk) = ptenh(jl,jk) + pqu(jl,jk) = pqenh(jl,jk) + plu(jl,jk) = 0. + zluold(jl) = plu(jl,jk) + end if + end do +!* do corrections for moist ascent +!* by adjusting t,q and l in *cuadjtq* +!------------------------------------------------ + ik=jk + icall=1 +! + if ( jlm > 0 ) then + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + end if +! compute the upfraft speed in cloud layer + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + plglac(jl,jk) = plu(jl,jk) * & + ((1.-foealfa(ptu(jl,jk)))- & + (1.-foealfa(ptu(jl,jk+1)))) + ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + klab(jl,jk) = 2 + plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) + zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & + zlrain(jl,jk+1)) + zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = zbc - zbe +! set flags for the case of midlevel convection + if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then + if ( zbuo(jl,jk) > -0.5 ) then + ldcum(jl) = .true. + kctop(jl) = jk + kup(jl,jk) = 0.5 + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + plude(jl,jk) = 0. + plu(jl,jk) = 0. + end if + end if + if ( klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. ) then + ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) + pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) + zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + end if + zbuoc = (zbuo(jl,jk) / & + (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & + (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 + zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc +! mixing and "pressure" gradient term in upper troposphere + if ( zdmfen(jl) > 0. ) then + zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + else + zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + end if + kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & + (1.+zdken) + if ( zbuo(jl,jk) < 0. ) then + zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) + zkedke = max(0.,min(1.,zkedke)) + zmfun = sqrt(zkedke)*pmfu(jl,jk+1) + zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + end if + if ( zbuo(jl,jk) > -0.2 ) then + ikb = kcbot(jl) + zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & + pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & + zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) + else + zoentr(jl) = 0. + end if +! erase values if below departure level + if ( jk > kdpl(jl) ) then + pmfu(jl,jk) = pmfu(jl,jk+1) + kup(jl,jk) = 0.5 + end if + if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then + kctop(jl) = jk + llo1(jl) = .true. + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + end if +! save detrainment rates for updraught + if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) + end if + else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfude_rate(jl,jk) = zdmfde(jl) + end if + end do + + do jl = 1,klon + if ( llo1(jl) ) then +! conversions only proceeds if plu is greater than a threshold liquid water +! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation +! generation from small water contents. + if ( lndj(jl).eq.1 ) then + zdshrd = 5.e-4 + else + zdshrd = 3.e-4 + end if + ikb=kcbot(jl) + if ( plu(jl,jk) > zdshrd )then + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) + zprcon = zprcdgw/(0.75*zwu) +! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) + zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) + zcbf = 1. + z_cprc2*sqrt(zdt) + zzco = zprcon*zcbf + zlcrit = zdshrd/zcbf + zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) + zc = (plu(jl,jk)-zluold(jl)) + zarg = (plu(jl,jk)/zlcrit)**2 + if ( zarg < 25.0 ) then + zd = zzco*(1.-exp(-zarg))*zdfi + else + zd = zzco*zdfi + end if + zint = exp(-zd) + zlnew = zluold(jl)*zint + zc/zd*(1.-zint) + zlnew = max(0.,min(plu(jl,jk),zlnew)) + zlnew = min(z_cldmax,zlnew) + zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) + pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) + plu(jl,jk) = zlnew + end if + end if + end do + do jl = 1, klon + if ( llo1(jl) ) then + if ( zlrain(jl,jk) > 0. ) then + zvw = 21.18*zlrain(jl,jk)**0.2 + zvi = z_cwifrac*zvw + zalfaw = foealfa(ptu(jl,jk)) + zvv = zalfaw*zvw + (1.-zalfaw)*zvi + zrold = zlrain(jl,jk) - zprecip(jl) + zc = zprecip(jl) + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) + zd = zvv/zwu + zint = exp(-zd) + zrnew = zrold*zint + zc/zd*(1.-zint) + zrnew = max(0.,min(zlrain(jl,jk),zrnew)) + zlrain(jl,jk) = zrnew + end if + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + 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 do + end if + end do +!---------------------------------------------------------------------- +! 5. final calculations +! ------------------ + do jl = 1,klon + if ( kctop(jl) == -1 ) ldcum(jl) = .false. + kcbot(jl) = max(kcbot(jl),kctop(jl)) + if ( ldcum(jl) ) then + wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) + wup(jl) = sqrt(2.*wup(jl)) + end if + end do + + return + end subroutine cuascn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudlfsn & + & (klon, klev, & + & kcbot, kctop, lndj, ldcum, & + & ptenh, pqenh, puen, pven, & + & pten, pqsen, pgeo, & + & pgeoh, paph, ptu, pqu, plu, & + & puu, pvu, 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. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pten* provisional environment temperature (t+1) k +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *ptu* temperature in updrafts k +! *pqu* spec. humidity in updrafts kg/kg +! *plu* liquid water content in updrafts kg/kg +! *puu* u-velocity in updrafts m/s +! *pvu* v-velocity in updrafts m/s +! *pmfub* massflux in updrafts at cloud base kg/(m2*s) + +! updated parameters (real): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! output parameters (integer): + +! *kdtop* top level of downdrafts + +! output parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! externals +! --------- +! *cuadjtq* for calculating wet bulb t and q at lfs +!---------------------------------------------------------------------- + + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + + integer,intent(in):: klev + integer,intent(in),dimension(klon):: lndj + integer,intent(in),dimension(klon):: kcbot,kctop + + real(kind=kind_phys),intent(in),dimension(klon):: pmfub + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqsen,pgeo,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptu,pqu,puu,pvu,plu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon):: prfl + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pud,pvd + +!--- output arguments: + logical,intent(out),dimension(klon):: lddraf + integer,intent(out),dimension(klon):: kdtop + + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptd,pqd,pmfd,pmfds,pmfdq,pdmfdp + +!--- local variables and arrays: + logical,dimension(klon):: llo2 + integer:: jl,jk + integer:: is,ik,icall,ike + integer,dimension(klon):: ikhsmin + + real(kind=kind_phys):: zhsk,zttest,zqtest,zbuo,zmftop + real(kind=kind_phys),dimension(klon):: zcond,zph,zhsmin + real(kind=kind_phys),dimension(klon,klev):: ztenwb,zqenwb + +!---------------------------------------------------------------------- + +! 1. set default values for downdrafts +! --------------------------------- + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klev+1 + ikhsmin(jl)=klev+1 + zhsmin(jl)=1.e8 + enddo +!---------------------------------------------------------------------- + +! 2. determine level of free sinking: +! downdrafts shall start at model level of minimum +! of saturation moist static energy or below +! respectively + +! for every point and proceed as follows: + +! (1) determine level of minimum of hs +! (2) determine wet bulb environmental t and q +! (3) do mixing with cumulus cloud air +! (4) check for negative buoyancy +! (5) if buoyancy>0 repeat (2) to (4) for next +! level below + +! 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) +! ---------------------------------------------------- + do jk=3,klev-2 + do jl=1,klon + zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & + & foelhm(pten(jl,jk))*pqsen(jl,jk) + if(zhsk .lt. zhsmin(jl)) then + zhsmin(jl) = zhsk + ikhsmin(jl)= jk + end if + end do + end do + + + ike=klev-3 + do jk=3,ike + +! 2.1 calculate wet-bulb temperature and moisture +! for environmental air in *cuadjtq* +! ------------------------------------------- + is=0 + do 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)).and. jk.ge.ikhsmin(jl) + if(llo2(jl))then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + ik=jk + icall=2 + call cuadjtqn & + & ( 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. +! ---------------------------------------- + do 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) + endif + endif + enddo + + enddo + + return + end subroutine cudlfsn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- +!********************************************** +! subroutine cuddrafn +!********************************************** + subroutine cuddrafn & + & ( klon, klev, lddraf & + & , ptenh, pqenh, puen, pven & + & , pgeo, pgeoh, paph, prfl & + & , ptd, pqd, pud, pvd, pmfu & + & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) + +! 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. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels + +! input parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! input parameters (real): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pgeo* geopotential m2/s2 +! *paph* provisional pressure on half levels pa +! *pmfu* massflux updrafts kg/(m2*s) + +! updated parameters (real): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! externals +! --------- +! *cuadjtq* for adjusting t and q due to evaporation in +! saturated descent +!---------------------------------------------------------------------- + implicit none + +!--- input arguments: + integer,intent(in)::klon + logical,intent(in),dimension(klon):: lddraf + + integer,intent(in)::klev + + real(kind=kind_phys),intent(in),dimension(klon,klev):: ptenh,pqenh,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo,pmfu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh,paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon):: prfl + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptd,pqd,pud,pvd + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfd,pmfds,pmfdq,pdmfdp + +!--- output arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pmfdde_rate + +!--- local variables and arrays: + logical:: llo1 + logical,dimension(klon):: llo2 + + integer:: jl,jk + integer:: is,ik,icall,ike + integer,dimension(klon):: itopde + + real(kind=kind_phys):: zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real(kind=kind_phys):: zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk + real(kind=kind_phys),dimension(klon):: zdmfen,zdmfde,zcond,zoentr,zbuoy,zph + +!---------------------------------------------------------------------- +! 1. calculate moist descent for cumulus downdraft by +! (a) calculating entrainment/detrainment rates, +! including organized entrainment dependent on +! negative buoyancy and 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 +! ------------------------------------------------- + do jl=1,klon + zoentr(jl)=0. + zbuoy(jl)=0. + zdmfen(jl)=0. + zdmfde(jl)=0. + enddo + + do jk=klev,1,-1 + do jl=1,klon + pmfdde_rate(jl,jk) = 0. + if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk + end do + end do + + do jk=3,klev + is=0 + do 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 + enddo + if(is.eq.0) cycle + + do jl=1,klon + if(llo2(jl)) then + zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zdmfen(jl)=zentr + zdmfde(jl)=zentr + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.gt.itopde(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde(jl))* & + & (paph(jl,jk)-paph(jl,jk-1))/ & + & (paph(jl,klev+1)-paph(jl,itopde(jl))) + endif + endif + enddo + + do jl=1,klon + if(llo2(jl)) then + if(jk.le.itopde(jl)) then + zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) + zdmfen(jl)=zdmfen(jl)+zzentr + zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) + zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & + & (pmfd(jl,jk-1)-zdmfde(jl))) + zdmfen(jl)=min(zdmfen(jl),0.) + endif + endif + enddo + + do 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) + endif + enddo + + ik=jk + icall=2 + call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) + + do 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(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then + zrain=prfl(jl)/pmfu(jl,jk) + zbuo=zbuo-ptd(jl,jk)*zrain + endif + if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + zbuo=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 + +! compute organized entrainment for use at next level + zbuoyz=zbuo/ptenh(jl,jk) + zbuoyz=min(zbuoyz,0.0) + zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) + zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz + zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) + pmfdde_rate(jl,jk) = -zdmfde(jl) + endif + enddo + + enddo + + return + end subroutine cuddrafn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ptenh, pqenh & + & , paph, pap, pgeoh, lndj, ldcum & + & , kcbot, kctop, kdtop, ktopm2 & + & , ktype, lddraf & + & , pmfu, pmfd, pmfus, pmfds & + & , pmfuq, pmfdq, pmful, plude & + & , pdmfup, pdmfdp, pdpmel, plglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! 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*. + + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level +! *kdtop* top level of downdrafts + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real): + +! *ptsphy* time step for the physics s +! *pten* provisional environment temperature (t+1) k +! *pqen* provisional environment spec. humidity (t+1) kg/kg +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *paph* provisional pressure on half levels pa +! *pap* provisional pressure on full levels pa +! *pgeoh* geopotential on half levels m2/s2 + +! updated parameters (integer): + +! *ktype* set to zero if ldcum=.false. + +! updated parameters (logical): + +! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) + if ( llddraf .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 + if ( llddraf .and. pmfd(jl,jk) < 0. .and. & + abs(pmfd(jl,ikb)) < 1.e-20 ) then + idbas(jl) = jk + 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. + plglac(jl,jk)=0. + pdmfup(jl,jk-1)=0. + pdmfdp(jl,jk-1)=0. + plude(jl,jk-1)=0. + endif + enddo + enddo + + do jl=1,klon + pmflxr(jl,klev+1) = 0. + pmflxs(jl,klev+1) = 0. + end do + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + ik=ikb+1 + zzp=((paph(jl,klev+1)-paph(jl,ik))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,ik)=pmfu(jl,ikb)*zzp + pmfus(jl,ik)=(pmfus(jl,ikb)- & + & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp + pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp + pmful(jl,ik)=0. + endif + enddo + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then + ikb=kcbot(jl)+1 + zzp=((paph(jl,klev+1)-paph(jl,jk))/ & + & (paph(jl,klev+1)-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)=0. + endif + ik = idbas(jl) + llddraf = lddraf(jl) .and. jk > ik .and. ik < klev + if ( llddraf .and. ik == kcbot(jl)+1 ) then + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + pmfd(jl,jk) = pmfd(jl,ik)*zzp + pmfds(jl,jk) = pmfds(jl,ik)*zzp + pmfdq(jl,jk) = pmfdq(jl,ik)*zzp + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + end if + enddo + enddo +!* 2. calculate rain/snow fall rates +!* calculate melting of snow +!* calculate evaporation of precip +! ------------------------------- + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then + prain(jl)=prain(jl)+pdmfup(jl,jk) + if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then + zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) + zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) + zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) + pdpmel(jl,jk)=zsnmlt + pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) + endif + zalfaw=foealfa(pten(jl,jk)) + ! + ! No liquid precipitation above melting level + ! + if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then + plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zalfaw = 0. + end if + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) + pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) + if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then + pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdpmel(jl,jk) =0.0 + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + endif + enddo + enddo + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kcbot(jl)) then + zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) + if(zrfl.gt.1.e-20) then + zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & + & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & + & zrfl/zcucov)**0.5777* & + & (paph(jl,jk+1)-paph(jl,jk)) + zrnew=zrfl-zdrfl1 + zrmin=zrfl-zcucov*max(0.,rhevap(jl)*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) + zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) + zalfaw=foealfa(pten(jl,jk)) + if ( pten(jl,jk) < tmelt ) zalfaw = 0. + zpdr=zalfaw*pdmfdp(jl,jk) + zpds=(1.-zalfaw)*pdmfdp(jl,jk) + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & + & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom + pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & + & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom + pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl + if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then + pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) + pmflxr(jl,jk+1) = 0. + pmflxs(jl,jk+1) = 0. + pdpmel(jl,jk) = 0. + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + else + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdmfdp(jl,jk)=0.0 + pdpmel(jl,jk)=0.0 + endif + endif + enddo + enddo + + return + end subroutine cuflxn +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & + lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & + pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & + pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum,lddraf + + integer,intent(in):: klev,ktopm2 + integer,intent(in),dimension(klon):: kctop,kdtop + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon,klev):: pgeo + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfus,pmfd,pmfds + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfuq,pmfdq,pmful + real(kind=kind_phys),intent(in),dimension(klon,klev):: plglac,plude,pdpmel + real(kind=kind_phys),intent(in),dimension(klon,klev):: pdmfup,pdmfdp + real(kind=kind_phys),intent(in),dimension(klon,klev):: pqen, ptenh,pqenh,pqsen + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph,pgeoh + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptent,ptenq,pcte + +!--- local variables and arrays: + integer:: jk ,ik ,jl + real(kind=kind_phys):: zalv ,zzp + real(kind=kind_phys),dimension(klon,klev):: zdtdt,zdqdt,zdp + + !* 1.0 SETUP AND INITIALIZATIONS + ! ------------------------- + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do + !----------------------------------------------------------------------- + !* 2.0 COMPUTE TENDENCIES + ! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & + (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & + pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) + zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - & + pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - & + pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & + (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) + zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & + pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) + end if + end do + end if + end do + !--------------------------------------------------------------- + !* 3.0 UPDATE TENDENCIES + ! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) + ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) + pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) + end if + end do + end do + + return + end subroutine cudtdqn +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & + ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & + ptenv) + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + integer,intent(in):: klev,ktopm2 + integer,intent(in),dimension(klon):: ktype,kcbot,kctop + + real(kind=kind_phys),intent(in):: ztmst + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu,pmfd,puen,pven + real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pud,pvu,pvd + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: paph + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: ptenu,ptenv + +!--- local variables and arrays: + integer:: ik,ikb,jk,jl + + real(kind=kind_phys):: zzp,zdtdt + real(kind=kind_Phys),dimension(klon,klev):: zdudt,zdvdt,zdp + real(kind=kind_phys),dimension(klon,klev):: zuen,zven,zmfuu,zmfdu,zmfuv,zmfdv + +! + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zuen(jl,jk) = puen(jl,jk) + zven(jl,jk) = pven(jl,jk) + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do +!---------------------------------------------------------------------- +!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES +! ---------------------------------------------- + do jk = ktopm2 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) + zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) + zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) + zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) + end if + end do + end do + ! linear fluxes below cloud + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk > kcbot(jl) ) then + ikb = kcbot(jl) + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + 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 + end do + end do +!---------------------------------------------------------------------- +!* 2.0 COMPUTE TENDENCIES +! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = zdp(jl,jk) * & + (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) + zdvdt(jl,jk) = zdp(jl,jk) * & + (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) + zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) + end if + end do + end if + end do +!--------------------------------------------------------------------- +!* 3.0 UPDATE TENDENCIES +! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) + ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) + end if + end do + end do +!---------------------------------------------------------------------- + return + end subroutine cududvn +!--------------------------------------------------------- +! level 3 subroutines +!-------------------------------------------------------- + subroutine cuadjtqn & + & (klon, klev, kk, psp, pt, pq, ldflag, kcall) +! m.tiedtke e.c.m.w.f. 12/89 +! purpose. +! -------- +! to produce t,q and l values for cloud ascent + +! interface +! --------- +! this routine is called from subroutines: +! *cond* (t and q at condensation level) +! *cubase* (t and q at condensation 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 + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kk* level +! *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) +! input parameters (real): + +! *psp* pressure pa + +! updated parameters (real): + +! *pt* temperature k +! *pq* specific humidity kg/kg +! externals +! --------- +! for condensation calculations. +! the tables are initialised in *suphec*. + +!---------------------------------------------------------------------- + + implicit none + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldflag + integer,intent(in):: kcall,kk,klev + + real(kind=kind_phys),intent(in),dimension(klon):: psp + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(klon,klev):: pt,pq + +!--- local variables and arrays: + integer:: jl,jk + integer:: isum + + real(kind=kind_phys)::zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf + +!---------------------------------------------------------------------- +! 1. define constants +! ---------------- + zqmax=0.5 + +! 2. calculate condensation and adjust t and q accordingly +! ----------------------------------------------------- + + if ( kcall == 1 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & + (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( zcond > 0. ) then + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk)) * & + exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & + exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( abs(zcond) < 1.e-20 ) zcond1 = 0. + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end if + end do + elseif ( kcall == 2 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + zcond = min(zcond,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end do + else if ( kcall == 0 ) then + do jl = 1,klon + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end do + end if + + return + end subroutine cuadjtqn +!--------------------------------------------------------- +! level 4 subroutines +!-------------------------------------------------------- + subroutine cubasmcn & + & (klon, klev, klevm1, kk, pten, & + & pqen, pqsen, puen, pven, pverv, & + & pgeo, pgeoh, ldcum, ktype, klab, plrain, & + & pmfu, pmfub, kcbot, ptu, & + & pqu, plu, puu, pvu, pmfus, & + & pmfuq, pmful, pdmfup) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +! c.zhang iprc 05/2012 +!***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 +! ---------------------------------------------------------------- + +!--- input arguments: + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + integer,intent(in):: kk,klev,klevm1 + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pten,pqen,pqsen,pgeo,pverv + real(kind=kind_phys),intent(in),dimension(klon,klev):: puen,pven ! not used. + real(kind=kind_phys),intent(in),dimension(klon,klev):: puu,pvu ! not used. + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh + +!--- output arguments: + integer,intent(out),dimension(klon):: ktype,kcbot + integer,intent(out),dimension(klon,klev):: klab + + real(kind=kind_phys),intent(out),dimension(klon):: pmfub + real(kind=kind_phys),intent(out),dimension(klon,klev):: plrain + real(kind=kind_phys),intent(out),dimension(klon,klev):: ptu,pqu,plu + real(kind=kind_phys),intent(out),dimension(klon,klev):: pmfu,pmfus,pmfuq,pmful + real(kind=kind_phys),intent(out),dimension(klon,klev):: pdmfup + +!--- local variables and arrays: + integer:: jl,klevp1 + real(kind=kind_phys):: zzzmb + +!-------------------------------------------------------- +!* 1. calculate entrainment and detrainment rates +! ------------------------------------------------------- + do jl=1,klon + if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then + if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & + pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & + & pgeo(jl,kk)*zrg .lt. 1.0e4 ) 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)*zrg) + 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 + plrain(jl,kk+1)=0.0 + ktype(jl)=3 + end if + end if + end do + return + end subroutine cubasmcn +!--------------------------------------------------------- +! level 4 subroutines +!--------------------------------------------------------- + subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & + pgeoh,pmfu,pdmfen,pdmfde) + implicit none + +!--- input arguments: + logical,intent(in):: ldwork + integer,intent(in):: klon + logical,intent(in),dimension(klon):: ldcum + + integer,intent(in):: klev,kk + integer,intent(in),dimension(klon):: kcbot + + real(kind=kind_phys),intent(in),dimension(klon,klev):: pmfu + real(kind=kind_phys),intent(in),dimension(klon,klev+1):: pgeoh + +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(klon):: pdmfen + real(kind=kind_phys),intent(out),dimension(klon):: pdmfde + +!--- local variables and arrays: + logical:: llo1 + integer:: jl + real(kind=kind_phys):: zdz ,zmf + real(kind=kind_phys),dimension(klon):: zentr + + ! + !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES + ! ------------------------------------------- + if ( ldwork ) then + do jl = 1,klon + pdmfen(jl) = 0. + pdmfde(jl) = 0. + zentr(jl) = 0. + end do + ! + !* 1.1 SPECIFY ENTRAINMENT RATES + ! ------------------------- + do jl = 1, klon + if ( ldcum(jl) ) then + zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg + zmf = pmfu(jl,kk+1)*zdz + llo1 = kk < kcbot(jl) + if ( llo1 ) then + pdmfen(jl) = zentr(jl)*zmf + pdmfde(jl) = 0.75e-4*zmf + end if + end if + end do + end if + end subroutine cuentrn +!-------------------------------------------------------- +! external functions +!------------------------------------------------------ + real(kind=kind_phys) function foealfa(tt) +! foealfa is calculated to distinguish the three cases: +! +! foealfa=1 water phase +! foealfa=0 ice phase +! 0 < foealfa < 1 mixed phase +! +! input : tt = temperature +! + implicit none + real(kind=kind_phys),intent(in):: tt + foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & + & /(rtwat-rtice))**2) + + return + end function foealfa + + real(kind=kind_phys) function foelhm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als + return + end function foelhm + + real(kind=kind_phys) function foeewm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foeewm = c2es * & + & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & + & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) + return + end function foeewm + + real(kind=kind_phys) function foedem(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & + & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) + return + end function foedem + + real(kind=kind_phys) function foeldcpm(tt) + implicit none + real(kind=kind_phys),intent(in):: tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + +!================================================================================================================= + end module cu_ntiedtke +!================================================================================================================= + diff --git a/src/core_atmosphere/physics/physics_mmm/module_libmassv.F b/src/core_atmosphere/physics/physics_mmm/module_libmassv.F new file mode 100644 index 0000000000..60ff9fa022 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/module_libmassv.F @@ -0,0 +1,91 @@ +!================================================================================================================= + module module_libmassv + + implicit none + + + interface vrec + module procedure vrec_d + module procedure vrec_s + end interface + + interface vsqrt + module procedure vsqrt_d + module procedure vsqrt_s + end interface + + integer, parameter, private :: R4KIND = selected_real_kind(6) + integer, parameter, private :: R8KIND = selected_real_kind(12) + + contains + + +!================================================================================================================= + subroutine vrec_d(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R8KIND),dimension(*),intent(in):: x + real(kind=R8KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=real(1.0,kind=R8KIND)/x(j) + enddo + + end subroutine vrec_d + +!================================================================================================================= + subroutine vrec_s(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R4KIND),dimension(*),intent(in):: x + real(kind=R4KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=real(1.0,kind=R4KIND)/x(j) + enddo + + end subroutine vrec_s + +!================================================================================================================= + subroutine vsqrt_d(y,x,n) +!================================================================================================================= + integer,intent(in):: n + real(kind=R8KIND),dimension(*),intent(in):: x + real(kind=R8KIND),dimension(*),intent(out):: y + + integer:: j +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=sqrt(x(j)) + enddo + + end subroutine vsqrt_d + +!================================================================================================================= + subroutine vsqrt_s(y,x,n) +!================================================================================================================= + + integer,intent(in):: n + real(kind=R4KIND),dimension(*),intent(in):: x + real(kind=R4KIND),dimension(*),intent(out):: y + + integer:: j + +!----------------------------------------------------------------------------------------------------------------- + + do j=1,n + y(j)=sqrt(x(j)) + enddo + + end subroutine vsqrt_s + +!================================================================================================================= + end module module_libmassv +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/mp_radar.F b/src/core_atmosphere/physics/physics_mmm/mp_radar.F new file mode 100644 index 0000000000..00b8ed47f4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/mp_radar.F @@ -0,0 +1,678 @@ +!================================================================================================================= + module mp_radar + use ccpp_kinds,only: kind_phys + use mpas_atmphys_utilities + + implicit none + private + public:: radar_init, & + rayleigh_soak_wetgraupel + +!+---+-----------------------------------------------------------------+ +!..This set of routines facilitates computing radar reflectivity. +!.. This module is more library code whereas the individual microphysics +!.. schemes contains specific details needed for the final computation, +!.. so refer to location within each schemes calling the routine named +!.. rayleigh_soak_wetgraupel. +!.. The bulk of this code originated from Ulrich Blahak (Germany) and +!.. was adapted to WRF by G. Thompson. This version of code is only +!.. intended for use when Rayleigh scattering principles dominate and +!.. is not intended for wavelengths in which Mie scattering is a +!.. significant portion. Therefore, it is well-suited to use with +!.. 5 or 10 cm wavelength like USA NEXRAD radars. +!.. This code makes some rather simple assumptions about water +!.. coating on outside of frozen species (snow/graupel). Fraction of +!.. meltwater is simply the ratio of mixing ratio below melting level +!.. divided by mixing ratio at level just above highest T>0C. Also, +!.. immediately 90% of the melted water exists on the ice's surface +!.. and 10% is embedded within ice. No water is "shed" at all in these +!.. assumptions. The code is quite slow because it does the reflectivity +!.. calculations based on 50 individual size bins of the distributions. +!+---+-----------------------------------------------------------------+ + + integer, parameter, private :: R4KIND = selected_real_kind(6) + integer, parameter, private :: R8KIND = selected_real_kind(12) + + integer,parameter,public:: nrbins = 50 + integer,parameter,public:: slen = 20 + character(len=slen), public:: & + mixingrulestring_s, matrixstring_s, inclusionstring_s, & + hoststring_s, hostmatrixstring_s, hostinclusionstring_s, & + mixingrulestring_g, matrixstring_g, inclusionstring_g, & + hoststring_g, hostmatrixstring_g, hostinclusionstring_g + + complex(kind=R8KIND),public:: m_w_0, m_i_0 + + double precision,dimension(nrbins+1),public:: xxdx + double precision,dimension(nrbins),public:: xxds,xdts,xxdg,xdtg + double precision,parameter,public:: lamda_radar = 0.10 ! in meters + double precision,public:: k_w,pi5,lamda4 + + double precision, dimension(nrbins+1), public:: simpson + double precision, dimension(3), parameter, public:: basis = & + (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) + + real(kind=kind_phys),public,dimension(4):: xcre,xcse,xcge,xcrg,xcsg,xcgg + real(kind=kind_phys),public:: xam_r,xbm_r,xmu_r,xobmr + real(kind=kind_phys),public:: xam_s,xbm_s,xmu_s,xoams,xobms,xocms + real(kind=kind_phys),public:: xam_g,xbm_g,xmu_g,xoamg,xobmg,xocmg + real(kind=kind_phys),public:: xorg2,xosg2,xogg2 + + +!..Single melting snow/graupel particle 90% meltwater on external sfc + character(len=256):: radar_debug + + double precision,parameter,public:: melt_outside_s = 0.9d0 + double precision,parameter,public:: melt_outside_g = 0.9d0 + + + contains + + +!================================================================================================================= + subroutine radar_init + implicit none +!================================================================================================================= + + integer:: n + +!----------------------------------------------------------------------------------------------------------------- + + pi5 = 3.14159*3.14159*3.14159*3.14159*3.14159 + lamda4 = lamda_radar*lamda_radar*lamda_radar*lamda_radar + m_w_0 = m_complex_water_ray (lamda_radar, 0.0d0) + m_i_0 = m_complex_ice_maetzler (lamda_radar, 0.0d0) + k_w = (abs( (m_w_0*m_w_0 - 1.0) /(m_w_0*m_w_0 + 2.0) ))**2 + + do n = 1, nrbins+1 + simpson(n) = 0.0d0 + enddo + do n = 1, nrbins-1, 2 + simpson(n) = simpson(n) + basis(1) + simpson(n+1) = simpson(n+1) + basis(2) + simpson(n+2) = simpson(n+2) + basis(3) + enddo + + do n = 1, slen + mixingrulestring_s(n:n) = char(0) + matrixstring_s(n:n) = char(0) + inclusionstring_s(n:n) = char(0) + hoststring_s(n:n) = char(0) + hostmatrixstring_s(n:n) = char(0) + hostinclusionstring_s(n:n) = char(0) + mixingrulestring_g(n:n) = char(0) + matrixstring_g(n:n) = char(0) + inclusionstring_g(n:n) = char(0) + hoststring_g(n:n) = char(0) + hostmatrixstring_g(n:n) = char(0) + hostinclusionstring_g(n:n) = char(0) + enddo + + mixingrulestring_s = 'maxwellgarnett' + hoststring_s = 'air' + matrixstring_s = 'water' + inclusionstring_s = 'spheroidal' + hostmatrixstring_s = 'icewater' + hostinclusionstring_s = 'spheroidal' + + mixingrulestring_g = 'maxwellgarnett' + hoststring_g = 'air' + matrixstring_g = 'water' + inclusionstring_g = 'spheroidal' + hostmatrixstring_g = 'icewater' + hostinclusionstring_g = 'spheroidal' + +!..Create bins of snow (from 100 microns up to 2 cm). + xxdx(1) = 100.d-6 + xxdx(nrbins+1) = 0.02d0 + do n = 2, nrbins + xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) & + * dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1))) + enddo + do n = 1, nrbins + xxds(n) = dsqrt(xxdx(n)*xxdx(n+1)) + xdts(n) = xxdx(n+1) - xxdx(n) + enddo + +!..create bins of graupel (from 100 microns up to 5 cm). + xxdx(1) = 100.d-6 + xxdx(nrbins+1) = 0.05d0 + do n = 2, nrbins + xxdx(n) = dexp(real(n-1,kind=R8KIND)/real(nrbins,kind=R8KIND) & + * dlog(xxdx(nrbins+1)/xxdx(1)) +dlog(xxdx(1))) + enddo + do n = 1, nrbins + xxdg(n) = dsqrt(xxdx(n)*xxdx(n+1)) + xdtg(n) = xxdx(n+1) - xxdx(n) + enddo + + +!.. The calling program must set the m(D) relations and gamma shape +!.. parameter mu for rain, snow, and graupel. Easily add other types +!.. based on the template here. For majority of schemes with simpler +!.. exponential number distribution, mu=0. + + xcre(1) = 1. + xbm_r + xcre(2) = 1. + xmu_r + xcre(3) = 4. + xmu_r + xcre(4) = 7. + xmu_r + do n = 1, 4 + xcrg(n) = wgamma(xcre(n)) + enddo + xorg2 = 1./xcrg(2) + + xcse(1) = 1. + xbm_s + xcse(2) = 1. + xmu_s + xcse(3) = 4. + xmu_s + xcse(4) = 7. + xmu_s + do n = 1, 4 + xcsg(n) = wgamma(xcse(n)) + enddo + xosg2 = 1./xcsg(2) + + xcge(1) = 1. + xbm_g + xcge(2) = 1. + xmu_g + xcge(3) = 4. + xmu_g + xcge(4) = 7. + xmu_g + do n = 1, 4 + xcgg(n) = wgamma(xcge(n)) + enddo + xogg2 = 1./xcgg(2) + + xobmr = 1./xbm_r + xoams = 1./xam_s + xobms = 1./xbm_s + xocms = xoams**xobms + xoamg = 1./xam_g + xobmg = 1./xbm_g + xocmg = xoamg**xobmg + + end subroutine radar_init + +!================================================================================================================= + subroutine rayleigh_soak_wetgraupel(x_g,a_geo,b_geo,fmelt,meltratio_outside,m_w,m_i,lambda,c_back, & + mixingrule,matrix,inclusion,host,hostmatrix,hostinclusion) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*), intent(in):: mixingrule, matrix, inclusion, & + host, hostmatrix, hostinclusion + + complex(kind=R8KIND),intent(in):: m_w, m_i + + double precision, intent(in):: x_g, a_geo, b_geo, fmelt, lambda, meltratio_outside + +!--- output arguments: + double precision,intent(out):: c_back + +!--- local variables: + integer:: error + + complex(kind=R8KIND):: m_core, m_air + + double precision, parameter:: pix=3.1415926535897932384626434d0 + double precision:: d_large, d_g, rhog, x_w, xw_a, fm, fmgrenz, & + volg, vg, volair, volice, volwater, & + meltratio_outside_grenz, mra + +!----------------------------------------------------------------------------------------------------------------- + +!refractive index of air: + m_air = (1.0d0,0.0d0) + +!Limiting the degree of melting --- for safety: + fm = dmax1(dmin1(fmelt, 1.0d0), 0.0d0) +!Limiting the ratio of (melting on outside)/(melting on inside): + mra = dmax1(dmin1(meltratio_outside, 1.0d0), 0.0d0) + +!The relative portion of meltwater melting at outside should increase +!from the given input value (between 0 and 1) +!to 1 as the degree of melting approaches 1, +!so that the melting particle "converges" to a water drop. +!Simplest assumption is linear: + mra = mra + (1.0d0-mra)*fm + + x_w = x_g * fm + + d_g = a_geo * x_g**b_geo + + if(D_g .ge. 1d-12) then + + vg = PIx/6. * D_g**3 + rhog = DMAX1(DMIN1(x_g / vg, 900.0d0), 10.0d0) + vg = x_g / rhog + + meltratio_outside_grenz = 1.0d0 - rhog / 1000. + + if (mra .le. meltratio_outside_grenz) then + !..In this case, it cannot happen that, during melting, all the + !.. air inclusions within the ice particle get filled with + !.. meltwater. This only happens at the end of all melting. + volg = vg * (1.0d0 - mra * fm) + + else + !..In this case, at some melting degree fm, all the air + !.. inclusions get filled with meltwater. + fmgrenz=(900.0-rhog)/(mra*900.0-rhog+900.0*rhog/1000.) + + if (fm .le. fmgrenz) then + !.. not all air pockets are filled: + volg = (1.0 - mra * fm) * vg + else + !..all air pockets are filled with meltwater, now the + !.. entire ice sceleton melts homogeneously: + volg = (x_g - x_w) / 900.0 + x_w / 1000. + endif + + endif + + d_large = (6.0 / pix * volg) ** (1./3.) + volice = (x_g - x_w) / (volg * 900.0) + volwater = x_w / (1000. * volg) + volair = 1.0 - volice - volwater + + !..complex index of refraction for the ice-air-water mixture + !.. of the particle: + m_core = get_m_mix_nested (m_air, m_i, m_w, volair, volice, & + volwater, mixingrule, host, matrix, inclusion, & + hostmatrix, hostinclusion, error) + if (error .ne. 0) then + c_back = 0.0d0 + return + endif + + !..rayleigh-backscattering coefficient of melting particle: + c_back = (abs((m_core**2-1.0d0)/(m_core**2+2.0d0)))**2 & + * pi5 * d_large**6 / lamda4 + + else + c_back = 0.0d0 + endif + + end subroutine rayleigh_soak_wetgraupel + +!================================================================================================================= + real(kind=kind_phys) function wgamma(y) + implicit none +!================================================================================================================= + +!--- input arguments: + real(kind=kind_phys),intent(in):: y + +!----------------------------------------------------------------------------------------------------------------- + + wgamma = exp(gammln(y)) + + end function wgamma + +!================================================================================================================= + real(kind=kind_phys) function gammln(xx) + implicit none +!(C) Copr. 1986-92 Numerical Recipes Software 2.02 +!================================================================================================================= + +!--- inout arguments: + real(kind=kind_phys),intent(in):: xx + +!--- local variables: + integer:: j + + double precision,parameter:: stp = 2.5066282746310005d0 + double precision,dimension(6), parameter:: & + cof = (/76.18009172947146d0, -86.50532032941677d0, & + 24.01409824083091d0, -1.231739572450155d0, & + .1208650973866179d-2, -.5395239384953d-5/) + double precision:: ser,tmp,x,y + +!----------------------------------------------------------------------------------------------------------------- + +!--- returns the value ln(gamma(xx)) for xx > 0. + x = xx + y = x + tmp = x+5.5d0 + tmp = (x+0.5d0)*log(tmp)-tmp + ser = 1.000000000190015d0 + do j = 1,6 + y=y+1.d0 + ser=ser+cof(j)/y + enddo + + gammln=tmp+log(stp*ser/x) + + end function gammln + +!================================================================================================================= + complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & + volice, volwater, mixingrule, host, matrix, & + inclusion, hostmatrix, hostinclusion, cumulerror) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: mixingrule, host, matrix, & + inclusion, hostmatrix, hostinclusion + + complex(kind=R8KIND),intent(in):: m_a, m_i, m_w + + double precision,intent(in):: volice, volair, volwater + +!--- output arguments: + integer,intent(out):: cumulerror + +!--- local variables: + integer:: error + + complex(kind=R8KIND):: mtmp + + double precision:: vol1, vol2 + +!----------------------------------------------------------------------------------------------------------------- + +!..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be air, ice, or water + cumulerror = 0 + get_m_mix_nested = cmplx(1.0d0,0.0d0) + + if (host .eq. 'air') then + if (matrix .eq. 'air') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volice / MAX(volice+volwater,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, 0.0d0, vol1, vol2, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'air') then + get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & + volair, (1.0d0-volair), 0.0d0, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'icewater') then + get_m_mix_nested = get_m_mix (m_a, mtmp, 2.0*m_a, & + volair, (1.0d0-volair), 0.0d0, mixingrule, & + 'ice', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'ice') then + + if (matrix .eq. 'ice') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volair / MAX(volair+volwater,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, vol1, 0.0d0, vol2, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'ice') then + get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & + (1.0d0-volice), volice, 0.0d0, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'airwater') then + get_m_mix_nested = get_m_mix (mtmp, m_i, 2.0*m_a, & + (1.0d0-volice), volice, 0.0d0, mixingrule, & + 'air', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'water') then + + if (matrix .eq. 'water') then + write(radar_debug,*) 'GET_M_MIX_NESTED: bad matrix: ', matrix + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + else + vol1 = volair / MAX(volice+volair,1d-10) + vol2 = 1.0d0 - vol1 + mtmp = get_m_mix (m_a, m_i, m_w, vol1, vol2, 0.0d0, & + mixingrule, matrix, inclusion, error) + cumulerror = cumulerror + error + + if (hostmatrix .eq. 'water') then + get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & + 0.0d0, (1.0d0-volwater), volwater, mixingrule, & + hostmatrix, hostinclusion, error) + cumulerror = cumulerror + error + elseif (hostmatrix .eq. 'airice') then + get_m_mix_nested = get_m_mix (2*m_a, mtmp, m_w, & + 0.0d0, (1.0d0-volwater), volwater, mixingrule, & + 'ice', hostinclusion, error) + cumulerror = cumulerror + error + else + write(radar_debug,*) 'GET_M_MIX_NESTED: bad hostmatrix: ', hostmatrix + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + endif + + elseif (host .eq. 'none') then + + get_m_mix_nested = get_m_mix (m_a, m_i, m_w, & + volair, volice, volwater, mixingrule, & + matrix, inclusion, error) + cumulerror = cumulerror + error + + else + write(radar_debug,*) 'GET_M_MIX_NESTED: unknown matrix: ', host + call physics_message(radar_debug) + cumulerror = cumulerror + 1 + endif + + if (cumulerror .ne. 0) then + write(radar_debug,*) 'get_m_mix_nested: error encountered' + call physics_message(radar_debug) + get_m_mix_nested = cmplx(1.0d0,0.0d0) + endif + + end function get_m_mix_nested + +!================================================================================================================= + complex(kind=R8KIND) function get_m_mix (m_a, m_i, m_w, volair, volice, & + volwater, mixingrule, matrix, inclusion, & + error) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: mixingrule, matrix, inclusion + + complex(kind=R8KIND), intent(in):: m_a, m_i, m_w + + double precision, intent(in):: volice, volair, volwater + +!--- output arguments: + integer,intent(out):: error + +!----------------------------------------------------------------------------------------------------------------- + error = 0 + get_m_mix = cmplx(1.0d0,0.0d0) + + if (mixingrule .eq. 'maxwellgarnett') then + if (matrix .eq. 'ice') then + get_m_mix = m_complex_maxwellgarnett(volice, volair, volwater, & + m_i, m_a, m_w, inclusion, error) + elseif (matrix .eq. 'water') then + get_m_mix = m_complex_maxwellgarnett(volwater, volair, volice, & + m_w, m_a, m_i, inclusion, error) + elseif (matrix .eq. 'air') then + get_m_mix = m_complex_maxwellgarnett(volair, volwater, volice, & + m_a, m_w, m_i, inclusion, error) + else + write(radar_debug,*) 'GET_M_MIX: unknown matrix: ', matrix + call physics_message(radar_debug) + error = 1 + endif + + else + write(radar_debug,*) 'GET_M_MIX: unknown mixingrule: ', mixingrule + call physics_message(radar_debug) + error = 2 + endif + + if (error .ne. 0) then + write(radar_debug,*) 'GET_M_MIX: error encountered' + call physics_message(radar_debug) + endif + + end function get_m_mix + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_maxwellgarnett(vol1, vol2, vol3, & + m1, m2, m3, inclusion, error) + implicit none +!================================================================================================================= + +!--- input arguments: + character(len=*),intent(in):: inclusion + + complex(kind=R8KIND),intent(in):: m1,m2,m3 + + double precision,intent(in):: vol1,vol2,vol3 + + +!--- output arguments: + integer,intent(out):: error + +!--- local variables: + complex(kind=R8KIND) :: beta2, beta3, m1t, m2t, m3t + +!----------------------------------------------------------------------------------------------------------------- + + error = 0 + + if (dabs(vol1+vol2+vol3-1.0d0) .gt. 1d-6) then + write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: sum of the ', & + 'partial volume fractions is not 1...ERROR' + call physics_message(radar_debug) + m_complex_maxwellgarnett = CMPLX(-999.99d0,-999.99d0) + error = 1 + return + endif + + m1t = m1**2 + m2t = m2**2 + m3t = m3**2 + + if (inclusion .eq. 'spherical') then + beta2 = 3.0d0*m1t/(m2t+2.0d0*m1t) + beta3 = 3.0d0*m1t/(m3t+2.0d0*m1t) + elseif (inclusion .eq. 'spheroidal') then + beta2 = 2.0d0*m1t/(m2t-m1t) * (m2t/(m2t-m1t)*LOG(m2t/m1t)-1.0d0) + beta3 = 2.0d0*m1t/(m3t-m1t) * (m3t/(m3t-m1t)*LOG(m3t/m1t)-1.0d0) + else + write(radar_debug,*) 'M_COMPLEX_MAXWELLGARNETT: ', 'unknown inclusion: ', inclusion + call physics_message(radar_debug) + m_complex_maxwellgarnett=cmplx(-999.99d0,-999.99d0,kind=R8KIND) + error = 1 + return + endif + + m_complex_maxwellgarnett = sqrt(((1.0d0-vol2-vol3)*m1t + vol2*beta2*m2t + vol3*beta3*m3t) / & + (1.0d0-vol2-vol3+vol2*beta2+vol3*beta3)) + + end function m_complex_maxwellgarnett + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_water_ray(lambda,t) + implicit none +!================================================================================================================= + +!complex refractive Index of Water as function of Temperature T +![deg C] and radar wavelength lambda [m]; valid for +!lambda in [0.001,1.0] m; T in [-10.0,30.0] deg C +!after Ray (1972) + +!--- input arguments: + double precision,intent(in):: t,lambda + +!--- local variables: + double precision,parameter:: pix=3.1415926535897932384626434d0 + double precision:: epsinf,epss,epsr,epsi + double precision:: alpha,lambdas,sigma,nenner + complex(kind=R8KIND),parameter:: i = (0d0,1d0) + +!----------------------------------------------------------------------------------------------------------------- + + epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T + epss = 78.54d+0 * (1.0 - 4.579d-3 * (T - 25.0) & + + 1.190d-5 * (T - 25.0)*(T - 25.0) & + - 2.800d-8 * (T - 25.0)*(T - 25.0)*(T - 25.0)) + alpha = -16.8129d0/(T+273.16) + 0.0609265d0 + lambdas = 0.00033836d0 * exp(2513.98d0/(T+273.16)) * 1e-2 + + nenner = 1.d0+2.d0*(lambdas/lambda)**(1d0-alpha)*sin(alpha*PIx*0.5) & + + (lambdas/lambda)**(2d0-2d0*alpha) + epsr = epsinf + ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & + * sin(alpha*PIx*0.5)+1d0)) / nenner + epsi = ((epss-epsinf) * ((lambdas/lambda)**(1d0-alpha) & + * cos(alpha*PIx*0.5)+0d0)) / nenner & + + lambda*1.25664/1.88496 + + m_complex_water_ray = sqrt(cmplx(epsr,-epsi)) + + end function m_complex_water_ray + +!================================================================================================================= + complex(kind=R8KIND) function m_complex_ice_maetzler(lambda,t) + implicit none +!================================================================================================================= + +!complex refractive index of ice as function of Temperature T +![deg C] and radar wavelength lambda [m]; valid for +!lambda in [0.0001,30] m; T in [-250.0,0.0] C +!Original comment from the Matlab-routine of Prof. Maetzler: +!Function for calculating the relative permittivity of pure ice in +!the microwave region, according to C. Maetzler, "Microwave +!properties of ice and snow", in B. Schmitt et al. (eds.) Solar +!System Ices, Astrophys. and Space Sci. Library, Vol. 227, Kluwer +!Academic Publishers, Dordrecht, pp. 241-257 (1998). Input: +!TK = temperature (K), range 20 to 273.15 +!f = frequency in GHz, range 0.01 to 3000 + +!--- input arguments: + double precision,intent(in):: t,lambda + +!--- local variables: + double precision:: f,c,tk,b1,b2,b,deltabeta,betam,beta,theta,alfa + +!----------------------------------------------------------------------------------------------------------------- + + c = 2.99d8 + tk = t + 273.16 + f = c / lambda * 1d-9 + + b1 = 0.0207 + b2 = 1.16d-11 + b = 335.0d0 + deltabeta = exp(-10.02 + 0.0364*(tk-273.16)) + betam = (b1/tk) * ( exp(b/tk) / ((exp(b/tk)-1)**2) ) + b2*f*f + beta = betam + deltabeta + theta = 300. / tk - 1. + alfa = (0.00504d0 + 0.0062d0*theta) * exp(-22.1d0*theta) + m_complex_ice_maetzler = 3.1884 + 9.1e-4*(tk-273.16) + m_complex_ice_maetzler = m_complex_ice_maetzler & + + cmplx(0.0d0, (alfa/f + beta*f)) + m_complex_ice_maetzler = sqrt(conjg(m_complex_ice_maetzler)) + + end function m_complex_ice_maetzler + +!================================================================================================================= + end module mp_radar +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/mp_wsm6.F b/src/core_atmosphere/physics/physics_mmm/mp_wsm6.F new file mode 100644 index 0000000000..ca345b3ba8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/mp_wsm6.F @@ -0,0 +1,2441 @@ +!================================================================================================================= + module mp_wsm6 + use ccpp_kinds,only: kind_phys + use module_libmassv,only: vrec,vsqrt + + use mp_radar + + implicit none + private + public:: mp_wsm6_run, & + mp_wsm6_init, & + mp_wsm6_final, & + refl10cm_wsm6 + + real(kind=kind_phys),parameter,private:: dtcldcr = 120. ! maximum time step for minor loops + real(kind=kind_phys),parameter,private:: n0r = 8.e6 ! intercept parameter rain +!real(kind=kind_phys),parameter,private:: n0g = 4.e6 ! intercept parameter graupel + real(kind=kind_phys),parameter,private:: avtr = 841.9 ! a constant for terminal velocity of rain + real(kind=kind_phys),parameter,private:: bvtr = 0.8 ! a constant for terminal velocity of rain + real(kind=kind_phys),parameter,private:: r0 = .8e-5 ! 8 microm in contrast to 10 micro m + real(kind=kind_phys),parameter,private:: peaut = .55 ! collection efficiency + real(kind=kind_phys),parameter,private:: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 + real(kind=kind_phys),parameter,private:: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 + real(kind=kind_phys),parameter,private:: avts = 11.72 ! a constant for terminal velocity of snow + real(kind=kind_phys),parameter,private:: bvts = .41 ! a constant for terminal velocity of snow +!real(kind=kind_phys),parameter,private:: avtg = 330. ! a constant for terminal velocity of graupel +!real(kind=kind_phys),parameter,private:: bvtg = 0.8 ! a constant for terminal velocity of graupel +!real(kind=kind_phys),parameter,private:: deng = 500. ! density of graupel ! set later with hail_opt + real(kind=kind_phys),parameter,private:: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain + real(kind=kind_phys),parameter,private:: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow +!real(kind=kind_phys),parameter,private:: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel + real(kind=kind_phys),parameter,private:: dicon = 11.9 ! constant for the cloud-ice diamter + real(kind=kind_phys),parameter,private:: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter + real(kind=kind_phys),parameter,private:: pfrz1 = 100. ! constant in Biggs freezing + real(kind=kind_phys),parameter,private:: pfrz2 = 0.66 ! constant in Biggs freezing + real(kind=kind_phys),parameter,private:: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg + real(kind=kind_phys),parameter,private:: eacrc = 1.0 ! Snow/cloud-water collection efficiency + real(kind=kind_phys),parameter,private:: dens = 100.0 ! Density of snow + real(kind=kind_phys),parameter,private:: qs0 = 6.e-4 ! threshold amount for aggretion to occur + + real(kind=kind_phys),parameter,public :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) + real(kind=kind_phys),parameter,public :: n0s = 2.e6 ! temperature dependent intercept parameter snow + real(kind=kind_phys),parameter,public :: alpha = .12 ! .122 exponen factor for n0s + + real(kind=kind_phys),save:: & + qc0,qck1, & + bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & + g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & + bvtr6,g6pbr, & + precr1,precr2,roqimax,bvts1, & + bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init + g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & + xlv1,pacrc,pi, & + bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & + g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & + precg1,precg2,pidn0g, & + rslopermax,rslopesmax,rslopegmax, & + rsloperbmax,rslopesbmax,rslopegbmax, & + rsloper2max,rslopes2max,rslopeg2max, & + rsloper3max,rslopes3max,rslopeg3max + + real(kind=kind_phys),public,save:: pidn0s,pidnc + + + contains + + +!================================================================================================================= + subroutine mp_wsm6_init(den0,denr,dens,cl,cpv,hail_opt,errmsg,errflg) +!================================================================================================================= + +!input arguments: + integer,intent(in):: hail_opt ! RAS + real(kind=kind_phys),intent(in):: den0,denr,dens,cl,cpv + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + +! RAS13.1 define graupel parameters as graupel-like or hail-like, +! depending on namelist option + if(hail_opt .eq. 1) then !Hail! + n0g = 4.e4 + deng = 700. + avtg = 285.0 + bvtg = 0.8 + lamdagmax = 2.e4 + else !Graupel! + n0g = 4.e6 + deng = 500 + avtg = 330.0 + bvtg = 0.8 + lamdagmax = 6.e4 + endif +! + pi = 4.*atan(1.) + xlv1 = cl-cpv +! + qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 + qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + pidnc = pi*denr/6. ! syb +! + bvtr1 = 1.+bvtr + bvtr2 = 2.5+.5*bvtr + bvtr3 = 3.+bvtr + bvtr4 = 4.+bvtr + bvtr6 = 6.+bvtr + g1pbr = rgmma(bvtr1) + g3pbr = rgmma(bvtr3) + g4pbr = rgmma(bvtr4) ! 17.837825 + g6pbr = rgmma(bvtr6) + g5pbro2 = rgmma(bvtr2) ! 1.8273 + pvtr = avtr*g4pbr/6. + eacrr = 1.0 + pacrr = pi*n0r*avtr*g3pbr*.25*eacrr + precr1 = 2.*pi*n0r*.78 + precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 + roqimax = 2.08e22*dimax**8 +! + bvts1 = 1.+bvts + bvts2 = 2.5+.5*bvts + bvts3 = 3.+bvts + bvts4 = 4.+bvts + g1pbs = rgmma(bvts1) !.8875 + g3pbs = rgmma(bvts3) + g4pbs = rgmma(bvts4) ! 12.0786 + g5pbso2 = rgmma(bvts2) + pvts = avts*g4pbs/6. + pacrs = pi*n0s*avts*g3pbs*.25 + precs1 = 4.*n0s*.65 + precs2 = 4.*n0s*.44*avts**.5*g5pbso2 + pidn0r = pi*denr*n0r + pidn0s = pi*dens*n0s +! + pacrc = pi*n0s*avts*g3pbs*.25*eacrc +! + bvtg1 = 1.+bvtg + bvtg2 = 2.5+.5*bvtg + bvtg3 = 3.+bvtg + bvtg4 = 4.+bvtg + g1pbg = rgmma(bvtg1) + g3pbg = rgmma(bvtg3) + g4pbg = rgmma(bvtg4) + pacrg = pi*n0g*avtg*g3pbg*.25 + g5pbgo2 = rgmma(bvtg2) + pvtg = avtg*g4pbg/6. + precg1 = 2.*pi*n0g*.78 + precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 + pidn0g = pi*deng*n0g +! + rslopermax = 1./lamdarmax + rslopesmax = 1./lamdasmax + rslopegmax = 1./lamdagmax + rsloperbmax = rslopermax ** bvtr + rslopesbmax = rslopesmax ** bvts + rslopegbmax = rslopegmax ** bvtg + rsloper2max = rslopermax * rslopermax + rslopes2max = rslopesmax * rslopesmax + rslopeg2max = rslopegmax * rslopegmax + rsloper3max = rsloper2max * rslopermax + rslopes3max = rslopes2max * rslopesmax + rslopeg3max = rslopeg2max * rslopegmax + +!+---+-----------------------------------------------------------------+ +!.. Set these variables needed for computing radar reflectivity. These +!.. get used within radar_init to create other variables used in the +!.. radar module. + xam_r = PI*denr/6. + xbm_r = 3. + xmu_r = 0. + xam_s = PI*dens/6. + xbm_s = 3. + xmu_s = 0. + xam_g = PI*deng/6. + xbm_g = 3. + xmu_g = 0. + + call radar_init + + errmsg = 'mp_wsm6_init OK' + errflg = 0 + + end subroutine mp_wsm6_init + +!================================================================================================================= + subroutine mp_wsm6_final(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_final OK' + errflg = 0 + + end subroutine mp_wsm6_final + +!================================================================================================================= + subroutine mp_wsm6_run(t,q,qc,qi,qr,qs,qg,den,p,delz,delt, & + g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin,xls, & + xlv0,xlf0,den0,denr,cliq,cice,psat, & + rain,rainncv,sr,snow,snowncv,graupel, & + graupelncv,rainprod2d,evapprod2d, & + its,ite,kts,kte,errmsg,errflg & + ) +!=================================================================================================================! +! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the +! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei +! number concentration is a function of temperature, and seperate assumption +! is developed, in which ice crystal number concentration is a function +! of ice amount. A theoretical background of the ice-microphysics and related +! processes in the WSMMPs are described in Hong et al. (2004). +! All production terms in the WSM6 scheme are described in Hong and Lim (2006). +! All units are in m.k.s. and source/sink terms in kgkg-1s-1. +! +! WSM6 cloud scheme +! +! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) +! Summer 2003 +! +! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) +! Summer 2004 +! +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! reflectivity computation from greg thompson, lim, jun 2011 +! ==> only diagnostic, but with removal of too large drops +! add hail option from afwa, aug 2014 +! ==> switch graupel or hail by changing no, den, fall vel. +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation +! bug fix in melting terms, bae from kiaps, nov 2015 +! ==> density of air is divided, which has not been +! +! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. +! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. +! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan +! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. +! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. +! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. +! Juang and Hong (JH, 2010) Mon. Wea. Rev. +! + +!input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + den, & + p, & + delz + real(kind=kind_phys),intent(in):: & + delt, & + g, & + cpd, & + cpv, & + t0c, & + den0, & + rd, & + rv, & + ep1, & + ep2, & + qmin, & + xls, & + xlv0, & + xlf0, & + cliq, & + cice, & + psat, & + denr + +!inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + t +real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + q, & + qc, & + qi, & + qr, & + qs, & + qg +real(kind=kind_phys),intent(inout),dimension(its:ite):: & + rain, & + rainncv, & + sr + +real(kind=kind_phys),intent(inout),dimension(its:ite),optional:: & + snow, & + snowncv +real(kind=kind_phys),intent(inout),dimension(its:ite),optional:: & + graupel, & + graupelncv + + + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte), & + optional:: & + rainprod2d, & + evapprod2d + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!local variables and arrays: + real(kind=kind_phys),dimension(its:ite,kts:kte,3):: & + rh, & + qsat, & + rslope, & + rslope2, & + rslope3, & + rslopeb, & + qrs_tmp, & + falk, & + fall, & + work1 + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + fallc, & + falkc, & + work1c, & + work2c, & + workr, & + worka + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + den_tmp, & + delz_tmp + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + pigen, & + pidep, & + pcond, & + prevp, & + psevp, & + pgevp, & + psdep, & + pgdep, & + praut, & + psaut, & + pgaut, & + piacr, & + pracw, & + praci, & + pracs, & + psacw, & + psaci, & + psacr, & + pgacw, & + pgaci, & + pgacr, & + pgacs, & + paacw, & + psmlt, & + pgmlt, & + pseml, & + pgeml + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + qsum, & + xl, & + cpm, & + work2, & + denfac, & + xni, & + denqrs1, & + denqrs2, & + denqrs3, & + denqci, & + n0sfac + real(kind=kind_phys),dimension(its:ite):: & + delqrs1, & + delqrs2, & + delqrs3, & + delqi + real(kind=kind_phys),dimension(its:ite):: & + tstepsnow, & + tstepgraup + integer,dimension(its:ite):: & + mstep, & + numdt + logical,dimension(its:ite):: flgcld + real(kind=kind_phys):: & + cpmcal, xlcal, diffus, & + viscos, xka, venfac, conden, diffac, & + x, y, z, a, b, c, d, e, & + qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & + coeres, supsat, dtcld, xmi, eacrs, satdt, & + qimax, diameter, xni0, roqi0, & + fallsum, fallsum_qsi, fallsum_qg, & + vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & + xlwork2, factor, source, value, & + xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 + real(kind=kind_phys):: vt2ave + real(kind=kind_phys):: holdc, holdci + integer:: i, j, k, mstepmax, & + iprt, latd, lond, loop, loops, ifsat, n, idim, kdim + +!Temporaries used for inlining fpvs function + real(kind=kind_phys):: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp + +! variables for optimization + real(kind=kind_phys),dimension(its:ite):: dvec1,tvec1 + real(kind=kind_phys):: temp + +!----------------------------------------------------------------------------------------------------------------- + +! compute internal functions +! + cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv + xlcal(x) = xlv0-xlv1*(x-t0c) +!---------------------------------------------------------------- +! diffus: diffusion coefficient of the water vapor +! viscos: kinematic viscosity(m2s-1) +! Optimizatin : A**B => exp(log(A)*(B)) +! + diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y + viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y + xka(x,y) = 1.414e3*viscos(x,y)*y + diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) + venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & + /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) + conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) +! +! + idim = ite-its+1 + kdim = kte-kts+1 +! +!---------------------------------------------------------------- +! paddint 0 for negative values generated by dynamics +! + do k = kts, kte + do i = its, ite + qc(i,k) = max(qc(i,k),0.0) + qr(i,k) = max(qr(i,k),0.0) + qi(i,k) = max(qi(i,k),0.0) + qs(i,k) = max(qs(i,k),0.0) + qg(i,k) = max(qg(i,k),0.0) + enddo + enddo +! +!---------------------------------------------------------------- +! latent heat for phase changes and heat capacity. neglect the +! changes during microphysical process calculation emanuel(1994) +! + do k = kts, kte + do i = its, ite + cpm(i,k) = cpmcal(q(i,k)) + xl(i,k) = xlcal(t(i,k)) + enddo + enddo + do k = kts, kte + do i = its, ite + delz_tmp(i,k) = delz(i,k) + den_tmp(i,k) = den(i,k) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the surface rain, snow, graupel +! + do i = its, ite + rainncv(i) = 0. + if(present(snowncv) .and. present(snow)) snowncv(i) = 0. + if(present(graupelncv) .and. present(graupel)) graupelncv(i) = 0. + sr(i) = 0. +! new local array to catch step snow and graupel + tstepsnow(i) = 0. + tstepgraup(i) = 0. + enddo +! +!---------------------------------------------------------------- +! compute the minor time steps. +! + loops = max(nint(delt/dtcldcr),1) + dtcld = delt/loops + if(delt.le.dtcldcr) dtcld = delt +! + do loop = 1,loops +! +!---------------------------------------------------------------- +! initialize the large scale variables +! + do i = its, ite + mstep(i) = 1 + flgcld(i) = .true. + enddo +! +! do k = kts, kte +! do i = its, ite +! denfac(i,k) = sqrt(den0/den(i,k)) +! enddo +! enddo + do k = kts, kte + do i = its,ite + dvec1(i) = den(i,k) + enddo + call vrec(tvec1,dvec1,ite-its+1) + do i = its, ite + tvec1(i) = tvec1(i)*den0 + enddo + call vsqrt(dvec1,tvec1,ite-its+1) + do i = its,ite + denfac(i,k) = dvec1(i) + enddo + enddo +! +! Inline expansion for fpvs +! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qsat(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) + qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) + qsat(i,k,1) = max(qsat(i,k,1),qmin) + rh(i,k,1) = max(q(i,k) / qsat(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) + qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) + qsat(i,k,2) = max(qsat(i,k,2),qmin) + rh(i,k,2) = max(q(i,k) / qsat(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! initialize the variables for microphysical physics +! +! + do k = kts, kte + do i = its, ite + prevp(i,k) = 0. + psdep(i,k) = 0. + pgdep(i,k) = 0. + praut(i,k) = 0. + psaut(i,k) = 0. + pgaut(i,k) = 0. + pracw(i,k) = 0. + praci(i,k) = 0. + piacr(i,k) = 0. + psaci(i,k) = 0. + psacw(i,k) = 0. + pracs(i,k) = 0. + psacr(i,k) = 0. + pgacw(i,k) = 0. + paacw(i,k) = 0. + pgaci(i,k) = 0. + pgacr(i,k) = 0. + pgacs(i,k) = 0. + pigen(i,k) = 0. + pidep(i,k) = 0. + pcond(i,k) = 0. + psmlt(i,k) = 0. + pgmlt(i,k) = 0. + pseml(i,k) = 0. + pgeml(i,k) = 0. + psevp(i,k) = 0. + pgevp(i,k) = 0. + falk(i,k,1) = 0. + falk(i,k,2) = 0. + falk(i,k,3) = 0. + fall(i,k,1) = 0. + fall(i,k,2) = 0. + fall(i,k,3) = 0. + fallc(i,k) = 0. + falkc(i,k) = 0. + xni(i,k) = 1.e3 + enddo + enddo +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- + do k = kts, kte + do i = its, ite + temp = (den(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + enddo + enddo +! +!---------------------------------------------------------------- +! compute the fallout term: +! first, vertical terminal velosity for minor loops +!---------------------------------------------------------------- + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + workr(i,k) = work1(i,k,1) + qsum(i,k) = max( (qs(i,k)+qg(i,k)), 1.E-15) + if( qsum(i,k) .gt. 1.e-15 ) then + worka(i,k) = (work1(i,k,2)*qs(i,k) + work1(i,k,3)*qg(i,k)) & + / qsum(i,k) + else + worka(i,k) = 0. + endif + denqrs1(i,k) = den(i,k)*qr(i,k) + denqrs2(i,k) = den(i,k)*qs(i,k) + denqrs3(i,k) = den(i,k)*qg(i,k) + if(qr(i,k).le.0.0) workr(i,k) = 0.0 + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & + delqrs1,dtcld,1,1) + call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & + denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) + do k = kts, kte + do i = its, ite + qr(i,k) = max(denqrs1(i,k)/den(i,k),0.) + qs(i,k) = max(denqrs2(i,k)/den(i,k),0.) + qg(i,k) = max(denqrs3(i,k)/den(i,k),0.) + fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) + fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) + fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) + enddo + enddo + do i = its, ite + fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld + fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld + fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld + enddo + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +! + do k = kte, kts, -1 + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(t(i,k).gt.t0c) then +!--------------------------------------------------------------- +! psmlt: melting of snow [HL A33] [RH83 A25] +! (T>T0: S->R) +!--------------------------------------------------------------- + xlf = xlf0 + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + if(qs(i,k).gt.0.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & + *n0sfac(i,k)*(precs1*rslope2(i,k,2) & + +precs2*work2(i,k)*coeres)/den(i,k) + psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & + -qs(i,k)/mstep(i)),0.) + qs(i,k) = qs(i,k) + psmlt(i,k) + qr(i,k) = qr(i,k) - psmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) + endif +!--------------------------------------------------------------- +! pgmlt: melting of graupel [HL A23] [LFO 47] +! (T>T0: G->R) +!--------------------------------------------------------------- + if(qg(i,k).gt.0.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & + *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & + +precg2*work2(i,k)*coeres)/den(i,k) + pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & + -qg(i,k)/mstep(i)),0.) + qg(i,k) = qg(i,k) + pgmlt(i,k) + qr(i,k) = qr(i,k) - pgmlt(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) + endif + endif + enddo + enddo +!--------------------------------------------------------------- +! Vice [ms-1] : fallout of ice crystal [HDC 5a] +!--------------------------------------------------------------- + do k = kte, kts, -1 + do i = its, ite + if(qi(i,k).le.0.) then + work1c(i,k) = 0. + else + xmi = den(i,k)*qi(i,k)/xni(i,k) + diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) + work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) + endif + enddo + enddo +! +! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) +! + do k = kte, kts, -1 + do i = its, ite + denqci(i,k) = den(i,k)*qi(i,k) + enddo + enddo + call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & + delqi,dtcld,1,0) + do k = kts, kte + do i = its, ite + qi(i,k) = max(denqci(i,k)/den(i,k),0.) + enddo + enddo + do i = its, ite + fallc(i,1) = delqi(i)/delz(i,1)/dtcld + enddo +! +!---------------------------------------------------------------- +! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf +! + do i = its, ite + fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) + fallsum_qsi = fall(i,kts,2)+fallc(i,kts) + fallsum_qg = fall(i,kts,3) + if(fallsum.gt.0.) then + rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i) + rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) + endif + if(fallsum_qsi.gt.0.) then + tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & + + tstepsnow(i) + if(present(snowncv) .and. present(snow)) then + snowncv(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & + + snowncv(i) + snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i) + endif + endif + if(fallsum_qg.gt.0.) then + tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & + + tstepgraup(i) + if(present (graupelncv) .and. present (graupel)) then + graupelncv(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & + + graupelncv(i) + graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i) + endif + endif + if(present (snowncv)) then + if(fallsum.gt.0.)sr(i)=(snowncv(i) + graupelncv(i))/(rainncv(i)+1.e-12) + else + if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) + endif + enddo +! +!--------------------------------------------------------------- +! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] +! (T>T0: I->C) +!--------------------------------------------------------------- + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + xlf = xls-xl(i,k) + if(supcol.lt.0.) xlf = xlf0 + if(supcol.lt.0.and.qi(i,k).gt.0.) then + qc(i,k) = qc(i,k) + qi(i,k) + t(i,k) = t(i,k) - xlf/cpm(i,k)*qi(i,k) + qi(i,k) = 0. + endif +!--------------------------------------------------------------- +! pihmf: homogeneous freezing of cloud water below -40c [HL A45] +! (T<-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.40..and.qc(i,k).gt.0.) then + qi(i,k) = qi(i,k) + qc(i,k) + t(i,k) = t(i,k) + xlf/cpm(i,k)*qc(i,k) + qc(i,k) = 0. + endif +!--------------------------------------------------------------- +! pihtf: heterogeneous freezing of cloud water [HL A44] +! (T0>T>-40C: C->I) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qc(i,k).gt.qmin) then +! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & +! * den(i,k)/denr/xncr*qc(i,k)**2*dtcld,qc(i,k)) + supcolt=min(supcol,50.) + pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & + * den(i,k)/denr/xncr*qc(i,k)*qc(i,k)*dtcld,qc(i,k)) + qi(i,k) = qi(i,k) + pfrzdtc + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc + qc(i,k) = qc(i,k)-pfrzdtc + endif +!--------------------------------------------------------------- +! pgfrz: freezing of rain water [HL A20] [LFO 45] +! (TG) +!--------------------------------------------------------------- + if(supcol.gt.0..and.qr(i,k).gt.0.) then +! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & +! * (exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & +! * rslope(i,k,1)*dtcld,qr(i,k)) + temp = rslope3(i,k,1) + temp = temp*temp*rslope(i,k,1) + supcolt=min(supcol,50.) + pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & + *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & + qr(i,k)) + qg(i,k) = qg(i,k) + pfrzdtr + t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr + qr(i,k) = qr(i,k)-pfrzdtr + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! update the slope parameters for microphysics computation +! + do k = kts, kte + do i = its, ite + qrs_tmp(i,k,1) = qr(i,k) + qrs_tmp(i,k,2) = qs(i,k) + qrs_tmp(i,k,3) = qg(i,k) + enddo + enddo + call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & + work1,its,ite,kts,kte) +!------------------------------------------------------------------ +! work1: the thermodynamic term in the denominator associated with +! heat conduction and vapor diffusion +! (ry88, y93, h85) +! work2: parameter associated with the ventilation effects(y93) +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qsat(i,k,1)) + work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qsat(i,k,2)) + work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) + enddo + enddo +! +!=============================================================== +! +! warm rain processes +! +! - follows the processes in RH83 and LFO except for autoconcersion +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supsat = max(q(i,k),qmin)-qsat(i,k,1) + satdt = supsat/dtcld +!--------------------------------------------------------------- +! praut: auto conversion rate from cloud to rain [HDC 16] +! (C->R) +!--------------------------------------------------------------- + if(qc(i,k).gt.qc0) then + praut(i,k) = qck1*qc(i,k)**(7./3.) + praut(i,k) = min(praut(i,k),qc(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! pracw: accretion of cloud water by rain [HL A40] [LFO 51] +! (C->R) +!--------------------------------------------------------------- + if(qr(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!--------------------------------------------------------------- +! prevp: evaporation/condensation rate of rain [HDC 14] +! (V->R or R->V) +!--------------------------------------------------------------- + if(qr(i,k).gt.0.) then + coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) + prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & + + precr2*work2(i,k)*coeres)/work1(i,k,1) + if(prevp(i,k).lt.0.) then + prevp(i,k) = max(prevp(i,k),-qr(i,k)/dtcld) + prevp(i,k) = max(prevp(i,k),satdt/2) + else + prevp(i,k) = min(prevp(i,k),satdt/2) + endif + endif + enddo + enddo +! +!=============================================================== +! +! cold rain processes +! +! - follows the revised ice microphysics processes in HDC +! - the processes same as in RH83 and RH84 and LFO behave +! following ice crystal hapits defined in HDC, inclduing +! intercept parameter for snow (n0s), ice crystal number +! concentration (ni), ice nuclei number concentration +! (n0i), ice diameter (d) +! +!=============================================================== +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + supsat = max(q(i,k),qmin)-qsat(i,k,2) + satdt = supsat/dtcld + ifsat = 0 +!------------------------------------------------------------- +! Ni: ice crystal number concentraiton [HDC 5c] +!------------------------------------------------------------- +! xni(i,k) = min(max(5.38e7*(den(i,k) & +! * max(qi(i,k),qmin))**0.75,1.e3),1.e6) + temp = (den(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + eacrs = exp(0.07*(-supcol)) +! + xmi = den(i,k)*qi(i,k)/xni(i,k) + diameter = min(dicon * sqrt(xmi),dimax) + vt2i = 1.49e4*diameter**1.31 + vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) + vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) + vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) + qsum(i,k) = max( (qs(i,k)+qg(i,k)), 1.E-15) + if(qsum(i,k) .gt. 1.e-15) then + vt2ave=(vt2s*qs(i,k)+vt2g*qg(i,k))/(qsum(i,k)) + else + vt2ave=0. + endif + if(supcol.gt.0.and.qi(i,k).gt.qmin) then + if(qr(i,k).gt.qcrmin) then +!------------------------------------------------------------- +! praci: accretion of cloud ice by rain [HL A15] [LFO 25] +! (TR) +!------------------------------------------------------------- + acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & + + diameter**2*rslope(i,k,1) + praci(i,k) = pi*qi(i,k)*n0r*abs(vt2r-vt2i)*acrfac/4. +! reduce collection efficiency (suggested by B. Wilt) + praci(i,k) = praci(i,k)*min(max(0.0,qr(i,k)/qi(i,k)),1.)**2 + praci(i,k) = min(praci(i,k),qi(i,k)/dtcld) +!------------------------------------------------------------- +! piacr: accretion of rain by cloud ice [HL A19] [LFO 26] +! (TS or R->G) +!------------------------------------------------------------- + piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & + * g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & + * rslopeb(i,k,1)/24./den(i,k) +! reduce collection efficiency (suggested by B. Wilt) + piacr(i,k) = piacr(i,k)*min(max(0.0,qi(i,k)/qr(i,k)),1.)**2 + piacr(i,k) = min(piacr(i,k),qr(i,k)/dtcld) + endif +!------------------------------------------------------------- +! psaci: accretion of cloud ice by snow [HDC 10] +! (TS) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin) then + acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & + + diameter**2*rslope(i,k,2) + psaci(i,k) = pi*qi(i,k)*eacrs*n0s*n0sfac(i,k) & + * abs(vt2ave-vt2i)*acrfac/4. + psaci(i,k) = min(psaci(i,k),qi(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgaci: accretion of cloud ice by graupel [HL A17] [LFO 41] +! (TG) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin) then + egi = exp(0.07*(-supcol)) + acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & + + diameter**2*rslope(i,k,3) + pgaci(i,k) = pi*egi*qi(i,k)*n0g*abs(vt2ave-vt2i)*acrfac/4. + pgaci(i,k) = min(pgaci(i,k),qi(i,k)/dtcld) + endif + endif +!------------------------------------------------------------- +! psacw: accretion of cloud water by snow [HL A7] [LFO 24] +! (TS, and T>=T0: C->R) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & +! reduce collection efficiency (suggested by B. Wilt) + * min(max(0.0,qs(i,k)/qc(i,k)),1.)**2 & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgacw: accretion of cloud water by graupel [HL A6] [LFO 40] +! (TG, and T>=T0: C->R) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qc(i,k).gt.qmin) then + pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & +! reduce collection efficiency (suggested by B. Wilt) + * min(max(0.0,qg(i,k)/qc(i,k)),1.)**2 & + * qc(i,k)*denfac(i,k),qc(i,k)/dtcld) + endif +!------------------------------------------------------------- +! paacw: accretion of cloud water by averaged snow/graupel +! (TG or S, and T>=T0: C->R) +!------------------------------------------------------------- + if(qsum(i,k) .gt. 1.e-15) then + paacw(i,k) = (qs(i,k)*psacw(i,k)+qg(i,k)*pgacw(i,k)) & + /(qsum(i,k)) + endif +!------------------------------------------------------------- +! pracs: accretion of snow by rain [HL A11] [LFO 27] +! (TG) +!------------------------------------------------------------- + if(qs(i,k).gt.qcrmin.and.qr(i,k).gt.qcrmin) then + if(supcol.gt.0) then + acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & + + 2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & + + .5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) + pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & + * (dens/den(i,k))*acrfac +! reduce collection efficiency (suggested by B. Wilt) + pracs(i,k) = pracs(i,k)*min(max(0.0,qr(i,k)/qs(i,k)),1.)**2 + pracs(i,k) = min(pracs(i,k),qs(i,k)/dtcld) + endif +!------------------------------------------------------------- +! psacr: accretion of rain by snow [HL A10] [LFO 28] +! (TS or R->G) (T>=T0: enhance melting of snow) +!------------------------------------------------------------- + acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & + + 2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & + +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) + psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & + * (denr/den(i,k))*acrfac +! reduce collection efficiency (suggested by B. Wilt) + psacr(i,k) = psacr(i,k)*min(max(0.0,qs(i,k)/qr(i,k)),1.)**2 + psacr(i,k) = min(psacr(i,k),qr(i,k)/dtcld) + endif +!------------------------------------------------------------- +! pgacr: accretion of rain by graupel [HL A12] [LFO 42] +! (TG) (T>=T0: enhance melting of graupel) +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qr(i,k).gt.qcrmin) then + acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & + + 2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & + + .5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) + pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & + * acrfac +! reduce collection efficiency (suggested by B. Wilt) + pgacr(i,k) = pgacr(i,k)*min(max(0.0,qg(i,k)/qr(i,k)),1.)**2 + pgacr(i,k) = min(pgacr(i,k),qr(i,k)/dtcld) + endif +! +!------------------------------------------------------------- +! pgacs: accretion of snow by graupel [HL A13] [LFO 29] +! (S->G): This process is eliminated in V3.0 with the +! new combined snow/graupel fall speeds +!------------------------------------------------------------- + if(qg(i,k).gt.qcrmin.and.qs(i,k).gt.qcrmin) then + pgacs(i,k) = 0. + endif + if(supcol.le.0) then + xlf = xlf0 +!------------------------------------------------------------- +! pseml: enhanced melting of snow by accretion of water [HL A34] +! (T>=T0: S->R) +!------------------------------------------------------------- + if(qs(i,k).gt.0.) & + pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & + / xlf,-qs(i,k)/dtcld),0.) +!------------------------------------------------------------- +! pgeml: enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] +! (T>=T0: G->R) +!------------------------------------------------------------- + if(qg(i,k).gt.0.) & + pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & + / xlf,-qg(i,k)/dtcld),0.) + endif + if(supcol.gt.0) then +!------------------------------------------------------------- +! pidep: deposition/Sublimation rate of ice [HDC 9] +! (TI or I->V) +!------------------------------------------------------------- + if(qi(i,k).gt.0.and.ifsat.ne.1) then + pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) + supice = satdt-prevp(i,k) + if(pidep(i,k).lt.0.) then + pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) + pidep(i,k) = max(pidep(i,k),-qi(i,k)/dtcld) + else + pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! psdep: deposition/sublimation rate of snow [HDC 14] +! (TS or S->V) +!------------------------------------------------------------- + if(qs(i,k).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & + + precs2*work2(i,k)*coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k) + if(psdep(i,k).lt.0.) then + psdep(i,k) = max(psdep(i,k),-qs(i,k)/dtcld) + psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) + else + psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & + ifsat = 1 + endif +!------------------------------------------------------------- +! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] +! (TG or G->V) +!------------------------------------------------------------- + if(qg(i,k).gt.0..and.ifsat.ne.1) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & + + precg2*work2(i,k)*coeres)/work1(i,k,2) + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) + if(pgdep(i,k).lt.0.) then + pgdep(i,k) = max(pgdep(i,k),-qg(i,k)/dtcld) + pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) + else + pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) + endif + if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & + abs(satdt)) ifsat = 1 + endif +!------------------------------------------------------------- +! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] +! (TI) +!------------------------------------------------------------- + if(supsat.gt.0.and.ifsat.ne.1) then + supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) + xni0 = 1.e3*exp(0.1*supcol) + roqi0 = 4.92e-11*xni0**1.33 + pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qi(i,k),0.))/dtcld) + pigen(i,k) = min(min(pigen(i,k),satdt),supice) + endif +! +!------------------------------------------------------------- +! psaut: conversion(aggregation) of ice to snow [HDC 12] +! (TS) +!------------------------------------------------------------- + if(qi(i,k).gt.0.) then + qimax = roqimax/den(i,k) + psaut(i,k) = max(0.,(qi(i,k)-qimax)/dtcld) + endif +! +!------------------------------------------------------------- +! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] +! (TG) +!------------------------------------------------------------- + if(qs(i,k).gt.0.) then + alpha2 = 1.e-3*exp(0.09*(-supcol)) + pgaut(i,k) = min(max(0.,alpha2*(qs(i,k)-qs0)),qs(i,k)/dtcld) + endif + endif +! +!------------------------------------------------------------- +! psevp: evaporation of melting snow [HL A35] [RH83 A27] +! (T>=T0: S->V) +!------------------------------------------------------------- + if(supcol.lt.0.) then + if(qs(i,k).gt.0..and.rh(i,k,1).lt.1.) then + coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) + psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & + * rslope2(i,k,2)+precs2*work2(i,k) & + * coeres)/work1(i,k,1) + psevp(i,k) = min(max(psevp(i,k),-qs(i,k)/dtcld),0.) + endif +!------------------------------------------------------------- +! pgevp: evaporation of melting graupel [HL A25] [RH84 A19] +! (T>=T0: G->V) +!------------------------------------------------------------- + if(qg(i,k).gt.0..and.rh(i,k,1).lt.1.) then + coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) + pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & + + precg2*work2(i,k)*coeres)/work1(i,k,1) + pgevp(i,k) = min(max(pgevp(i,k),-qg(i,k)/dtcld),0.) + endif + endif + enddo + enddo +! +! +!---------------------------------------------------------------- +! check mass conservation of generation terms and feedback to the +! large scale +! + do k = kts, kte + do i = its, ite +! + delta2=0. + delta3=0. + if(qr(i,k).lt.1.e-4.and.qs(i,k).lt.1.e-4) delta2=1. + if(qr(i,k).lt.1.e-4) delta3=1. + if(t(i,k).le.t0c) then +! +! cloud water +! + value = max(qmin,qc(i,k)) + source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + endif +! +! cloud ice +! + value = max(qmin,qi(i,k)) + source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & + + pgaci(i,k))*dtcld + if (source.gt.value) then + factor = value/source + psaut(i,k) = psaut(i,k)*factor + pigen(i,k) = pigen(i,k)*factor + pidep(i,k) = pidep(i,k)*factor + praci(i,k) = praci(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pgaci(i,k) = pgaci(i,k)*factor + endif +! +! rain +! + value = max(qmin,qr(i,k)) + source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & + + pgacr(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + prevp(i,k) = prevp(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pgacr(i,k) = pgacr(i,k)*factor + endif +! +! snow +! + value = max(qmin,qs(i,k)) + source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & + * delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & + + psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld + if (source.gt.value) then + factor = value/source + psdep(i,k) = psdep(i,k)*factor + psaut(i,k) = psaut(i,k)*factor + pgaut(i,k) = pgaut(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + praci(i,k) = praci(i,k)*factor + psaci(i,k) = psaci(i,k)*factor + pracs(i,k) = pracs(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pgacs(i,k) = pgacs(i,k)*factor + endif +! +! graupel +! + value = max(qmin,qg(i,k)) + source = -(pgdep(i,k)+pgaut(i,k) & + + piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & + + psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & + + pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgdep(i,k) = pgdep(i,k)*factor + pgaut(i,k) = pgaut(i,k)*factor + piacr(i,k) = piacr(i,k)*factor + praci(i,k) = praci(i,k)*factor + psacr(i,k) = psacr(i,k)*factor + pracs(i,k) = pracs(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + pgaci(i,k) = pgaci(i,k)*factor + pgacr(i,k) = pgacr(i,k)*factor + pgacs(i,k) = pgacs(i,k)*factor + endif +! + work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & + + paacw(i,k)+paacw(i,k))*dtcld,0.) + qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & + + prevp(i,k)-piacr(i,k)-pgacr(i,k) & + - psacr(i,k))*dtcld,0.) + qi(i,k) = max(qi(i,k)-(psaut(i,k)+praci(i,k) & + + psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & + * dtcld,0.) + qs(i,k) = max(qs(i,k)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & + - pgaut(i,k)+piacr(i,k)*delta3 & + + praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & + - pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & + * dtcld,0.) + qg(i,k) = max(qg(i,k)+(pgdep(i,k)+pgaut(i,k) & + + piacr(i,k)*(1.-delta3) & + + praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & + + pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & + + pgacr(i,k)+pgacs(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & + -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & + +paacw(i,k)+pgacr(i,k)+psacr(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + else +! +! cloud water +! + value = max(qmin,qc(i,k)) + source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + endif +! +! rain +! + value = max(qmin,qr(i,k)) + source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & + -paacw(i,k)-prevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + praut(i,k) = praut(i,k)*factor + prevp(i,k) = prevp(i,k)*factor + pracw(i,k) = pracw(i,k)*factor + paacw(i,k) = paacw(i,k)*factor + pseml(i,k) = pseml(i,k)*factor + pgeml(i,k) = pgeml(i,k)*factor + endif +! +! snow +! + value = max(qcrmin,qs(i,k)) + source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgacs(i,k) = pgacs(i,k)*factor + psevp(i,k) = psevp(i,k)*factor + pseml(i,k) = pseml(i,k)*factor + endif +! +! graupel +! + value = max(qcrmin,qg(i,k)) + source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld + if (source.gt.value) then + factor = value/source + pgacs(i,k) = pgacs(i,k)*factor + pgevp(i,k) = pgevp(i,k)*factor + pgeml(i,k) = pgeml(i,k)*factor + endif +! + work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) +! update + q(i,k) = q(i,k)+work2(i,k)*dtcld + qc(i,k) = max(qc(i,k)-(praut(i,k)+pracw(i,k) & + + paacw(i,k)+paacw(i,k))*dtcld,0.) + qr(i,k) = max(qr(i,k)+(praut(i,k)+pracw(i,k) & + + prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & + - pgeml(i,k))*dtcld,0.) + qs(i,k) = max(qs(i,k)+(psevp(i,k)-pgacs(i,k) & + + pseml(i,k))*dtcld,0.) + qg(i,k) = max(qg(i,k)+(pgacs(i,k)+pgevp(i,k) & + + pgeml(i,k))*dtcld,0.) + xlf = xls-xl(i,k) + xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & + -xlf*(pseml(i,k)+pgeml(i,k)) + t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld + endif + enddo + enddo +! +! Inline expansion for fpvs +! qsat(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) +! qsat(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) + hsub = xls + hvap = xlv0 + cvap = cpv + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + do k = kts, kte + do i = its, ite + tr=ttp/t(i,k) + qsat(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + qsat(i,k,1) = min(qsat(i,k,1),0.99*p(i,k)) + qsat(i,k,1) = ep2 * qsat(i,k,1) / (p(i,k) - qsat(i,k,1)) + qsat(i,k,1) = max(qsat(i,k,1),qmin) + tr=ttp/t(i,k) + if(t(i,k).lt.ttp) then + qsat(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) + else + qsat(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) + endif + qsat(i,k,2) = min(qsat(i,k,2),0.99*p(i,k)) + qsat(i,k,2) = ep2 * qsat(i,k,2) / (p(i,k) - qsat(i,k,2)) + qsat(i,k,2) = max(qsat(i,k,2),qmin) + enddo + enddo +! +!---------------------------------------------------------------- +! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] +! if there exists additional water vapor condensated/if +! evaporation of cloud water is not enough to remove subsaturation +! + do k = kts, kte + do i = its, ite + work1(i,k,1) = conden(t(i,k),q(i,k),qsat(i,k,1),xl(i,k),cpm(i,k)) + work2(i,k) = qc(i,k)+work1(i,k,1) + pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) + if(qc(i,k).gt.0..and.work1(i,k,1).lt.0.) & + pcond(i,k) = max(work1(i,k,1),-qc(i,k))/dtcld + q(i,k) = q(i,k)-pcond(i,k)*dtcld + qc(i,k) = max(qc(i,k)+pcond(i,k)*dtcld,0.) + t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld + enddo + enddo +! +! +!---------------------------------------------------------------- +! padding for small values +! + do k = kts, kte + do i = its, ite + if(qc(i,k).le.qmin) qc(i,k) = 0.0 + if(qi(i,k).le.qmin) qi(i,k) = 0.0 + enddo + enddo + enddo ! big loops + + if(present(rainprod2d) .and. present(evapprod2d)) then + do k = kts, kte + do i = its,ite + rainprod2d(i,k) = praut(i,k)+pracw(i,k)+praci(i,k)+psaci(i,k)+pgaci(i,k) & + + psacw(i,k)+pgacw(i,k)+paacw(i,k)+psaut(i,k) + evapprod2d(i,k) = -(prevp(i,k)+psevp(i,k)+pgevp(i,k)+psdep(i,k)+pgdep(i,k)) + enddo + enddo + endif +! +!---------------------------------------------------------------- +! CCPP checks: +! + + errmsg = 'mp_wsm6_run OK' + errflg = 0 + + end subroutine mp_wsm6_run + +!================================================================================================================= + real(kind=kind_phys) function rgmma(x) +!================================================================================================================= +!rgmma function: use infinite product form + + real(kind=kind_phys),intent(in):: x + + integer:: i + real(kind=kind_phys),parameter:: euler=0.577215664901532 + real(kind=kind_phys):: y + +!----------------------------------------------------------------------------------------------------------------- + + if(x.eq.1.)then + rgmma=0. + else + rgmma=x*exp(euler*x) + do i = 1,10000 + y = float(i) + rgmma=rgmma*(1.000+x/y)*exp(-x/y) + enddo + rgmma=1./rgmma + endif + + end function rgmma + +!================================================================================================================= + real(kind=kind_phys) function fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) +!================================================================================================================= + + integer,intent(in):: ice + real(kind=kind_phys),intent(in):: cice,cliq,cvap,hsub,hvap,psat,rd,rv,t0c + real(kind=kind_phys),intent(in):: t + + real(kind=kind_phys):: tr,ttp,dldt,dldti,xa,xb,xai,xbi + +!----------------------------------------------------------------------------------------------------------------- + + ttp=t0c+0.01 + dldt=cvap-cliq + xa=-dldt/rv + xb=xa+hvap/(rv*ttp) + dldti=cvap-cice + xai=-dldti/rv + xbi=xai+hsub/(rv*ttp) + tr=ttp/t + if(t.lt.ttp.and.ice.eq.1) then + fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) + else + fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) + endif + + end function fpvs + +!================================================================================================================= + subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: den,denfac,t + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte,3):: qrs + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte,3):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdar,lamdas,lamdag,x,y,z,supcol + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 + + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k,1).le.qcrmin)then + rslope(i,k,1) = rslopermax + rslopeb(i,k,1) = rsloperbmax + rslope2(i,k,1) = rsloper2max + rslope3(i,k,1) = rsloper3max + else + rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) + rslopeb(i,k,1) = rslope(i,k,1)**bvtr + rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) + rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) + endif + if(qrs(i,k,2).le.qcrmin)then + rslope(i,k,2) = rslopesmax + rslopeb(i,k,2) = rslopesbmax + rslope2(i,k,2) = rslopes2max + rslope3(i,k,2) = rslopes3max + else + rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) + rslopeb(i,k,2) = rslope(i,k,2)**bvts + rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) + rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) + endif + if(qrs(i,k,3).le.qcrmin)then + rslope(i,k,3) = rslopegmax + rslopeb(i,k,3) = rslopegbmax + rslope2(i,k,3) = rslopeg2max + rslope3(i,k,3) = rslopeg3max + else + rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) + rslopeb(i,k,3) = rslope(i,k,3)**bvtg + rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) + rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) + endif + vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) + vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) + vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) + if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 + if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 + if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 + enddo + enddo + + end subroutine slope_wsm6 + +!================================================================================================================= + subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdar,x,y + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 + + do k = kts, kte + do i = its, ite + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopermax + rslopeb(i,k) = rsloperbmax + rslope2(i,k) = rsloper2max + rslope3(i,k) = rsloper3max + else + rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtr + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + + end subroutine slope_rain + +!================================================================================================================= + subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdas,x,y,z,supcol + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 +! + do k = kts, kte + do i = its, ite + supcol = t0c-t(i,k) +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopesmax + rslopeb(i,k) = rslopesbmax + rslope2(i,k) = rslopes2max + rslope3(i,k) = rslopes3max + else + rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) + rslopeb(i,k) = rslope(i,k)**bvts + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + + end subroutine slope_snow + +!================================================================================================================= + subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3,vt,its,ite,kts,kte) +!================================================================================================================= + +!--- input arguments: + integer:: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: qrs,den,denfac,t + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: & + rslope,rslopeb,rslope2,rslope3,vt + +!--- local variables and arrays: + integer:: i,k + + real(kind=kind_phys),parameter:: t0c = 273.15 + real(kind=kind_phys):: lamdag,x,y + real(kind=kind_phys),dimension(its:ite,kts:kte):: n0sfac + +!----------------------------------------------------------------------------------------------------------------- + +!size distributions: (x=mixing ratio, y=air density): +!valid for mixing ratio > 1.e-9 kg/kg. + lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 + + do k = kts, kte + do i = its, ite +!--------------------------------------------------------------- +! n0s: Intercept parameter for snow [m-4] [HDC 6] +!--------------------------------------------------------------- + if(qrs(i,k).le.qcrmin)then + rslope(i,k) = rslopegmax + rslopeb(i,k) = rslopegbmax + rslope2(i,k) = rslopeg2max + rslope3(i,k) = rslopeg3max + else + rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) + rslopeb(i,k) = rslope(i,k)**bvtg + rslope2(i,k) = rslope(i,k)*rslope(i,k) + rslope3(i,k) = rslope2(i,k)*rslope(i,k) + endif + vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) + if(qrs(i,k).le.0.0) vt(i,k) = 0.0 + enddo + enddo + + end subroutine slope_graup + +!================================================================================================================= + subroutine nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) +!================================================================================================================= +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + +!--- input arguments: + integer,intent(in):: im,km,id,iter + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(im):: precip + real(kind=kind_phys),intent(inout),dimension(im,km):: rql,wwl + +!---- local variables and arrays: + integer:: i,k,n,m,kk,kb,kt + real(kind=kind_phys):: tl,tl2,qql,dql,qqd + real(kind=kind_phys):: th,th2,qqh,dqh + real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl + real(kind=kind_phys),dimension(km):: dz,ww,qq,wd,wa,was + real(kind=kind_phys),dimension(km):: den,denfac,tk + real(kind=kind_phys),dimension(km):: qn,qr,tmp,tmp1,tmp2,tmp3 + real(kind=kind_phys),dimension(km+1):: wi,zi,za + real(kind=kind_phys),dimension(km+1):: dza,qa,qmi,qpi + +!----------------------------------------------------------------------------------------------------------------- + + precip(:) = 0.0 + + i_loop: do i=1,im + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + enddo + qa(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + rql(i,:) = qn(:) + enddo i_loop + + end subroutine nislfv_rain_plm + +!================================================================================================================= + subroutine nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2,precip1,precip2,dt,id,iter) +!================================================================================================================= +! +! for non-iteration semi-Lagrangain forward advection for cloud +! with mass conservation and positive definite advection +! 2nd order interpolation with monotonic piecewise linear method +! this routine is under assumption of decfl < 1 for semi_Lagrangian +! +! dzl depth of model layer in meter +! wwl terminal velocity at model layer m/s +! rql cloud density*mixing ration +! precip precipitation +! dt time step +! id kind of precip: 0 test case; 1 raindrop +! iter how many time to guess mean terminal velocity: 0 pure forward. +! 0 : use departure wind for advection +! 1 : use mean wind for advection +! > 1 : use mean wind after iter-1 iterations +! +! author: hann-ming henry juang +! implemented by song-you hong +! + +!--- input arguments: + integer,intent(in):: im,km,id,iter + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(im,km):: dzl,denl,denfacl,tkl + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(im):: precip1,precip2 + real(kind=kind_phys),intent(inout),dimension(im,km):: rql,rql2,wwl + +!---- local variables and arrays: + integer:: i,ist,k,n,m,kk,kb,kt + real(kind=kind_phys):: tl,tl2,qql,dql,qqd + real(kind=kind_phys):: th,th2,qqh,dqh + real(kind=kind_phys):: zsum,qsum,dim,dip,c1,con1,fa1,fa2 + real(kind=kind_phys):: allold,allnew,zz,dzamin,cflmax,decfl + real(kind=kind_phys),dimension(km):: dz,ww,qq,qq2,wd,wa,wa2,was + real(kind=kind_phys),dimension(km):: den,denfac,tk + real(kind=kind_phys),dimension(km):: qn,qr,qr2,tmp,tmp1,tmp2,tmp3 + real(kind=kind_phys),dimension(km+1):: wi,zi,za + real(kind=kind_phys),dimension(km+1):: dza,qa,qa2,qmi,qpi + real(kind=kind_phys),dimension(im):: precip + +!----------------------------------------------------------------------------------------------------------------- + + precip(:) = 0.0 + precip1(:) = 0.0 + precip2(:) = 0.0 + + i_loop: do i=1,im + dz(:) = dzl(i,:) + qq(:) = rql(i,:) + qq2(:) = rql2(i,:) + ww(:) = wwl(i,:) + den(:) = denl(i,:) + denfac(:) = denfacl(i,:) + tk(:) = tkl(i,:) +! skip for no precipitation for all layers + allold = 0.0 + do k=1,km + allold = allold + qq(k) + qq2(k) + enddo + if(allold.le.0.0) then + cycle i_loop + endif +! +! compute interface values + zi(1)=0.0 + do k=1,km + zi(k+1) = zi(k)+dz(k) + enddo +! +! save departure wind + wd(:) = ww(:) + n=1 + 100 continue +! plm is 2nd order, we can use 2nd order wi or 3rd order wi +! 2nd order interpolation to get wi + wi(1) = ww(1) + wi(km+1) = ww(km) + do k=2,km + wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) + enddo +! 3rd order interpolation to get wi + fa1 = 9./16. + fa2 = 1./16. + wi(1) = ww(1) + wi(2) = 0.5*(ww(2)+ww(1)) + do k=3,km-1 + wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) + enddo + wi(km) = 0.5*(ww(km)+ww(km-1)) + wi(km+1) = ww(km) +! +! terminate of top of raingroup + do k=2,km + if( ww(k).eq.0.0 ) wi(k)=ww(k-1) + enddo +! +! diffusivity of wi + con1 = 0.05 + do k=km,1,-1 + decfl = (wi(k+1)-wi(k))*dt/dz(k) + if( decfl .gt. con1 ) then + wi(k) = wi(k+1) - con1*dz(k)/dt + endif + enddo +! compute arrival point + do k=1,km+1 + za(k) = zi(k) - wi(k)*dt + enddo +! + do k=1,km + dza(k) = za(k+1)-za(k) + enddo + dza(km+1) = zi(km+1) - za(km+1) +! +! computer deformation at arrival point + do k=1,km + qa(k) = qq(k)*dz(k)/dza(k) + qa2(k) = qq2(k)*dz(k)/dza(k) + qr(k) = qa(k)/den(k) + qr2(k) = qa2(k)/den(k) + enddo + qa(km+1) = 0.0 + qa2(km+1) = 0.0 +! call maxmin(km,1,qa,' arrival points ') +! +! compute arrival terminal velocity, and estimate mean terminal velocity +! then back to use mean terminal velocity + if( n.le.iter ) then + call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) + call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) + do k = 1, km + tmp(k) = max((qr(k)+qr2(k)), 1.E-15) + if( tmp(k) .gt. 1.e-15 ) then + wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) + else + wa(k) = 0. + endif + enddo + if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) + do k=1,km +!#ifdef DEBUG +! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & +! ww(k),wa(k) +!#endif +! mean wind is average of departure and new arrival winds + ww(k) = 0.5* ( wd(k)+wa(k) ) + enddo + was(:) = wa(:) + n=n+1 + go to 100 + endif + + ist_loop : do ist = 1, 2 + if (ist.eq.2) then + qa(:) = qa2(:) + endif +! + precip(i) = 0. +! +! estimate values at arrival cell interface with monotone + do k=2,km + dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) + dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) + if( dip*dim.le.0.0 ) then + qmi(k)=qa(k) + qpi(k)=qa(k) + else + qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) + qmi(k)=2.0*qa(k)-qpi(k) + if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then + qpi(k) = qa(k) + qmi(k) = qa(k) + endif + endif + enddo + qpi(1)=qa(1) + qmi(1)=qa(1) + qmi(km+1)=qa(km+1) + qpi(km+1)=qa(km+1) +! +! interpolation to regular point + qn = 0.0 + kb=1 + kt=1 + intp : do k=1,km + kb=max(kb-1,1) + kt=max(kt-1,1) +! find kb and kt + if( zi(k).ge.za(km+1) ) then + exit intp + else + find_kb : do kk=kb,km + if( zi(k).le.za(kk+1) ) then + kb = kk + exit find_kb + else + cycle find_kb + endif + enddo find_kb + find_kt : do kk=kt,km + if( zi(k+1).le.za(kk) ) then + kt = kk + exit find_kt + else + cycle find_kt + endif + enddo find_kt + kt = kt - 1 +! compute q with piecewise constant method + if( kt.eq.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + th=(zi(k+1)-za(kb))/dza(kb) + tl2=tl*tl + th2=th*th + qqd=0.5*(qpi(kb)-qmi(kb)) + qqh=qqd*th2+qmi(kb)*th + qql=qqd*tl2+qmi(kb)*tl + qn(k) = (qqh-qql)/(th-tl) + else if( kt.gt.kb ) then + tl=(zi(k)-za(kb))/dza(kb) + tl2=tl*tl + qqd=0.5*(qpi(kb)-qmi(kb)) + qql=qqd*tl2+qmi(kb)*tl + dql = qa(kb)-qql + zsum = (1.-tl)*dza(kb) + qsum = dql*dza(kb) + if( kt-kb.gt.1 ) then + do m=kb+1,kt-1 + zsum = zsum + dza(m) + qsum = qsum + qa(m) * dza(m) + enddo + endif + th=(zi(k+1)-za(kt))/dza(kt) + th2=th*th + qqd=0.5*(qpi(kt)-qmi(kt)) + dqh=qqd*th2+qmi(kt)*th + zsum = zsum + th*dza(kt) + qsum = qsum + dqh*dza(kt) + qn(k) = qsum/zsum + endif + cycle intp + endif +! + enddo intp +! +! rain out + sum_precip: do k=1,km + if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then + precip(i) = precip(i) + qa(k)*dza(k) + cycle sum_precip + else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then + precip(i) = precip(i) + qa(k)*(0.0-za(k)) + exit sum_precip + endif + exit sum_precip + enddo sum_precip +! +! replace the new values + if(ist.eq.1) then + rql(i,:) = qn(:) + precip1(i) = precip(i) + else + rql2(i,:) = qn(:) + precip2(i) = precip(i) + endif + enddo ist_loop + + enddo i_loop + + end subroutine nislfv_rain_plm6 + +!================================================================================================================= + subroutine refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ,kts,kte) + implicit none +!================================================================================================================= + +!..Sub arguments + integer,intent(in):: kts,kte + real(kind=kind_phys),intent(in),dimension(kts:kte):: qv1d,qr1d,qs1d,qg1d,t1d,p1d + real(kind=kind_phys),intent(inout),dimension(kts:kte):: dBz + +!..Local variables + logical:: melti + logical,dimension(kts:kte):: l_qr,l_qs,l_qg + + INTEGER:: i,k,k_0,kbot,n + + real(kind=kind_phys),parameter:: R=287. + real(kind=kind_phys):: temp_c + real(kind=kind_phys),dimension(kts:kte):: temp,pres,qv,rho + real(kind=kind_phys),dimension(kts:kte):: rr,rs,rg + real(kind=kind_phys),dimension(kts:kte):: ze_rain,ze_snow,ze_graupel + + double precision:: fmelt_s,fmelt_g + double precision:: cback,x,eta,f_d + double precision,dimension(kts:kte):: ilamr,ilams,ilamg + double precision,dimension(kts:kte):: n0_r, n0_s, n0_g + double precision:: lamr,lams,lamg + +!----------------------------------------------------------------------------------------------------------------- + + do k = kts, kte + dBZ(k) = -35.0 + enddo + +!+---+-----------------------------------------------------------------+ +!..Put column of data into local arrays. +!+---+-----------------------------------------------------------------+ + do k = kts, kte + temp(k) = t1d(k) + temp_c = min(-0.001, temp(k)-273.15) + qv(k) = max(1.e-10, qv1d(k)) + pres(k) = p1d(k) + rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + + if (qr1d(k) .gt. 1.e-9) then + rr(k) = qr1d(k)*rho(k) + n0_r(k) = n0r + lamr = (xam_r*xcrg(3)*n0_r(k)/rr(k))**(1./xcre(1)) + ilamr(k) = 1./lamr + l_qr(k) = .true. + else + rr(k) = 1.e-12 + l_qr(k) = .false. + endif + + if (qs1d(k) .gt. 1.e-9) then + rs(k) = qs1d(k)*rho(k) + n0_s(k) = min(n0smax, n0s*exp(-alpha*temp_c)) + lams = (xam_s*xcsg(3)*n0_s(k)/rs(k))**(1./xcse(1)) + ilams(k) = 1./lams + l_qs(k) = .true. + else + rs(k) = 1.e-12 + l_qs(k) = .false. + endif + + if (qg1d(k) .gt. 1.e-9) then + rg(k) = qg1d(k)*rho(k) + n0_g(k) = n0g + lamg = (xam_g*xcgg(3)*n0_g(k)/rg(k))**(1./xcge(1)) + ilamg(k) = 1./lamg + l_qg(k) = .true. + else + rg(k) = 1.e-12 + l_qg(k) = .false. + endif + enddo + +!+---+-----------------------------------------------------------------+ +!..Locate K-level of start of melting (k_0 is level above). +!+---+-----------------------------------------------------------------+ + melti = .false. + k_0 = kts + do k = kte-1, kts, -1 + if ( (temp(k).gt.273.15) .and. L_qr(k) & + .and. (L_qs(k+1).or.L_qg(k+1)) ) then + k_0 = MAX(k+1, k_0) + melti=.true. + goto 195 + endif + enddo + 195 continue + +!+---+-----------------------------------------------------------------+ +!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) +!.. and non-water-coated snow and graupel when below freezing are +!.. simple. Integrations of m(D)*m(D)*N(D)*dD. +!+---+-----------------------------------------------------------------+ + + do k = kts, kte + ze_rain(k) = 1.e-22 + ze_snow(k) = 1.e-22 + ze_graupel(k) = 1.e-22 + if (l_qr(k)) ze_rain(k) = n0_r(k)*xcrg(4)*ilamr(k)**xcre(4) + if (l_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & + * (xam_s/900.0)*(xam_s/900.0) & + * n0_s(k)*xcsg(4)*ilams(k)**xcse(4) + if (l_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/pi)*(6.0/pi) & + * (xam_g/900.0)*(xam_g/900.0) & + * n0_g(k)*xcgg(4)*ilamg(k)**xcge(4) + enddo + + +!+---+-----------------------------------------------------------------+ +!..Special case of melting ice (snow/graupel) particles. Assume the +!.. ice is surrounded by the liquid water. Fraction of meltwater is +!.. extremely simple based on amount found above the melting level. +!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting +!.. routines). +!+---+-----------------------------------------------------------------+ + + if (melti .and. k_0.ge.kts+1) then + do k = k_0-1, kts, -1 + +!..Reflectivity contributed by melting snow + if (L_qs(k) .and. L_qs(k_0) ) then + fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) + eta = 0.d0 + lams = 1./ilams(k) + do n = 1, nrbins + x = xam_s * xxDs(n)**xbm_s + call rayleigh_soak_wetgraupel (x,dble(xocms),dble(xobms), & + fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & + cback, mixingrulestring_s, matrixstring_s, & + inclusionstring_s, hoststring_s, & + hostmatrixstring_s, hostinclusionstring_s) + f_d = n0_s(k)*xxds(n)**xmu_s * dexp(-lams*xxds(n)) + eta = eta + f_d * cback * simpson(n) * xdts(n) + enddo + ze_snow(k) = sngl(lamda4 / (pi5 * k_w) * eta) + endif + + +!..Reflectivity contributed by melting graupel + + if (l_qg(k) .and. l_qg(k_0) ) then + fmelt_g = max(0.005d0, min(1.0d0-rg(k)/rg(k_0), 0.99d0)) + eta = 0.d0 + lamg = 1./ilamg(k) + do n = 1, nrbins + x = xam_g * xxdg(n)**xbm_g + call rayleigh_soak_wetgraupel (x,dble(xocmg),dble(xobmg), & + fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & + cback, mixingrulestring_g, matrixstring_g, & + inclusionstring_g, hoststring_g, & + hostmatrixstring_g, hostinclusionstring_g) + f_d = n0_g(k)*xxdg(n)**xmu_g * dexp(-lamg*xxdg(n)) + eta = eta + f_d * cback * simpson(n) * xdtg(n) + enddo + ze_graupel(k) = sngl(lamda4 / (pi5 * k_w) * eta) + endif + + enddo + endif + + do k = kte, kts, -1 + dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) + enddo + + + end subroutine refl10cm_wsm6 + + +!================================================================================================================= + end module mp_wsm6 +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/mp_wsm6_effectRad.F b/src/core_atmosphere/physics/physics_mmm/mp_wsm6_effectRad.F new file mode 100644 index 0000000000..d54cf74b66 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/mp_wsm6_effectRad.F @@ -0,0 +1,188 @@ +!================================================================================================================= + module mp_wsm6_effectrad + use ccpp_kinds,only: kind_phys + + + use mp_wsm6,only: alpha,n0s,n0smax,pidn0s,pidnc + + + implicit none + private + public:: mp_wsm6_effectRad_run, & + mp_wsm6_effectrad_init, & + mp_wsm6_effectRad_final + + + contains + + +!================================================================================================================= + subroutine mp_wsm6_effectRad_init(errmsg,errflg) +!================================================================================================================= + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_effectRad_init OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_init + +!================================================================================================================= + subroutine mp_wsm6_effectRad_final(errmsg,errflg) +!================================================================================================================= + +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'mp_wsm6_effectRad_final OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_final + +!================================================================================================================= + subroutine mp_wsm6_effectRad_run(do_microp_re,t,qc,qi,qs,rho,qmin,t0c,re_qc_bg,re_qi_bg,re_qs_bg, & + re_qc_max,re_qi_max,re_qs_max,re_qc,re_qi,re_qs,its,ite,kts,kte, & + errmsg,errflg) +!================================================================================================================= +! Compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------------------------------------------------- + + +!..Sub arguments + logical,intent(in):: do_microp_re + integer,intent(in):: its,ite,kts,kte + real(kind=kind_phys),intent(in):: qmin + real(kind=kind_phys),intent(in):: t0c + real(kind=kind_phys),intent(in):: re_qc_bg,re_qi_bg,re_qs_bg + real(kind=kind_phys),intent(in):: re_qc_max,re_qi_max,re_qs_max + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: t + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: qc + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: qi + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: qs + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(in):: rho + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(inout):: re_qc + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(inout):: re_qi + real(kind=kind_phys),dimension(its:ite,kts:kte),intent(inout):: re_qs + +!...Output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!..Local variables + integer:: i,k + integer:: inu_c + real(kind=kind_phys),dimension(its:ite,kts:kte):: ni + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqc + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqi + real(kind=kind_phys),dimension(its:ite,kts:kte):: rni + real(kind=kind_phys),dimension(its:ite,kts:kte):: rqs + real(kind=kind_phys):: temp + real(kind=kind_phys):: lamdac + real(kind=kind_phys):: supcol,n0sfac,lamdas + real(kind=kind_phys):: diai ! diameter of ice in m + logical:: has_qc, has_qi, has_qs +!..Minimum microphys values + real(kind=kind_phys),parameter:: R1 = 1.E-12 + real(kind=kind_phys),parameter:: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real(kind=kind_phys),parameter:: bm_r = 3.0 + real(kind=kind_phys),parameter:: obmr = 1.0/bm_r + real(kind=kind_phys),parameter:: nc0 = 3.E8 + +!----------------------------------------------------------------------------------------------------------------- + + if(.not. do_microp_re) return + +!--- initialization of effective radii of cloud water, cloud ice, and snow to background values: + do k = kts,kte + do i = its,ite + re_qc(i,k) = re_qc_bg + re_qi(i,k) = re_qi_bg + re_qs(i,k) = re_qs_bg + enddo + enddo + +!--- computation of effective radii: + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts,kte + do i = its,ite + ! for cloud + rqc(i,k) = max(R1,qc(i,k)*rho(i,k)) + if (rqc(i,k).gt.R1) has_qc = .true. + ! for ice + rqi(i,k) = max(R1,qi(i,k)*rho(i,k)) + temp = (rho(i,k)*max(qi(i,k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(i,k)= max(R2,ni(i,k)*rho(i,k)) + if (rqi(i,k).gt.R1 .and. rni(i,k).gt.R2) has_qi = .true. + ! for snow + rqs(i,k) = max(R1,qs(i,k)*rho(i,k)) + if (rqs(i,k).gt.R1) has_qs = .true. + enddo + enddo + + if (has_qc) then + do k = kts,kte + do i = its,ite + if (rqc(i,k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(i,k))**obmr + re_qc(i,k) = max(2.51E-6,min(1.5*(1.0/lamdac),re_qc_max)) + enddo + enddo + endif + + if (has_qi) then + do k = kts,kte + do i = its,ite + if (rqi(i,k).le.R1 .or. rni(i,k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(i,k)/ni(i,k)) + re_qi(i,k) = max(10.01E-6,min(0.75*0.163*diai,re_qi_max)) + enddo + enddo + endif + + if (has_qs) then + do i = its,ite + do k = kts,kte + if (rqs(i,k).le.R1) CYCLE + supcol = t0c-t(i,k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(i,k))) + re_qs(i,k) = max(25.E-6,min(0.5*(1./lamdas),re_qs_max)) + enddo + enddo + endif + +!--- limit effective radii of cloud water, cloud ice, and snow to maximum values: + do k = kts,kte + do i = its,ite + re_qc(i,k) = max(re_qc_bg,min(re_qc(i,k),re_qc_max)) + re_qi(i,k) = max(re_qi_bg,min(re_qi(i,k),re_qi_max)) + re_qs(i,k) = max(re_qs_bg,min(re_qs(i,k),re_qs_max)) + enddo + enddo + + errmsg = 'mp_wsm6_effectRad_run OK' + errflg = 0 + + end subroutine mp_wsm6_effectRad_run + +!================================================================================================================= + end module mp_wsm6_effectrad +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F b/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F new file mode 100644 index 0000000000..0fa2b5f446 --- /dev/null +++ b/src/core_atmosphere/physics/physics_mmm/sf_sfclayrev.F @@ -0,0 +1,1162 @@ +!================================================================================================================= + module sf_sfclayrev + use mpas_log + use ccpp_kinds,only: kind_phys + + implicit none + private + public:: sf_sfclayrev_run, & + sf_sfclayrev_init, & + sf_sfclayrev_final, & + sf_sfclayrev_timestep_init, & + sf_sfclayrev_timestep_final + + + real(kind=kind_phys),parameter:: vconvc= 1. + real(kind=kind_phys),parameter:: czo = 0.0185 + real(kind=kind_phys),parameter:: ozo = 1.59e-5 + + real(kind=kind_phys),dimension(0:1000 ),save:: psim_stab,psim_unstab,psih_stab,psih_unstab + + + contains + + +!================================================================================================================= + subroutine sf_sfclayrev_timestep_init(dz2d,u2d,v2d,qv2d,p2d,t2d,dz1d,u1d,v1d,qv1d,p1d,t1d, & + its,ite,kts,kte,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + dz2d,u2d,v2d,qv2d,p2d,t2d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + dz1d,u1d,v1d,qv1d,p1d,t1d + +!--- local variables: + integer:: i + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite + dz1d(i) = dz2d(i,kts) + u1d(i) = u2d(i,kts) + v1d(i) = v2d(i,kts) + qv1d(i) = qv2d(i,kts) + p1d(i) = p2d(i,kts) + t1d(i) = t2d(i,kts) + enddo + + errmsg = 'sf_sfclayrev_timestep_init OK' + errflg = 0 + + end subroutine sf_sfclayrev_timestep_init + +!================================================================================================================= + subroutine sf_sfclayrev_timestep_final(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'sf_sfclayrev_timestep_final OK' + errflg = 0 + + end subroutine sf_sfclayrev_timestep_final + +!================================================================================================================= + subroutine sf_sfclayrev_init(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!local variables: + integer:: n + real(kind=kind_phys):: zolf + +!----------------------------------------------------------------------------------------------------------------- + + do n = 0,1000 +! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + +! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) + enddo + + errmsg = 'sf_sfclayrev_init OK' + errflg = 0 + + end subroutine sf_sfclayrev_init + +!================================================================================================================= + subroutine sf_sfclayrev_final(errmsg,errflg) +!================================================================================================================= + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = 'sf_sfclayrev_final OK' + errflg = 0 + + end subroutine sf_sfclayrev_final + +!================================================================================================================= + subroutine sf_sfclayrev_run(ux,vx,t1d,qv1d,p1d,dz8w1d, & + cp,g,rovcp,r,xlv,psfcpa,chs,chs2,cqs2, & + cpm,pblh,rmol,znt,ust,mavail,zol,mol, & + regime,psim,psih,fm,fh, & + xland,hfx,qfx,tsk, & + u10,v10,th2,t2,q2,flhc,flqc,qgh, & + qsfc,lh,gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,eomeg,stbolt,p1000mb, & + shalwater_z0,water_depth,shalwater_depth, & + isftcflx,iz0tlnd,scm_force_flux, & + ustm,ck,cka,cd,cda, & + its,ite,errmsg,errflg & + ) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite + + integer,intent(in):: isfflx + integer,intent(in):: shalwater_z0 + integer,intent(in),optional:: isftcflx, iz0tlnd + integer,intent(in),optional:: scm_force_flux + + real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 + real(kind=kind_phys),intent(in):: ep1,ep2,karman,eomeg,stbolt + real(kind=kind_phys),intent(in):: P1000mb + real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv + real(kind=kind_phys),intent(in):: shalwater_depth + + real(kind=kind_phys),intent(in),dimension(its:ite):: & + mavail, & + pblh, & + psfcpa, & + tsk, & + xland, & + water_depth + + real(kind=kind_phys),intent(in),dimension(its:ite):: & + dx, & + dz8w1d, & + ux, & + vx, & + qv1d, & + p1d, & + t1d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + lh, & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(its:ite),optional:: & + ck, & + cka, & + cd, & + cda + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite):: & + regime, & + hfx, & + qfx, & + qsfc, & + mol, & + rmol, & + gz1oz0, & + wspd, & + br, & + psim, & + psih, & + fm, & + fh, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + flhc, & + flqc, & + qgh + + real(kind=kind_phys),intent(inout),dimension(its:ite),optional:: & + ustm + +!--- local variables: + integer:: n,i,k,kk,l,nzol,nk,nzol2,nzol10 + + real(kind=kind_phys),parameter:: xka = 2.4e-5 + real(kind=kind_phys),parameter:: prt = 1. + + real(kind=kind_phys):: pl,thcon,tvcon,e1 + real(kind=kind_phys):: zl,tskv,dthvdz,dthvm,vconv,rzol,rzol2,rzol10,zol2,zol10 + real(kind=kind_phys):: dtg,psix,dtthx,psix10,psit,psit2,psiq,psiq2,psiq10 + real(kind=kind_phys):: fluxc,vsgd,z0q,visc,restar,czil,gz0ozq,gz0ozt + real(kind=kind_phys):: zw,zn1,zn2 + real(kind=kind_phys):: zolzz,zol0 + real(kind=kind_phys):: zl2,zl10,z0t + + real(kind=kind_phys),dimension(its:ite):: & + za, & + thvx, & + zqkl, & + zqklp1, & + thx, & + qx, & + psih2, & + psim2, & + psih10, & + psim10, & + denomq, & + denomq2, & + denomt2, & + wspdi, & + gz2oz0, & + gz10oz0, & + rhox, & + govrth, & + tgdsa, & + scr3, & + scr4, & + thgb, & + psfc + + real(kind=kind_phys),dimension(its:ite):: & + pq, & + pq2, & + pq10 + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite +!PSFC cb + psfc(i)=psfcpa(i)/1000. + enddo +! +!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE: +! + do 5 i = its,ite + tgdsa(i)=tsk(i) +!PSFC cb +! thgb(i)=tsk(i)*(100./psfc(i))**rovcp + thgb(i)=tsk(i)*(p1000mb/psfcpa(i))**rovcp + 5 continue +! +!-----DECOUPLE FLUX-FORM VARIABLES TO GIVE U,V,T,THETA,THETA-VIR., +! T-VIR., QV, AND QC AT CROSS POINTS AND AT KTAU-1. +! +! *** NOTE *** +! THE BOUNDARY WINDS MAY NOT BE ADEQUATELY AFFECTED BY FRICTION, +! SO USE ONLY INTERIOR VALUES OF UX AND VX TO CALCULATE +! TENDENCIES. +! + 10 continue + +!do 24 i = its,ite +! ux(i)=u1d(i) +! vx(i)=v1d(i) +!24 continue + + 26 continue + +!.....SCR3(I,K) STORE TEMPERATURE, +! SCR4(I,K) STORE VIRTUAL TEMPERATURE. + + do 30 i = its,ite +!PL cb + pl=p1d(i)/1000. + scr3(i)=t1d(i) +! thcon=(100./pl)**rovcp + thcon=(p1000mb*0.001/pl)**rovcp + thx(i)=scr3(i)*thcon + scr4(i)=scr3(i) + thvx(i)=thx(i) + qx(i)=0. + 30 continue +! + do i = its,ite + qgh(i)=0. + flhc(i)=0. + flqc(i)=0. + cpm(i)=cp + enddo +! +!if(idry.eq.1)goto 80 + do 50 i = its,ite + qx(i)=qv1d(i) + tvcon=(1.+ep1*qx(i)) + thvx(i)=thx(i)*tvcon + scr4(i)=scr3(i)*tvcon + 50 continue +! + do 60 i=its,ite + e1=svp1*exp(svp2*(tgdsa(i)-svpt0)/(tgdsa(i)-svp3)) + !for land points qsfc can come from previous time step + if(xland(i).gt.1.5.or.qsfc(i).le.0.0)qsfc(i)=ep2*e1/(psfc(i)-e1) +!QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE +!Q2SAT = QGH IN LSM + e1=svp1*exp(svp2*(t1d(i)-svpt0)/(t1d(i)-svp3)) + pl=p1d(i)/1000. + qgh(i)=ep2*e1/(pl-e1) + cpm(i)=cp*(1.+0.8*qx(i)) + 60 continue + 80 continue + +!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND +! LEVEL, AND THE LAYER THICKNESSES. + + do 90 i = its,ite + zqklp1(i)=0. + rhox(i)=psfc(i)*1000./(r*scr4(i)) + 90 continue +! + do 110 i = its,ite + zqkl(i)=dz8w1d(i)+zqklp1(i) + 110 continue +! + do 120 i = its,ite + za(i)=0.5*(zqkl(i)+zqklp1(i)) + 120 continue +! + do 160 i=its,ite + govrth(i)=g/thx(i) + 160 continue + +!-----CALCULATE BULK RICHARDSON NO. OF SURFACE LAYER, ACCORDING TO +! AKB(1976), EQ(12). + do 260 i = its,ite + gz1oz0(i)=alog((za(i)+znt(i))/znt(i)) ! log((z+z0)/z0) + gz2oz0(i)=alog((2.+znt(i))/znt(i)) ! log((2+z0)/z0) + gz10oz0(i)=alog((10.+znt(i))/znt(i)) ! log((10+z0)z0) + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif + wspd(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) + + tskv=thgb(i)*(1.+ep1*qsfc(i)) + dthvdz=(thvx(i)-tskv) +!-----CONVECTIVE VELOCITY SCALE VC AND SUBGRID-SCALE VELOCITY VSG +! FOLLOWING BELJAARS (1994, QJRMS) AND MAHRT AND SUN (1995, MWR) +! ... HONG AUG. 2001 +! +! vconv = 0.25*sqrt(g/tskv*pblh(i)*dthvm) +! USE BELJAARS OVER LAND, OLD MM5 (WYNGAARD) FORMULA OVER WATER + if(xland(i).lt.1.5) then + fluxc = max(hfx(i)/rhox(i)/cp & + + ep1*tskv*qfx(i)/rhox(i),0.) + vconv = vconvc*(g/tgdsa(i)*pblh(i)*fluxc)**.33 + else + if(-dthvdz.ge.0)then + dthvm=-dthvdz + else + dthvm=0. + endif +! vconv = 2.*sqrt(dthvm) +! V3.7: REDUCING CONTRIBUTION IN CALM CONDITIONS + vconv = sqrt(dthvm) + endif +! MAHRT AND SUN LOW-RES CORRECTION + vsgd = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 + wspd(i)=sqrt(wspd(i)*wspd(i)+vconv*vconv+vsgd*vsgd) + wspd(i)=amax1(wspd(i),0.1) + br(i)=govrth(i)*za(i)*dthvdz/(wspd(i)*wspd(i)) +!-----IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 + if(mol(i).lt.0.)br(i)=amin1(br(i),0.0) + rmol(i)=-govrth(i)*dthvdz*za(i)*karman + 260 continue + +! +!-----DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATED STABILITY CLASS: +! +! +! THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.) +! AND HOL (HEIGHT OF PBL/MONIN-OBUKHOV LENGTH). +! +! CRITERIA FOR THE CLASSES ARE AS FOLLOWS: +! +! 1. BR .GE. 0.0; +! REPRESENTS NIGHTTIME STABLE CONDITIONS (REGIME=1), +! +! 3. BR .EQ. 0.0 +! REPRESENTS FORCED CONVECTION CONDITIONS (REGIME=3), +! +! 4. BR .LT. 0.0 +! REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4). +! + + do 320 i = its,ite +! + if(br(i).gt.0) then + if(br(i).gt.250.0) then + zol(i)=zolri(250.0,za(i),znt(i)) + else + zol(i)=zolri(br(i),za(i),znt(i)) + endif + endif +! + if(br(i).lt.0) then + if(ust(i).lt.0.001)then + zol(i)=br(i)*gz1oz0(i) + else + if(br(i).lt.-250.0) then + zol(i)=zolri(-250.0,za(i),znt(i)) + else + zol(i)=zolri(br(i),za(i),znt(i)) + endif + endif + endif +! +! ... paj: compute integrated similarity functions. +! + zolzz=zol(i)*(za(i)+znt(i))/za(i) ! (z+z0/L + zol10=zol(i)*(10.+znt(i))/za(i) ! (10+z0)/L + zol2=zol(i)*(2.+znt(i))/za(i) ! (2+z0)/L + zol0=zol(i)*znt(i)/za(i) ! z0/L + zl2=(2.)/za(i)*zol(i) ! 2/L + zl10=(10.)/za(i)*zol(i) ! 10/L + + if((xland(i)-1.5).lt.0.)then + zl=(0.01)/za(i)*zol(i) ! (0.01)/L + else + zl=zol0 ! z0/L + endif + + if(br(i).lt.0.)goto 310 ! go to unstable regime (class 4) + if(br(i).eq.0.)goto 280 ! go to neutral regime (class 3) +! +!-----CLASS 1; STABLE (NIGHTTIME) CONDITIONS: +! + regime(i)=1. +! +! ... paj: psim and psih. follows cheng and brutsaert 2005 (cb05). +! + psim(i)=psim_stable(zolzz)-psim_stable(zol0) + psih(i)=psih_stable(zolzz)-psih_stable(zol0) +! + psim10(i)=psim_stable(zol10)-psim_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) +! + psim2(i)=psim_stable(zol2)-psim_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) +! +! ... paj: preparations to compute psiq. follows cb05+carlson boland jam 1978. +! + pq(i)=psih_stable(zol(i))-psih_stable(zl) + pq2(i)=psih_stable(zl2)-psih_stable(zl) + pq10(i)=psih_stable(zl10)-psih_stable(zl) +! +! 1.0 over monin-obukhov length + rmol(i)=zol(i)/za(i) +! + goto 320 +! +!-----CLASS 3; FORCED CONVECTION: +! + 280 regime(i)=3. + psim(i)=0.0 + psih(i)=psim(i) + psim10(i)=0. + psih10(i)=psim10(i) + psim2(i)=0. + psih2(i)=psim2(i) +! +! paj: preparations to compute PSIQ. +! + pq(i)=psih(i) + pq2(i)=psih2(i) + pq10(i)=0. +! + zol(i)=0. + rmol(i) = zol(i)/za(i) + + goto 320 +! +!-----CLASS 4; FREE CONVECTION: +! + 310 continue + regime(i)=4. +! +! ... paj: PSIM and PSIH ... +! + psim(i)=psim_unstable(zolzz)-psim_unstable(zol0) + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) +! + psim10(i)=psim_unstable(zol10)-psim_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) +! + psim2(i)=psim_unstable(zol2)-psim_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) +! +! ... paj: preparations to compute PSIQ +! + pq(i)=psih_unstable(zol(i))-psih_unstable(zl) + pq2(i)=psih_unstable(zl2)-psih_unstable(zl) + pq10(i)=psih_unstable(zl10)-psih_unstable(zl) +! +!-----LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND HIGH ROUGHNESS +!-----THIS PREVENTS DENOMINATOR IN FLUXES FROM GETTING TOO SMALL + psih(i)=amin1(psih(i),0.9*gz1oz0(i)) + psim(i)=amin1(psim(i),0.9*gz1oz0(i)) + psih2(i)=amin1(psih2(i),0.9*gz2oz0(i)) + psim10(i)=amin1(psim10(i),0.9*gz10oz0(i)) +! +! AHW: mods to compute ck, cd + psih10(i)=amin1(psih10(i),0.9*gz10oz0(i)) + rmol(i) = zol(i)/za(i) + + 320 continue +! +!-----COMPUTE THE FRICTIONAL VELOCITY: +! ZA(1982) EQS(2.60),(2.61). +! + do 330 i = its,ite + dtg=thx(i)-thgb(i) + psix=gz1oz0(i)-psim(i) + psix10=gz10oz0(i)-psim10(i) + +! LOWER LIMIT ADDED TO PREVENT LARGE FLHC IN SOIL MODEL +! ACTIVATES IN UNSTABLE CONDITIONS WITH THIN LAYERS OR HIGH Z0 +! PSIT=AMAX1(GZ1OZ0(I)-PSIH(I),2.) + psit=gz1oz0(i)-psih(i) + psit2=gz2oz0(i)-psih2(i) +! + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif +! + psiq=alog(karman*ust(i)*za(i)/xka+za(i)/zl)-pq(i) + psiq2=alog(karman*ust(i)*2./xka+2./zl)-pq2(i) + +! AHW: mods to compute ck, cd + psiq10=alog(karman*ust(i)*10./xka+10./zl)-pq10(i) + +! v3.7: using fairall 2003 to compute z0q and z0t over water: +! adapted from module_sf_mynn.f + if((xland(i)-1.5).ge.0.) then + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 + restar=ust(i)*znt(i)/visc + z0t = (5.5e-5)*(restar**(-0.60)) + z0t = min(z0t,1.0e-4) + z0t = max(z0t,2.0e-9) + z0q = z0t + +! following paj: + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif + psit=alog((za(i)+z0t)/z0t)-psih(i) + psit2=alog((2.+z0t)/z0t)-psih2(i) + + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) + endif + + if(present(isftcflx)) then + if(isftcflx.eq.1 .and. (xland(i)-1.5).ge.0.) then +! v3.1 +! z0q = 1.e-4 + 1.e-3*(max(0.,ust(i)-1.))**2 +! hfip1 +! z0q = 0.62*2.0e-5/ust(i) + 1.e-3*(max(0.,ust(i)-1.5))**2 +! v3.2 + z0q = 1.e-4 +! +! ... paj: recompute psih for z0q +! + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psit=psiq + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) + psit2=psiq2 + endif + if(isftcflx.eq.2 .and. (xland(i)-1.5).ge.0.) then +! AHW: Garratt formula: Calculate roughness Reynolds number +! Kinematic viscosity of air (linear approc to +! temp dependence at sea level) +! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which +! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60 + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 +! visc=1.5e-5 + restar=ust(i)*znt(i)/visc + gz0ozt=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.71)-5.) +! +! ... paj: compute psih for z0t for temperature ... +! + z0t=znt(i)/exp(gz0ozt) +! + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! +! psit=gz1oz0(i)-psih(i)+restar2 +! psit2=gz2oz0(i)-psih2(i)+restar2 + psit=alog((za(i)+z0t)/z0t)-psih(i) + psit2=alog((2.+z0t)/z0t)-psih2(i) +! + gz0ozq=0.40*(7.3*sqrt(sqrt(restar))*sqrt(0.60)-5.) + z0q=znt(i)/exp(gz0ozq) +! + zolzz=zol(i)*(za(i)+z0q)/za(i) ! (z+z0q)/L + zol10=zol(i)*(10.+z0q)/za(i) ! (10+z0q)/L + zol2=zol(i)*(2.+z0q)/za(i) ! (2+z0q)/L + zol0=zol(i)*z0q/za(i) ! z0q/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0q)/z0q)-psih(i) + psiq2=alog((2.+z0q)/z0q)-psih2(i) + psiq10=alog((10.+z0q)/z0q)-psih10(i) +! psiq=gz1oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. +! psiq2=gz2oz0(i)-psih2(i)+2.28*sqrt(sqrt(restar))-2. +! psiq10=gz10oz0(i)-psih(i)+2.28*sqrt(sqrt(restar))-2. + endif + endif + if(present(ck) .and. present(cd) .and. present(cka) .and. present(cda)) then + ck(i)=(karman/psix10)*(karman/psiq10) + cd(i)=(karman/psix10)*(karman/psix10) + cka(i)=(karman/psix)*(karman/psiq) + cda(i)=(karman/psix)*(karman/psix) + endif + if(present(iz0tlnd)) then + if(iz0tlnd.ge.1 .and. (xland(i)-1.5).le.0.) then + zl=znt(i) +! CZIL RELATED CHANGES FOR LAND + visc=(1.32+0.009*(scr3(i)-273.15))*1.e-5 + restar=ust(i)*zl/visc +! Modify CZIL according to Chen & Zhang, 2009 if iz0tlnd = 1 +! If iz0tlnd = 2, use traditional value + + if(iz0tlnd.eq.1) then + czil = 10.0 ** ( -0.40 * ( zl / 0.07 ) ) + elseif(iz0tlnd.eq.2) then + czil = 0.1 + endif +! +! ... paj: compute phish for z0t over land +! + z0t=znt(i)/exp(czil*karman*sqrt(restar)) +! + zolzz=zol(i)*(za(i)+z0t)/za(i) ! (z+z0t)/L + zol10=zol(i)*(10.+z0t)/za(i) ! (10+z0t)/L + zol2=zol(i)*(2.+z0t)/za(i) ! (2+z0t)/L + zol0=zol(i)*z0t/za(i) ! z0t/L +! + if(zol(i).gt.0.) then + psih(i)=psih_stable(zolzz)-psih_stable(zol0) + psih10(i)=psih_stable(zol10)-psih_stable(zol0) + psih2(i)=psih_stable(zol2)-psih_stable(zol0) + else + if(zol(i).eq.0) then + psih(i)=0. + psih10(i)=0. + psih2(i)=0. + else + psih(i)=psih_unstable(zolzz)-psih_unstable(zol0) + psih10(i)=psih_unstable(zol10)-psih_unstable(zol0) + psih2(i)=psih_unstable(zol2)-psih_unstable(zol0) + endif + endif +! + psiq=alog((za(i)+z0t)/z0t)-psih(i) + psiq2=alog((2.+z0t)/z0t)-psih2(i) + psit=psiq + psit2=psiq2 +! +! psit=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) +! psiq=gz1oz0(i)-psih(i)+czil*karman*sqrt(restar) +! psit2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) +! psiq2=gz2oz0(i)-psih2(i)+czil*karman*sqrt(restar) + endif + endif +! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE + ust(i)=0.5*ust(i)+0.5*karman*wspd(i)/psix +! TKE coupling: compute ust without vconv for use in tke scheme + wspdi(i)=sqrt(ux(i)*ux(i)+vx(i)*vx(i)) + if(present(ustm)) then + ustm(i)=0.5*ustm(i)+0.5*karman*wspdi(i)/psix + endif + + u10(i)=ux(i)*psix10/psix + v10(i)=vx(i)*psix10/psix + th2(i)=thgb(i)+dtg*psit2/psit + q2(i)=qsfc(i)+(qx(i)-qsfc(i))*psiq2/psiq + t2(i) = th2(i)*(psfcpa(i)/p1000mb)**rovcp +! + if((xland(i)-1.5).lt.0.)then + ust(i)=amax1(ust(i),0.001) + endif + mol(i)=karman*dtg/psit/prt + denomq(i)=psiq + denomq2(i)=psiq2 + denomt2(i)=psit2 + fm(i)=psix + fh(i)=psit + 330 continue +! + 335 continue + +!-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES: + if(present(scm_force_flux) ) then + if(scm_force_flux.eq.1) goto 350 + endif + do i = its,ite + qfx(i)=0. + hfx(i)=0. + enddo + 350 continue + + if(isfflx.eq.0) goto 410 + +!-----OVER WATER, ALTER ROUGHNESS LENGTH (ZNT) ACCORDING TO WIND (UST). + do 360 i = its,ite + if((xland(i)-1.5).ge.0)then +! znt(i)=czo*ust(i)*ust(i)/g+ozo + ! PSH - formulation for depth-dependent roughness from + ! ... Jimenez and Dudhia, 2018 + if(shalwater_z0 .eq. 1) then + znt(i) = depth_dependent_z0(water_depth(i),znt(i),ust(i)) + else + !Since V3.7 (ref: EC Physics document for Cy36r1) + znt(i)=czo*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) + ! v3.9: add limit as in isftcflx = 1,2 + znt(i)=min(znt(i),2.85e-3) + endif +! COARE 3.5 (Edson et al. 2013) +! czc = 0.0017*wspd(i)-0.005 +! czc = min(czc,0.028) +! znt(i)=czc*ust(i)*ust(i)/g+0.11*1.5e-5/ust(i) +! AHW: change roughness length, and hence the drag coefficients Ck and Cd + if(present(isftcflx)) then + if(isftcflx.ne.0) then +! znt(i)=10.*exp(-9.*ust(i)**(-.3333)) +! znt(i)=10.*exp(-9.5*ust(i)**(-.3333)) +! znt(i)=znt(i) + 0.11*1.5e-5/amax1(ust(i),0.01) +! znt(i)=0.011*ust(i)*ust(i)/g+ozo +! znt(i)=max(znt(i),3.50e-5) +! AHW 2012: + zw = min((ust(i)/1.06)**(0.3),1.0) + zn1 = 0.011*ust(i)*ust(i)/g + ozo + zn2 = 10.*exp(-9.5*ust(i)**(-.3333)) + & + 0.11*1.5e-5/amax1(ust(i),0.01) + znt(i)=(1.0-zw) * zn1 + zw * zn2 + znt(i)=min(znt(i),2.85e-3) + znt(i)=max(znt(i),1.27e-7) + endif + endif + zl = znt(i) + else + zl = 0.01 + endif + flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/denomq(i) +! flqc(i)=rhox(i)*mavail(i)*ust(i)*karman/( & +! alog(karman*ust(i)*za(i)/xka+za(i)/zl)-psih(i)) + dtthx=abs(thx(i)-thgb(i)) + if(dtthx.gt.1.e-5)then + flhc(i)=cpm(i)*rhox(i)*ust(i)*mol(i)/(thx(i)-thgb(i)) +! write(*,1001)flhc(i),cpm(i),rhox(i),ust(i),mol(i),thx(i),thgb(i),i + 1001 format(f8.5,2x,f12.7,2x,f12.10,2x,f12.10,2x,f13.10,2x,f12.8,f12.8,2x,i3) + else + flhc(i)=0. + endif + 360 continue + +! +!-----COMPUTE SURFACE MOIST FLUX: +! +!IF(IDRY.EQ.1)GOTO 390 +! + if(present(scm_force_flux)) then + if(scm_force_flux.eq.1) goto 405 + endif + + do 370 i = its,ite + qfx(i)=flqc(i)*(qsfc(i)-qx(i)) + qfx(i)=amax1(qfx(i),0.) + lh(i)=xlv*qfx(i) + 370 continue + +!-----COMPUTE SURFACE HEAT FLUX: +! + 390 continue + do 400 i = its,ite + if(xland(i)-1.5.gt.0.)then + hfx(i)=flhc(i)*(thgb(i)-thx(i)) +! if(present(isftcflx)) then +! if(isftcflx.ne.0) then +! AHW: add dissipative heating term (commented out in 3.6.1) +! hfx(i)=hfx(i)+rhox(i)*ustm(i)*ustm(i)*wspdi(i) +! endif +! endif + elseif(xland(i)-1.5.lt.0.)then + hfx(i)=flhc(i)*(thgb(i)-thx(i)) + hfx(i)=amax1(hfx(i),-250.) + endif + 400 continue + + 405 continue + + do i = its,ite + if((xland(i)-1.5).ge.0)then + zl=znt(i) + else + zl=0.01 + endif +!v3.1.1 +! chs(i)=ust(i)*karman/(alog(karman*ust(i)*za(i) & +! /xka+za(i)/zl)-psih(i)) + chs(i)=ust(i)*karman/denomq(i) +! gz2oz0(i)=alog(2./znt(i)) +! psim2(i)=-10.*gz2oz0(i) +! psim2(i)=amax1(psim2(i),-10.) +! psih2(i)=psim2(i) +! v3.1.1 +! cqs2(i)=ust(i)*karman/(alog(karman*ust(i)*2.0 & +! /xka+2.0/zl)-psih2(i)) +! chs2(i)=ust(i)*karman/(gz2oz0(i)-psih2(i)) + cqs2(i)=ust(i)*karman/denomq2(i) + chs2(i)=ust(i)*karman/denomt2(i) + enddo + + 410 continue + +!jdf +! do i = its,ite +! if(ust(i).ge.0.1) then +! rmol(i)=rmol(i)*(-flhc(i))/(ust(i)*ust(i)*ust(i)) +! else +! rmol(i)=rmol(i)*(-flhc(i))/(0.1*0.1*0.1) +! endif +! enddo +!jdf + + errmsg = 'sf_sfclayrev_run OK' + errflg = 0 + + end subroutine sf_sfclayrev_run + +!================================================================================================================= + real(kind=kind_phys) function zolri(ri,z,z0) + real(kind=kind_phys),intent(in):: ri,z,z0 + + integer:: iter + real(kind=kind_phys):: fx1,fx2,x1,x2 + + + if(ri.lt.0.)then + x1=-5. + x2=0. + else + x1=0. + x2=5. + endif + + fx1=zolri2(x1,ri,z,z0) + fx2=zolri2(x2,ri,z,z0) + iter = 0 + do while (abs(x1 - x2) > 0.01) + if (iter .eq. 10) return +!check added for potential divide by zero (2019/11) + if(fx1.eq.fx2)return + if(abs(fx2).lt.abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,z,z0) + zolri=x1 + else + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,z,z0) + zolri=x2 + endif + iter = iter + 1 + enddo + + return + end function zolri + +!================================================================================================================= + real(kind=kind_phys) function zolri2(zol2,ri2,z,z0) + real(kind=kind_phys),intent(in):: ri2,z,z0 + real(kind=kind_phys),intent(inout):: zol2 + real(kind=kind_phys):: psih2,psix2,zol20,zol3 + + if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 + + zol20=zol2*z0/z ! z0/L + zol3=zol2+zol20 ! (z+z0)/L + + if(ri2.lt.0) then + psix2=log((z+z0)/z0)-(psim_unstable(zol3)-psim_unstable(zol20)) + psih2=log((z+z0)/z0)-(psih_unstable(zol3)-psih_unstable(zol20)) + else + psix2=log((z+z0)/z0)-(psim_stable(zol3)-psim_stable(zol20)) + psih2=log((z+z0)/z0)-(psih_stable(zol3)-psih_stable(zol20)) + endif + + zolri2=zol2*psih2/psix2**2-ri2 + + return + end function zolri2 + +!================================================================================================================= +! +! ... integrated similarity functions ... +! + real(kind=kind_phys) function psim_stable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + + return + end function psim_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_stable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + + return + end function psih_stable_full + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: psimc,psimk,x,y,ym + x=(1.-16.*zolf)**.25 + psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) + + ym=(1.-10.*zolf)**0.33 + psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) + + return + end function psim_unstable_full + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable_full(zolf) + real(kind=kind_phys),intent(in):: zolf + real(kind=kind_phys):: psihc,psihk,y,yh + y=(1.-16.*zolf)**.5 + psihk=2.*log((1+y)/2.) + + yh=(1.-34.*zolf)**0.33 + psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) + + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) + + return + end function psih_unstable_full + +!================================================================================================================= +! ... look-up table functions ... + real(kind=kind_phys) function psim_stable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + psim_stable = psim_stable_full(zolf) + endif + + return + end function psim_stable + +!================================================================================================================= + real(kind=kind_phys) function psih_stable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + psih_stable = psih_stable_full(zolf) + endif + + return + end function psih_stable + +!================================================================================================================= + real(kind=kind_phys) function psim_unstable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + psim_unstable = psim_unstable_full(zolf) + endif + + return + end function psim_unstable + +!================================================================================================================= + real(kind=kind_phys) function psih_unstable(zolf) + real(kind=kind_phys),intent(in):: zolf + integer:: nzol + real(kind=kind_phys):: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .lt. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + psih_unstable = psih_unstable_full(zolf) + endif + + return + end function psih_unstable + +!================================================================================================================= + real(kind=kind_phys) function depth_dependent_z0(water_depth,z0,ust) + real(kind=kind_phys),intent(in):: water_depth,z0,ust + real(kind=kind_phys):: depth_b + real(kind=kind_phys):: effective_depth + if(water_depth .lt. 10.0) then + effective_depth = 10.0 + elseif(water_depth .gt. 100.0) then + effective_depth = 100.0 + else + effective_depth = water_depth + endif + + depth_b = 1 / 30.0 * log (1260.0 / effective_depth) + depth_dependent_z0 = exp((2.7 * ust - 1.8 / depth_b) / (ust + 0.17 / depth_b) ) + depth_dependent_z0 = MIN(depth_dependent_z0,0.1) + + return + end function depth_dependent_z0 + +!================================================================================================================= + end module sf_sfclayrev +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index b470771cc2..b8a99b0a33 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -7,6 +7,7 @@ dummy: OBJS = \ libmassv.o \ + module_bep_bem_helper.o \ module_bl_gwdo.o \ module_bl_mynn.o \ module_bl_ysu.o \ @@ -18,7 +19,6 @@ OBJS = \ module_cu_ntiedtke.o \ module_cu_kfeta.o \ module_mp_kessler.o \ - module_mp_radar.o \ module_mp_thompson.o \ module_mp_thompson_cldfra3.o \ module_mp_wsm6.o \ @@ -39,6 +39,7 @@ OBJS = \ module_sf_noah_seaice_drv.o \ module_sf_oml.o \ module_sf_sfclay.o \ + module_sf_sfclayrev.o \ module_sf_urban.o physics_wrf: $(OBJS) @@ -51,12 +52,6 @@ module_bl_mynn.o: \ module_cam_support.o: \ module_cam_shr_kind_mod.o -module_mp_thompson.o: \ - module_mp_radar.o - -module_mp_wsm6.o: \ - module_mp_radar.o - module_ra_cam.o: \ module_cam_support.o \ module_ra_cam_support.o @@ -69,9 +64,11 @@ module_ra_rrtmg_sw.o: \ module_ra_rrtmg_vinterp.o module_sf_bep.o: \ + module_bep_bem_helper.o \ module_sf_urban.o module_sf_bep_bem.o: \ + module_bep_bem_helper.o \ module_sf_bem.o \ module_sf_urban.o @@ -105,7 +102,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework -I../../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework -I../../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/physics_wrf/libmassv.F b/src/core_atmosphere/physics/physics_wrf/libmassv.F index 9037850dfc..d1477c35c6 100644 --- a/src/core_atmosphere/physics/physics_wrf/libmassv.F +++ b/src/core_atmosphere/physics/physics_wrf/libmassv.F @@ -1,9 +1,13 @@ ! IBM libmassv compatibility library ! +#define R4KIND selected_real_kind(6) +#define R8KIND selected_real_kind(12) #ifndef NATIVE_MASSV subroutine vdiv(z,x,y,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=x(j)/y(j) 10 continue @@ -11,7 +15,9 @@ subroutine vdiv(z,x,y,n) end subroutine vsdiv(z,x,y,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=x(j)/y(j) 10 continue @@ -19,7 +25,9 @@ subroutine vsdiv(z,x,y,n) end subroutine vexp(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=exp(x(j)) 10 continue @@ -27,7 +35,9 @@ subroutine vexp(y,x,n) end subroutine vsexp(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=exp(x(j)) 10 continue @@ -35,7 +45,9 @@ subroutine vsexp(y,x,n) end subroutine vlog(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log(x(j)) 10 continue @@ -43,7 +55,9 @@ subroutine vlog(y,x,n) end subroutine vslog(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log(x(j)) 10 continue @@ -51,7 +65,9 @@ subroutine vslog(y,x,n) end subroutine vrec(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.d0/x(j) 10 continue @@ -59,7 +75,9 @@ subroutine vrec(y,x,n) end subroutine vsrec(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.e0/x(j) 10 continue @@ -67,7 +85,9 @@ subroutine vsrec(y,x,n) end subroutine vrsqrt(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.d0/sqrt(x(j)) 10 continue @@ -75,7 +95,9 @@ subroutine vrsqrt(y,x,n) end subroutine vsrsqrt(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.e0/sqrt(x(j)) 10 continue @@ -83,7 +105,9 @@ subroutine vsrsqrt(y,x,n) end subroutine vsincos(x,y,z,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n x(j)=sin(z(j)) y(j)=cos(z(j)) @@ -92,7 +116,9 @@ subroutine vsincos(x,y,z,n) end subroutine vssincos(x,y,z,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n x(j)=sin(z(j)) y(j)=cos(z(j)) @@ -101,7 +127,9 @@ subroutine vssincos(x,y,z,n) end subroutine vsqrt(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sqrt(x(j)) 10 continue @@ -109,7 +137,9 @@ subroutine vsqrt(y,x,n) end subroutine vssqrt(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sqrt(x(j)) 10 continue @@ -117,7 +147,9 @@ subroutine vssqrt(y,x,n) end subroutine vtan(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tan(x(j)) 10 continue @@ -125,7 +157,9 @@ subroutine vtan(y,x,n) end subroutine vstan(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tan(x(j)) 10 continue @@ -133,7 +167,9 @@ subroutine vstan(y,x,n) end subroutine vatan2(z,y,x,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=atan2(y(j),x(j)) 10 continue @@ -141,7 +177,9 @@ subroutine vatan2(z,y,x,n) end subroutine vsatan2(z,y,x,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=atan2(y(j),x(j)) 10 continue @@ -149,7 +187,9 @@ subroutine vsatan2(z,y,x,n) end subroutine vasin(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=asin(x(j)) 10 continue @@ -157,7 +197,9 @@ subroutine vasin(y,x,n) end subroutine vsin(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sin(x(j)) 10 continue @@ -165,7 +207,9 @@ subroutine vsin(y,x,n) end subroutine vssin(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sin(x(j)) 10 continue @@ -173,7 +217,9 @@ subroutine vssin(y,x,n) end subroutine vacos(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=acos(x(j)) 10 continue @@ -181,7 +227,9 @@ subroutine vacos(y,x,n) end subroutine vcos(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cos(x(j)) 10 continue @@ -189,7 +237,9 @@ subroutine vcos(y,x,n) end subroutine vscos(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cos(x(j)) 10 continue @@ -197,25 +247,31 @@ subroutine vscos(y,x,n) end subroutine vcosisin(y,x,n) - complex*16 y(*) - real*8 x(*) + complex(kind=R8KIND) y(*) + real(kind=R8KIND) x(*) + integer n + integer j do 10 j=1,n - y(j)=dcmplx(cos(x(j)),sin(x(j))) + y(j)=cmplx(cos(x(j)),sin(x(j)),kind=R8KIND) 10 continue return end subroutine vscosisin(y,x,n) - complex*8 y(*) - real*4 x(*) + complex(kind=R4KIND) y(*) + real(kind=R4KIND) x(*) + integer n + integer j do 10 j=1,n - y(j)= cmplx(cos(x(j)),sin(x(j))) + y(j)= cmplx(cos(x(j)),sin(x(j)),kind=R4KIND) 10 continue return end subroutine vdint(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n ! y(j)=dint(x(j)) y(j)=int(x(j)) @@ -224,7 +280,9 @@ subroutine vdint(y,x,n) end subroutine vdnint(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n ! y(j)=dnint(x(j)) y(j)=nint(x(j)) @@ -233,7 +291,9 @@ subroutine vdnint(y,x,n) end subroutine vlog10(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log10(x(j)) 10 continue @@ -241,10 +301,10 @@ subroutine vlog10(y,x,n) end ! subroutine vlog1p(y,x,n) -! real*8 x(*),y(*) +! real(kind=R8KIND) x(*),y(*) ! interface -! real*8 function log1p(%val(x)) -! real*8 x +! real(kind=R8KIND) function log1p(%val(x)) +! real(kind=R8KIND) x ! end function log1p ! end interface ! do 10 j=1,n @@ -254,7 +314,9 @@ subroutine vlog10(y,x,n) ! end subroutine vcosh(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cosh(x(j)) 10 continue @@ -262,7 +324,9 @@ subroutine vcosh(y,x,n) end subroutine vsinh(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sinh(x(j)) 10 continue @@ -270,7 +334,9 @@ subroutine vsinh(y,x,n) end subroutine vtanh(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tanh(x(j)) 10 continue @@ -278,10 +344,10 @@ subroutine vtanh(y,x,n) end ! subroutine vexpm1(y,x,n) -! real*8 x(*),y(*) +! real(kind=R8KIND) x(*),y(*) ! interface -! real*8 function expm1(%val(x)) -! real*8 x +! real(kind=R8KIND) function expm1(%val(x)) +! real(kind=R8KIND) x ! end function expm1 ! end interface ! do 10 j=1,n @@ -292,7 +358,9 @@ subroutine vtanh(y,x,n) subroutine vsasin(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=asin(x(j)) 10 continue @@ -300,7 +368,9 @@ subroutine vsasin(y,x,n) end subroutine vsacos(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n #if defined (G95) ! no reason why g95 should fail - oh well, we don't use this routine anyways @@ -313,7 +383,9 @@ subroutine vsacos(y,x,n) end subroutine vscosh(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cosh(x(j)) 10 continue @@ -321,10 +393,10 @@ subroutine vscosh(y,x,n) end ! subroutine vsexpm1(y,x,n) -! real*4 x(*),y(*) +! real(kind=R4KIND) x(*),y(*) ! interface -! real*8 function expm1(%val(x)) -! real*8 x +! real(kind=R8KIND) function expm1(%val(x)) +! real(kind=R8KIND) x ! end function expm1 ! end interface ! do 10 j=1,n @@ -334,7 +406,9 @@ subroutine vscosh(y,x,n) ! end subroutine vslog10(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log10(x(j)) 10 continue @@ -342,10 +416,10 @@ subroutine vslog10(y,x,n) end ! subroutine vslog1p(y,x,n) -! real*4 x(*),y(*) +! real(kind=R4KIND) x(*),y(*) ! interface -! real*8 function log1p(%val(x)) -! real*8 x +! real(kind=R8KIND) function log1p(%val(x)) +! real(kind=R8KIND) x ! end function log1p ! end interface ! do 10 j=1,n @@ -356,7 +430,9 @@ subroutine vslog10(y,x,n) subroutine vssinh(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sinh(x(j)) 10 continue @@ -364,7 +440,9 @@ subroutine vssinh(y,x,n) end subroutine vstanh(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tanh(x(j)) 10 continue @@ -373,7 +451,9 @@ subroutine vstanh(y,x,n) #endif subroutine vspow(z,y,x,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=y(j)**x(j) 10 continue @@ -381,7 +461,9 @@ subroutine vspow(z,y,x,n) end subroutine vpow(z,y,x,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=y(j)**x(j) 10 continue diff --git a/src/core_atmosphere/physics/physics_wrf/module_bep_bem_helper.F b/src/core_atmosphere/physics/physics_wrf/module_bep_bem_helper.F new file mode 100644 index 0000000000..ac29b7bf9a --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_bep_bem_helper.F @@ -0,0 +1,4 @@ +MODULE module_bep_bem_helper + integer, save :: nurbm ! Maximum number of urban classes +CONTAINS +END MODULE module_bep_bem_helper diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F b/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F index 58dcc15853..ae95ed5d62 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F @@ -1,34 +1,30 @@ -!----------------------------------------------------------------------------------------------------------------- -! copied from WRF version 4.0.2 for implementation in MPAS: - -! modifications to sourcecode for implementation in MPAS: -! * made the variable dx (and local variable dxmeter) a two-dimensional array to include the impact -! of the mean distance between cells. -! * added the initialization of kpblmax to kte if the optional variables p_top,znu,and znw are not -! available in the argument list. -! Laura D. Fowler (laura@ucar.edu) / 2019-01-29. -! * because the topography variance is zero over ocean points,also check that the variable zlowtop -! is strictly greater than zero for the initialization of klowtop and kloop1. -! Laura D. Fowler (laura@ucar.edu) / 2019-01-30. - -!WRF:model_layer:physics -! -module module_bl_gwdo -contains -!------------------------------------------------------------------------------- - subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & - rublten,rvblten, & - dtaux3d,dtauy3d,dusfcg,dvsfcg, & - var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & - sina,cosa,znu,znw,p_top, & - cp,g,rd,rv,ep1,pi, & - dt,dx,kpbl2d,itimestep, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- +!================================================================================================================= + module module_bl_gwdo + use mpas_kind_types,only: kind_phys => RKIND + use bl_gwdo + + implicit none + private + public:: gwdo + + + contains + + +!================================================================================================================= + subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & + rublten,rvblten, & + dtaux3d,dtauy3d,dusfcg,dvsfcg, & + var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & + sina,cosa,znu,znw,p_top, & + cp,g,rd,rv,ep1,pi, & + dt,dx,kpbl2d,itimestep, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + errmsg,errflg & + ) +!================================================================================================================= ! !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) @@ -69,680 +65,177 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & !-- 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 - integer, intent(in ) :: itimestep -! - real, intent(in ) :: dt,cp,g,rd,rv,ep1,pi -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: qv3d, & - p3d, & - pi3d, & - t3d, & - z - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: p3di -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & - rvblten - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: dtaux3d, & - dtauy3d -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: u3d, & - v3d -! - integer, dimension( ims:ime, jms:jme ) , & - intent(in ) :: kpbl2d - real, dimension( ims:ime, jms:jme ) , & - intent(inout ) :: dusfcg, & - dvsfcg -! - real, dimension( ims:ime, jms:jme ) , & - intent(in ) :: dx - real, dimension( ims:ime, jms:jme ) , & - intent(in ) :: var2d, & - oc12d, & - oa2d1,oa2d2,oa2d3,oa2d4, & - ol2d1,ol2d2,ol2d3,ol2d4, & - sina,cosa -! - real, dimension( kms:kme ) , & - optional , & - intent(in ) :: znu, & - znw -! - real, optional, intent(in ) :: p_top -! -!local -! - real, dimension( its:ite, kts:kte ) :: delprsi, & - pdh - real, dimension( its:ite, kts:kte ) :: ugeo, vgeo, dudt, dvdt, dtaux, dtauy - real, dimension( its:ite ) :: dusfc, dvsfc - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite, 4 ) :: oa4, & - ol4 - integer :: i,j,k,kpblmax -! - if(present(p_top) .and. present(znu) .and. present(znw)) then - do k = kts,kte - if (znu(k).gt.0.6) kpblmax = k + 1 - enddo - else - kpblmax = kte - endif -! - do j = jts,jte - do k = kts,kte+1 - do i = its,ite - if (k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo -! - do k = kts,kte - do i = its,ite - delprsi(i,k) = pdhi(i,k)-pdhi(i,k+1) -! rotate winds to zonal/meridional - ugeo(i,k) = u3d(i,k,j)*cosa(i,j) - v3d(i,k,j)*sina(i,j) - vgeo(i,k) = u3d(i,k,j)*sina(i,j) + v3d(i,k,j)*cosa(i,j) - dudt(i,k) = 0.0 - dvdt(i,k) = 0.0 - enddo - enddo - do i = its,ite - oa4(i,1) = oa2d1(i,j) - oa4(i,2) = oa2d2(i,j) - oa4(i,3) = oa2d3(i,j) - oa4(i,4) = oa2d4(i,j) - ol4(i,1) = ol2d1(i,j) - ol4(i,2) = ol2d2(i,j) - ol4(i,3) = ol2d3(i,j) - ol4(i,4) = ol2d4(i,j) - enddo - call gwdo2d(dudt=dudt(its,kts),dvdt=dvdt(its,kts) & - ,dtaux2d=dtaux(its,kts),dtauy2d=dtauy(its,kts) & - ,u1=ugeo(its,kts),v1=vgeo(its,kts) & - ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) & - ,del=delprsi(its,kts) & - ,prsi=pdhi(its,kts) & - ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) & - ,zl=z(ims,kms,j) & - ,kpblmax=kpblmax & - ,var=var2d(ims,j),oc1=oc12d(ims,j) & - ,oa4=oa4,ol4=ol4 & - ,dusfc=dusfc(its),dvsfc=dvsfc(its) & - ,g_=g,cp_=cp,rd_=rd,rv_=rv,fv_=ep1,pi_=pi & - ,dxmeter=dx,deltim=dt & - ,kpbl=kpbl2d(ims,j),lat=j & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & - ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) - do k = kts,kte - do i = its,ite -! rotate tendencies from zonal/meridional to model grid - rublten(i,k,j) = rublten(i,k,j)+dudt(i,k)*cosa(i,j) + dvdt(i,k)*sina(i,j) - rvblten(i,k,j) = rvblten(i,k,j)-dudt(i,k)*sina(i,j) + dvdt(i,k)*cosa(i,j) - dtaux3d(i,k,j) = dtaux(i,k)*cosa(i,j) + dtauy(i,k)*sina(i,j) - dtauy3d(i,k,j) =-dtaux(i,k)*sina(i,j) + dtauy(i,k)*cosa(i,j) - if(k.eq.kts)then - dusfcg(i,j) = dusfc(i)*cosa(i,j) + dvsfc(i)*sina(i,j) - dvsfcg(i,j) =-dusfc(i)*sina(i,j) + dvsfc(i)*cosa(i,j) - endif - enddo - enddo - enddo -! - end subroutine gwdo -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- - subroutine gwdo2d(dudt, dvdt, dtaux2d, dtauy2d, & - u1, v1, t1, q1, & - del, & - prsi, prsl, prslk, zl, & - kpblmax, & - var, oc1, oa4, ol4, dusfc, dvsfc, & - g_, cp_, rd_, rv_, fv_, pi_, & - dxmeter, deltim, kpbl, lat, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) -!------------------------------------------------------------------------------- -! -! abstract : -! this code handles the time tendencies of u v due to the effect of -! mountain induced gravity wave drag from sub-grid scale orography. -! this routine not only treats the traditional upper-level wave breaking due -! to mountain variance (alpert 1988), but also the enhanced -! lower-tropospheric wave breaking due to mountain convexity and asymmetry -! (kim and arakawa 1995). thus, in addition to the terrain height data -! in a model grid gox, additional 10-2d topographic statistics files are -! needed, including orographic standard deviation (var), convexity (oc1), -! asymmetry (oa4) and ol (ol4). these data sets are prepared based on the -! 30 sec usgs orography (hong 1999). the current scheme was implmented as in -! choi and hong (2015), which names kim gwdo since it was developed by -! kiaps staffs for kiaps integrated model system (kim). the scheme -! additionally includes the effects of orographic anisotropy and -! flow-blocking drag. -! coded by song-you hong and young-joon kim and implemented by song-you hong -! -! history log : -! 2015-07-01 hyun-joo choi add flow-blocking drag and orographic anisotropy -! -! references : -! choi and hong (2015), j. geophys. res. -! hong et al. (2008), wea. forecasting -! kim and doyle (2005), q. j. r. meteor. soc. -! kim and arakawa (1995), j. atmos. sci. -! alpet et al. (1988), NWP conference -! hong (1999), NCEP office note 424 -! -! input : -! dudt, dvdt - non-lin tendency for u and v wind component -! u1, v1 - zonal and meridional wind m/sec at t0-dt -! t1 - temperature deg k at t0-dt -! q1 - mixing ratio at t0-dt -! deltim - time step (s) -! del - positive increment of pressure across layer (pa) -! kpblmax, kpbl - vertical index of pbl height -! prslk, zl, prsl, prsi - pressure and height variables -! oa4, ol4, omax, var, oc1 - orographic statistics -! -! output : -! dudt, dvdt - wind tendency due to gwdo -! dtaux2d, dtauy2d - diagnoised orographic gwd -! dusfc, dvsfc - gw stress -! -!------------------------------------------------------------------------------- - implicit none -! - integer , intent(in ) :: lat, kpblmax, & - ids, ide, jds, jde, & - kds, kde, ims, ime, & - jms, jme, kms, kme, & - its, ite, jts, jte, & - kts, kte - integer, dimension(ims:ime) , intent(in ) :: kpbl - real , intent(in ) :: g_, pi_, rd_, rv_, fv_,& - cp_, deltim - real, dimension(ims:ime) , intent(in ) :: dxmeter - real, dimension(its:ite,kts:kte) , intent(inout) :: dudt, dvdt - real, dimension(its:ite,kts:kte) , intent( out) :: dtaux2d, dtauy2d - real, dimension(its:ite,kts:kte) , intent(in ) :: u1, v1 - real, dimension(ims:ime,kms:kme) , intent(in ) :: t1, q1, prslk, zl -! - real, dimension(its:ite,kts:kte) , intent(in ) :: prsl, del - real, dimension(its:ite,kts:kte+1), intent(in ) :: prsi - real, dimension(its:ite,4) , intent(in ) :: oa4, ol4 -! - real, dimension(ims:ime) , intent(in ) :: var, oc1 - real, dimension(its:ite) , intent( out) :: dusfc, dvsfc -! - real, parameter :: ric = 0.25 ! critical richardson number - real, parameter :: dw2min = 1. - real, parameter :: rimin = -100. - real, parameter :: bnv2min = 1.0e-5 - real, parameter :: efmin = 0.0 - real, parameter :: efmax = 10.0 - real, parameter :: xl = 4.0e4 - real, parameter :: critac = 1.0e-5 - real, parameter :: gmax = 1. - real, parameter :: veleps = 1.0 - real, parameter :: frc = 1.0 - real, parameter :: ce = 0.8 - real, parameter :: cg = 0.5 - integer,parameter :: kpblmin = 2 -! -! local variables -! - integer :: latd,lond - integer :: i,k,lcap,lcapp1,nwd,idir, & - klcap,kp1,ikount,kk -! - real :: fdir,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & - temv,dtaux,dtauy -! - logical, dimension(its:ite) :: ldrag, icrilv, flag,kloop1 - real, dimension(its:ite) :: coefm -! - real, dimension(its:ite) :: taub, xn, yn, ubar, vbar, fr, & - ulow, rulow, bnv, oa, ol, rhobar, & - dtfac, brvf, xlinv, delks,delks1, & - zlowtop,cleff - real, dimension(its:ite,kts:kte+1) :: taup - real, dimension(its:ite,kts:kte-1) :: velco - real, dimension(its:ite,kts:kte) :: bnv2, usqj, taud, rho, vtk, vtj -! - integer, dimension(its:ite) :: kbl, klowtop - integer, parameter :: mdir=8 - integer, dimension(mdir) :: nwdir - data nwdir/6,7,5,8,2,3,1,4/ -! -! variables for flow-blocking drag -! - real, parameter :: frmax = 10. - real, parameter :: olmin = 1.0e-5 - real, parameter :: odmin = 0.1 - real, parameter :: odmax = 10. -! - real :: fbdcd - real :: zblk, tautem - real :: fbdpe, fbdke - real, dimension(its:ite) :: delx, dely - real, dimension(its:ite,4) :: dxy4, dxy4p - real, dimension(4) :: ol4p - real, dimension(its:ite) :: dxy, dxyp, olp, od - real, dimension(its:ite,kts:kte+1) :: taufb -! - integer, dimension(its:ite) :: komax - integer :: kblk -!------------------------------------------------------------------------------- -! -! constants -! - lcap = kte - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi_) -! -! calculate length of grid for flow-blocking drag -! - delx(its:ite) = dxmeter(its:ite) - dely(its:ite) = dxmeter(its:ite) - dxy4(its:ite,1) = delx(its:ite) - dxy4(its:ite,2) = dely(its:ite) - dxy4(its:ite,3) = sqrt(delx(its:ite)**2. + dely(its:ite)**2.) - dxy4(its:ite,4) = dxy4(its:ite,3) - dxy4p(its:ite,1) = dxy4(its:ite,2) - dxy4p(its:ite,2) = dxy4(its:ite,1) - dxy4p(its:ite,3) = dxy4(its:ite,4) - dxy4p(its:ite,4) = dxy4(its:ite,3) -! - cleff(its:ite) = dxmeter(its:ite) -! -! initialize arrays -! - ldrag = .false. ; icrilv = .false. ; flag = .true. -! - klowtop = 0 ; kbl = 0 -! - dtaux = 0. ; dtauy = 0. ; xn = 0. ; yn = 0. - ubar = 0. ; vbar = 0. ; rhobar = 0. ; ulow = 0. - oa = 0. ; ol = 0. ; taub = 0. -! - usqj = 0. ; bnv2 = 0. ; vtj = 0. ; vtk = 0. - taup = 0. ; taud = 0. ; dtaux2d = 0. ; dtauy2d = 0. -! - dtfac = 1.0 ; xlinv = 1.0/xl -! -! initialize arrays for flow-blocking drag -! - komax = 0 - taufb = 0.0 -! - do k = kts,kte - do i = its,ite - vtj(i,k) = t1(i,k) * (1.+fv_*q1(i,k)) - vtk(i,k) = vtj(i,k) / prslk(i,k) - rho(i,k) = 1./rd_ * prsl(i,k) / vtj(i,k) ! density kg/m**3 - enddo - enddo -! - do i = its,ite - zlowtop(i) = 2. * var(i) - enddo -! - do i = its,ite - kloop1(i) = .true. - enddo -! - do k = kts+1,kte - do i = its,ite - if(zlowtop(i) .gt. 0.) then - if (kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then - klowtop(i) = k+1 - kloop1(i) = .false. - endif - endif - enddo - enddo -! - do i = its,ite -! -! determine reference level: 2*var -! - kbl(i) = klowtop(i) - kbl(i) = max(min(kbl(i),kpblmax),kpblmin) - enddo -! -! determine the level of maximum orographic height -! - komax(:) = kbl(:) -! - do i = its,ite - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) - enddo -! -! compute low level averages within pbl -! - do k = kts,kpblmax - do i = its,ite - if (k.lt.kbl(i)) then - rcsks = del(i,k) * delks(i) - rdelks = del(i,k) * delks(i) - ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean - rhobar(i) = rhobar(i) + rdelks * rho(i,k) ! pbl rho mean - endif - enddo - enddo -! -! figure out low-level horizontal wind direction -! -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! - do i = its,ite - wdir = atan2(ubar(i),vbar(i)) + pi_ - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) - ol(i) = ol4(i,mod(nwd-1,4)+1) -! -! compute orographic width along (ol) and perpendicular (olp) the wind direction -! - ol4p(1) = ol4(i,2) - ol4p(2) = ol4(i,1) - ol4p(3) = ol4(i,4) - ol4p(4) = ol4(i,3) - olp(i) = ol4p(mod(nwd-1,4)+1) -! -! compute orographic direction (horizontal orographic aspect ratio) -! - od(i) = olp(i)/max(ol(i),olmin) - od(i) = min(od(i),odmax) - od(i) = max(od(i),odmin) -! -! compute length of grid in the along(dxy) and cross(dxyp) wind directions -! - dxy(i) = dxy4(i,MOD(nwd-1,4)+1) - dxyp(i) = dxy4p(i,MOD(nwd-1,4)+1) - enddo -! -! saving richardson number in usqj for migwdi -! - do k = kts,kte-1 - do i = its,ite - ti = 2.0 / (t1(i,k)+t1(i,k+1)) - rdz = 1./(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = tem1*tem1 + tem2*tem2 - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g_*(g_/cp_+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = 2.0*g_*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - enddo - enddo -! -! compute the "low level" or 1/3 wind magnitude (m/s) -! - do i = its,ite - ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) - rulow(i) = 1./ulow(i) - enddo -! - do k = kts,kte-1 - do i = its,ite - velco(i,k) = 0.5 * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) - if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then - velco(i,k) = veleps - endif - enddo - enddo -! -! no drag when critical level in the base layer -! - do i = its,ite - ldrag(i) = velco(i,1).le.0. - enddo -! -! no drag when velco.lt.0 -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. - enddo - enddo -! -! the low level weighted average ri is stored in usqj(1,1; im) -! the low level weighted average n**2 is stored in bnv2(1,1; im) -! this is called bnvl2 in phy_gwd_alpert_sub not bnv2 -! rdelks (del(k)/delks) vert ave factor so we can * instead of / -! - do i = its,ite - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) - enddo -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) - bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks - usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks - endif - enddo - enddo -! - do i = its,ite - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 - ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 - enddo -! -! set all ri low level values to the low level value -! - do k = kpblmin,kpblmax - do i = its,ite - if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) - enddo - enddo -! - do i = its,ite - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * var(i) * od(i) - fr(i) = min(fr(i),frmax) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) - endif - enddo -! -! compute the base level stress and store it in taub -! calculate enhancement factor, number of mountains & aspect -! ratio const. use simplified relationship between standard -! deviation & critical hgt -! - do i = its,ite - if (.not. ldrag(i)) then - efact = (oa(i) + 2.) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) - coefm(i) = (1. + ol(i)) ** (oa(i)+1.) - xlinv(i) = coefm(i) / cleff(i) - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - taub(i) = xlinv(i) * rhobar(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else - taub(i) = 0.0 - xn(i) = 0.0 - yn(i) = 0.0 - endif - enddo -! -! now compute vertical structure of the stress. -! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo -! - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite -! -! unstablelayer if ri < ric -! unstable layer if upper air vel comp along surf vel <=0 (crit lay) -! at (u-c)=0. crit layer exists and bit vector should be set (.le.) -! - if (k .ge. kbl(i)) then - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & - .or. (velco(i,k) .le. 0.0) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif - enddo -! - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then - temv = 1.0 / velco(i,k) - tem1 = coefm(i)/dxy(i)*(rho(i,kp1)+rho(i,k))*brvf(i)*velco(i,k)*0.5 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv -! -! rim is the minimum-richardson number by shutts (1985) -! - tem2 = sqrt(usqj(i,k)) - tem = 1. + tem2 * fro - rim = usqj(i,k) * (1.-fro) / (tem * tem) -! -! check stability to employ the 'saturation hypothesis' -! of lindzen (1981) except at tropospheric downstream regions -! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) - endif - endif - endif - enddo - enddo -! - if (lcap.lt.kte) then - do klcap = lcapp1,kte - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - enddo - endif - do i = its,ite - if (.not.ldrag(i)) then -! -! determine the height of flow-blocking layer -! - kblk = 0 - fbdpe = 0.0 - fbdke = 0.0 - do k = kte, kpblmin, -1 - if (kblk.eq.0 .and. k.le.kbl(i)) then - fbdpe = fbdpe + bnv2(i,k)*(zl(i,kbl(i))-zl(i,k)) & - *del(i,k)/g_/rho(i,k) - fbdke = 0.5*(u1(i,k)**2.+v1(i,k)**2.) -! -! apply flow-blocking drag when fbdpe >= fbdke -! - if (fbdpe.ge.fbdke) then - kblk = k - kblk = min(kblk,kbl(i)) - zblk = zl(i,kblk)-zl(i,kts) - endif - endif +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + integer,intent(in):: itimestep + + integer,intent(in),dimension(ims:ime,jms:jme):: kpbl2d + + real(kind=kind_phys),intent(in):: dt,cp,g,rd,rv,ep1,pi + real(kind=kind_phys),intent(in),optional:: p_top + + real(kind=kind_phys),intent(in),dimension(kms:kme),optional:: & + znu, & + znw + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, & + var2d, & + oc12d, & + oa2d1,oa2d2,oa2d3,oa2d4, & + ol2d1,ol2d2,ol2d3,ol2d4, & + sina,cosa + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + qv3d, & + p3d, & + pi3d, & + t3d, & + u3d, & + v3d, & + z + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + p3di + +!--- output arguments: + character(len=*),intent(out):: errmsg + + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + dusfcg, & + dvsfcg + + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + dtaux3d, & + dtauy3d + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + rublten, & + rvblten + +!--- local variables and arrays: + integer:: i,j,k + + real(kind=kind_phys),dimension(its:ite):: & + var2d_hv,oc12d_hv,dx_hv,sina_hv,cosa_hv + real(kind=kind_phys),dimension(its:ite):: & + oa2d1_hv,oa2d2_hv,oa2d3_hv,oa2d4_hv,ol2d1_hv,ol2d2_hv,ol2d3_hv,ol2d4_hv + real(kind=kind_phys),dimension(its:ite):: & + dusfcg_hv,dvsfcg_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + u3d_hv,v3d_hv,t3d_hv,qv3d_hv,pi3d_hv,p3d_hv,z_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + rublten_hv,rvblten_hv,dtaux3d_hv,dtauy3d_hv + + real(kind=kind_phys),dimension(its:ite,kms:kme):: & + p3di_hv + +!----------------------------------------------------------------------------------------------------------------- + +! Outer j-loop. Allows consistency between WRF and MPAS in the driver. + + do j = jts,jte + + ! All variables for gwdo2d are tile-sized and have only a single + ! horizontal dimension. The _hv suffix refers to "horizontal vertical", + ! a reminder that there is a single horizontal index. Yes, we know that + ! variables that have only a horizontal index are not *really* _hv. + + ! All of the following 3d and 2d variables are declared intent(in) in the + ! gwdo2d subroutine, so there is no need to put the updated values back + ! from the temporary arrays back into the original arrays. + + ! Variables that are INTENT(IN) or INTENT(INOUT) + + ! 3d, interface levels: + do k = kts,kte+1 + do i = its,ite + p3di_hv(i,k) = p3di(i,k,j) enddo - if (kblk.ne.0) then -! -! compute flow-blocking stress -! - fbdcd = max(2.0-1.0/od(i),0.0) - taufb(i,kts) = 0.5*rhobar(i)*coefm(i)/dxmeter(i)**2*fbdcd*dxyp(i) & - *olp(i)*zblk*ulow(i)**2 - tautem = taufb(i,kts)/real(kblk-kts) - do k = kts+1, kblk - taufb(i,k) = taufb(i,k-1) - tautem - enddo -! -! sum orographic GW stress and flow-blocking stress -! - taup(i,:) = taup(i,:) + taufb(i,:) - endif - endif - enddo -! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy -! - do k = kts,kte - do i = its,ite - taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * g_ / del(i,k) - enddo - enddo -! -! if the gravity wave drag would force a critical line -! in the lower ksmm1 layers during the next deltim timestep, -! then only apply drag until that critical line is reached. -! - do k = kts,kpblmax-1 - do i = its,ite - if (k .le. kbl(i)) then - if (taud(i,k).ne.0.) & - dtfac(i) = min(dtfac(i),abs(velco(i,k)/(deltim*taud(i,k)))) - endif - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - enddo -! - do k = kts,kte - do i = its,ite - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) - dtauy = taud(i,k) * yn(i) - dtaux2d(i,k) = dtaux - dtauy2d(i,k) = dtauy - dudt(i,k) = dtaux + dudt(i,k) - dvdt(i,k) = dtauy + dvdt(i,k) - dusfc(i) = dusfc(i) + dtaux * del(i,k) - dvsfc(i) = dvsfc(i) + dtauy * del(i,k) - enddo - enddo -! - do i = its,ite - dusfc(i) = (-1./g_) * dusfc(i) - dvsfc(i) = (-1./g_) * dvsfc(i) - enddo -! - return - end subroutine gwdo2d -!------------------------------------------------------------------------------- -!------------------------------------------------------------------------------- + enddo + + ! 3d, layers: + do k = kts,kte + do i = its,ite + rublten_hv(i,k) = rublten(i,k,j) + rvblten_hv(i,k) = rvblten(i,k,j) + u3d_hv(i,k) = u3d(i,k,j) + v3d_hv(i,k) = v3d(i,k,j) + t3d_hv(i,k) = t3d(i,k,j) + qv3d_hv(i,k) = qv3d(i,k,j) + p3d_hv(i,k) = p3d(i,k,j) + pi3d_hv(i,k) = pi3d(i,k,j) + z_hv(i,k) = z(i,k,j) + enddo + enddo + + ! 2d: + do i = its,ite + dx_hv(i) = dx(i,j) + var2d_hv(i) = var2d(i,j) + oc12d_hv(i) = oc12d(i,j) + sina_hv(i) = sina(i,j) + cosa_hv(i) = cosa(i,j) + oa2d1_hv(i) = oa2d1(i,j) + oa2d2_hv(i) = oa2d2(i,j) + oa2d3_hv(i) = oa2d3(i,j) + oa2d4_hv(i) = oa2d4(i,j) + ol2d1_hv(i) = ol2d1(i,j) + ol2d2_hv(i) = ol2d2(i,j) + ol2d3_hv(i) = ol2d3(i,j) + ol2d4_hv(i) = ol2d4(i,j) + enddo + + call bl_gwdo_run(sina=sina_hv,cosa=cosa_hv & + ,rublten=rublten_hv,rvblten=rvblten_hv & + ,dtaux3d=dtaux3d_hv,dtauy3d=dtauy3d_hv & + ,dusfcg=dusfcg_hv,dvsfcg=dvsfcg_hv & + ,uproj=u3d_hv,vproj=v3d_hv & + ,t1=t3d_hv,q1=qv3d_hv & + ,prsi=p3di_hv & + ,prsl=p3d_hv,prslk=pi3d_hv & + ,zl=z_hv & + ,var=var2d_hv,oc1=oc12d_hv & + ,oa2d1=oa2d1_hv, oa2d2=oa2d2_hv & + ,oa2d3=oa2d3_hv, oa2d4=oa2d4_hv & + ,ol2d1=ol2d1_hv, ol2d2=ol2d2_hv & + ,ol2d3=ol2d3_hv, ol2d4=ol2d4_hv & + ,g_=g,cp_=cp,rd_=rd,rv_=rv,fv_=ep1,pi_=pi & + ,dxmeter=dx_hv,deltim=dt & + ,its=its,ite=ite,kte=kte,kme=kte+1 & + ,errmsg=errmsg,errflg=errflg) + + ! Variables that are INTENT(OUT) or INTENT(INOUT): + + ! 3d, layers: + do k = kts,kte + do i = its,ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) + dtaux3d(i,k,j) = dtaux3d_hv(i,k) + dtauy3d(i,k,j) = dtauy3d_hv(i,k) + enddo + enddo + + ! 2d: + do i = its,ite + dusfcg(i,j) = dusfcg_hv(i) + dvsfcg(i,j) = dvsfcg_hv(i) + enddo + + enddo ! Outer J-loop + + end subroutine gwdo + +!================================================================================================================= end module module_bl_gwdo +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F index 46486d305e..d516bf1b4f 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F @@ -1,23 +1,22 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 !================================================================================================================= -!module_bl_ysu.F was modified to accomodate both the WRF and MPAS models / 2018-12-7 + module module_bl_ysu + use mpas_log + use mpas_kind_types,only: kind_phys => RKIND + use bl_ysu + + implicit none + private + public:: ysu + + + contains + + !================================================================================================================= -!WRF:model_layer:physics -! -! -! -! -! -! -! -module module_bl_ysu -contains -! -! -!------------------------------------------------------------------------------- -! - subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & + subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & rublten,rvblten,rthblten, & - rqvblten,rqcblten,rqiblten,flag_qi, & + rqvblten,rqcblten,rqiblten,flag_qc,flag_qi, & cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & dz8w,psfc, & znt,ust,hpbl,psim,psih, & @@ -29,14 +28,20 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & uoce,voce, & rthraten,ysu_topdown_pblmix, & ctopo,ctopo2, & + idiff,flag_bep,frc_urb2d, & + a_u_bep,a_v_bep,a_t_bep, & + a_q_bep, & + a_e_bep,b_u_bep,b_v_bep, & + b_t_bep,b_q_bep, & + b_e_bep,dlg_bep, & + dl_u_bep,sf_bep,vl_bep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - !optional - regime & + errmsg,errflg & ) !------------------------------------------------------------------------------- - implicit none + implicit none !------------------------------------------------------------------------------- !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) @@ -90,6 +95,23 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- ep1 constant for virtual temperature (r_v/r_d - 1) !-- ep2 constant for specific humidity calculation !-- karman von karman constant +!-- idiff diff3d BEP/BEM+BEM diffusion flag +!-- flag_bep flag to use BEP/BEP+BEM +!-- frc_urb2d urban fraction +!-- a_u_bep BEP/BEP+BEM implicit component u-mom +!-- a_v_bep BEP/BEP+BEM implicit component v-mom +!-- a_t_bep BEP/BEP+BEM implicit component pot. temp. +!-- a_q_bep BEP/BEP+BEM implicit component vapor mixing ratio +!-- a_e_bep BEP/BEP+BEM implicit component TKE +!-- b_u_bep BEP/BEP+BEM explicit component u-mom +!-- b_v_bep BEP/BEP+BEM explicit component v-mom +!-- b_t_bep BEP/BEP+BEM explicit component pot.temp. +!-- b_q_bep BEP/BEP+BEM explicit component vapor mixing ratio +!-- b_e_bep BEP/BEP+BEM explicit component TKE +!-- dlg_bep Height above ground Martilli et al. (2002) Eq. 24 +!-- dl_u_bep modified length scale Martilli et al. (2002) Eq. 22 +!-- sf_bep fraction of vertical surface not occupied by buildings +!-- vl_bep volume fraction of grid cell not occupied by buildings !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -110,8 +132,6 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- kte end index for k in tile !------------------------------------------------------------------------------- ! - integer,parameter :: ndiff = 3 - real,parameter :: rcl = 1.0 ! integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -119,1646 +139,333 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & integer, intent(in) :: ysu_topdown_pblmix ! - real, intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv + real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv ! - real, intent(in ) :: ep1,ep2,karman + real(kind=kind_phys), intent(in ) :: ep1,ep2,karman ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: qv3d, & qc3d, & qi3d, & p3d, & pi3d, & - th3d, & t3d, & dz8w, & rthraten - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: p3di ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: rublten, & rvblten, & rthblten, & rqvblten, & - rqcblten + rqcblten, & + rqiblten ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: exch_h, & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: exch_h, & exch_m - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: wstar - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: delta - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: wstar + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: delta + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(inout) :: u10, & v10 - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: uoce, & voce ! - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: xland, & hfx, & qfx, & br, & psfc - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: & psim, & psih - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: znt, & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(in ) :: znt, & ust, & - hpbl, & wspd + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: hpbl ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: u3d, & v3d ! integer, dimension( ims:ime, jms:jme ) , & intent(out ) :: kpbl2d - logical, intent(in) :: flag_qi ! -!optional + logical, intent(in) :: flag_qc, & + flag_qi ! - real, dimension( ims:ime, jms:jme ) , & + integer, intent(in) :: idiff + logical, intent(in) :: flag_bep + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & optional , & - intent(inout) :: regime -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(in) :: a_u_bep, & + a_v_bep,a_t_bep, & + a_e_bep,b_u_bep, & + a_q_bep,b_q_bep, & + b_v_bep,b_t_bep, & + b_e_bep,dlg_bep, & + dl_u_bep, & + vl_bep,sf_bep + real(kind=kind_phys), dimension(ims:ime,jms:jme) , & optional , & - intent(inout) :: rqiblten + intent(in) :: frc_urb2d ! - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & optional , & intent(in ) :: ctopo, & ctopo2 +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !local integer :: i,j,k - real, dimension( its:ite, kts:kte*ndiff ) :: rqvbl2dt, & - qv2d - real, dimension( its:ite, kts:kte ) :: pdh - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite ) :: & - dusfc, & - dvsfc, & - dtsfc, & - dqsfc - -! - qv2d(its:ite,:) = 0.0 -! - do j = jts,jte - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo - - do k = kts,kte - do i = its,ite - qv2d(i,k) = qv3d(i,k,j) - qv2d(i,k+kte) = qc3d(i,k,j) - if(present(rqiblten)) qv2d(i,k+kte+kte) = qi3d(i,k,j) - enddo - enddo -! - call ysu2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j) & - ,tx=t3d(ims,kms,j) & - ,qx=qv2d(its,kts) & - ,p2d=pdh(its,kts),p2di=pdhi(its,kts) & - ,pi2d=pi3d(ims,kms,j) & - ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j) & - ,ttnp=rthblten(ims,kms,j),qtnp=rqvbl2dt(its,kts),ndiff=ndiff & - ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & - ,xlv=xlv,rv=rv & - ,ep1=ep1,ep2=ep2,karman=karman & - ,dz8w2d=dz8w(ims,kms,j) & - ,psfcpa=psfc(ims,j),znt=znt(ims,j),ust=ust(ims,j) & - ,hpbl=hpbl(ims,j) & - ,regime=regime(ims,j),psim=psim(ims,j) & - ,psih=psih(ims,j),xland=xland(ims,j) & - ,hfx=hfx(ims,j),qfx=qfx(ims,j) & - ,wspd=wspd(ims,j),br=br(ims,j) & - ,dusfc=dusfc,dvsfc=dvsfc,dtsfc=dtsfc,dqsfc=dqsfc & - ,dt=dt,rcl=1.0,kpbl1d=kpbl2d(ims,j) & - ,exch_hx=exch_h(ims,kms,j) & - ,exch_mx=exch_m(ims,kms,j) & - ,wstar=wstar(ims,j) & - ,delta=delta(ims,j) & - ,u10=u10(ims,j),v10=v10(ims,j) & - ,uox=uoce(ims,j),vox=voce(ims,j) & - ,rthraten=rthraten(ims,kms,j),p2diORG=p3di(ims,kms,j) & - ,ysu_topdown_pblmix=ysu_topdown_pblmix & - ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j) & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & - ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) -! - do k = kts,kte - do i = its,ite - rthblten(i,k,j) = rthblten(i,k,j)/pi3d(i,k,j) - rqvblten(i,k,j) = rqvbl2dt(i,k) - rqcblten(i,k,j) = rqvbl2dt(i,k+kte) - if(present(rqiblten)) rqiblten(i,k,j) = rqvbl2dt(i,k+kte+kte) - enddo - enddo -! - enddo -! - end subroutine ysu -! -!------------------------------------------------------------------------------- -! - subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & - utnp,vtnp,ttnp,qtnp,ndiff, & - cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & - dz8w2d,psfcpa, & - znt,ust,hpbl,psim,psih, & - xland,hfx,qfx,wspd,br, & - dusfc,dvsfc,dtsfc,dqsfc, & - dt,rcl,kpbl1d, & - exch_hx,exch_mx, & - wstar,delta, & - u10,v10, & - uox,vox, & - rthraten,p2diORG, & - ysu_topdown_pblmix, & - ctopo,ctopo2, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - !optional - regime & - ) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! -! this code is a revised vertical diffusion package ("ysupbl") -! with a nonlocal turbulent mixing in the pbl after "mrfpbl". -! the ysupbl (hong et al. 2006) is based on the study of noh -! et al.(2003) and accumulated realism of the behavior of the -! troen and mahrt (1986) concept implemented by hong and pan(1996). -! the major ingredient of the ysupbl is the inclusion of an explicit -! treatment of the entrainment processes at the entrainment layer. -! this routine uses an implicit approach for vertical flux -! divergence and does not require "miter" timesteps. -! it includes vertical diffusion in the stable atmosphere -! and moist vertical diffusion in clouds. -! -! mrfpbl: -! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) -! fall 1996 -! -! ysupbl: -! coded by song-you hong (yonsei university) and implemented by -! song-you hong (yonsei university) and jimy dudhia (ncar) -! summer 2002 -! -! further modifications : -! an enhanced stable layer mixing, april 2008 -! ==> increase pbl height when sfc is stable (hong 2010) -! pressure-level diffusion, april 2009 -! ==> negligible differences -! implicit forcing for momentum with clean up, july 2009 -! ==> prevents model blowup when sfc layer is too low -! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 -! ==> prevents model blowup when delz is extremely large -! revised prandtl number at surface, peggy lemone, feb 2010 -! ==> increase kh, decrease mixing due to counter-gradient term -! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 -! ==> reduce the thermal strength when z1 < 0.1 h -! revised prandtl number for free convection, dudhia, mar 2012 -! ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced -! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 -! ==> weaker mixing when stable, and les resolution in vertical -! gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012 -! ==> consider thermal z0 when differs from mechanical z0 -! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 -! ==> wscale becomes small with height, and less mixing in stable bl -! revision in background diffusion (kzo), jan 2016 -! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for -! internal wave mixing of large et al. (1994), songyou hong, feb 2016 -! ==> alleviate superious excessive mixing when delz is large -! -! references: -! -! hong (2010) quart. j. roy. met. soc -! hong, noh, and dudhia (2006), mon. wea. rev. -! hong and pan (1996), mon. wea. rev. -! noh, chun, hong, and raasch (2003), boundary layer met. -! troen and mahrt (1986), boundary layer met. -! -!------------------------------------------------------------------------------- -! - real,parameter :: xkzminm = 0.1,xkzminh = 0.01 - real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. - real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. - real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 - real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 - real,parameter :: phifac = 8.,sfcfrac = 0.1 - real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 - real,parameter :: h1 = 0.33333335, h2 = 0.6666667 - real,parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. - real,parameter :: tmin=1.e-2 - real,parameter :: gamcrt = 3.,gamcrq = 2.e-3 - real,parameter :: xka = 2.4e-5 - integer,parameter :: imvdif = 1 -! - integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - j,ndiff - - integer, intent(in) :: ysu_topdown_pblmix -! - real, intent(in ) :: dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv -! - real, intent(in ) :: ep1,ep2,karman -! - real, dimension( ims:ime, kms:kme ), & - intent(in) :: dz8w2d, & - pi2d, & - p2diorg -! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: tx - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(in ) :: qx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: utnp, & - vtnp, & - ttnp - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(inout) :: qtnp -! - real, dimension( its:ite, kts:kte+1 ) , & - intent(in ) :: p2di -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: p2d -! - real, dimension( ims:ime ) , & - intent(inout) :: ust, & - hpbl, & - znt - real, dimension( ims:ime ) , & - intent(in ) :: xland, & - hfx, & - qfx -! - real, dimension( ims:ime ), intent(inout) :: wspd - real, dimension( ims:ime ), intent(in ) :: br -! - real, dimension( ims:ime ), intent(in ) :: psim, & - psih -! - real, dimension( ims:ime ), intent(in ) :: psfcpa - integer, dimension( ims:ime ), intent(out ) :: kpbl1d -! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: ux, & - vx, & - rthraten - real, dimension( ims:ime ) , & - optional , & - intent(in ) :: ctopo, & - ctopo2 - real, dimension( ims:ime ) , & - optional , & - intent(inout) :: regime -! -! local vars -! - real, dimension( its:ite ) :: hol - real, dimension( its:ite, kts:kte+1 ) :: zq -! - real, dimension( its:ite, kts:kte ) :: & - thx,thvx,thlix, & - del, & - dza, & - dzq, & - xkzom, & - xkzoh, & - za -! - real, dimension( its:ite ) :: & - rhox, & - govrth, & - zl1,thermal, & - wscale, & - hgamt,hgamq, & - brdn,brup, & - phim,phih, & - dusfc,dvsfc, & - dtsfc,dqsfc, & - prpbl, & - wspd1,thermalli -! - real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & - f1,f2, & - r1,r2, & - ad,au, & - cu, & - al, & - xkzq, & - zfac, & - rhox2, & - hgamt2 -! -!jdf added exch_hx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: exch_hx, & - exch_mx -! - real, dimension( ims:ime ) , & - intent(inout) :: u10, & - v10 - real, dimension( ims:ime ) , & - intent(in ) :: uox, & - vox - real, dimension( its:ite ) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro -! - real, dimension( its:ite, kts:kte, ndiff) :: r3,f3 - integer, dimension( its:ite ) :: kpbl,kpblold -! - logical, dimension( its:ite ) :: pblflg, & - sfcflg, & - stable, & - cloudflg - logical :: definebrup -! - integer :: n,i,k,l,ic,is,kk - integer :: klpbl, ktrace1, ktrace2, ktrace3 -! -! - real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 - real :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri - real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz - real :: utend,vtend,ttend,qtend - real :: dtstep,govrthv - real :: cont, conq, conw, conwrc -! +!temporary allocation of local chemical species and/or passive tracers that are vertically- +!mixed in subroutine bl_ysu_run: + integer, parameter :: nmix = 0 + integer :: n + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: qmix + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: rqmixblten - real, dimension( its:ite, kts:kte ) :: wscalek,wscalek2 - real, dimension( ims:ime ) :: wstar - real, dimension( ims:ime ) :: delta - real, dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & - zfacent,entfac - real, dimension( its:ite ) :: ust3, & - wstar3, & - wstar3_2, & - hgamu,hgamv, & - wm2, we, & - bfxpbl, & - hfxpbl,qfxpbl, & - ufxpbl,vfxpbl, & - dthvx - real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & - dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & - prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & - rcldb,bruptmp,radflux,vconvlim,vconvnew,fluxc,vconvc,vconv -!topo-corr - real, dimension( ims:ime, kms:kme ) :: fric, & - tke_ysu,& - el_ysu,& - shear_ysu,& - buoy_ysu - real, dimension( ims:ime ) :: pblh_ysu,& - vconvfx -! -!------------------------------------------------------------------------------- -! - klpbl = kte -! - cont=cp/g - conq=xlv/g - conw=1./g - conwrc = conw*sqrt(rcl) - conpr = bfac*karman*sfcfrac -! -! k-start index for tracer diffusion -! - ktrace1 = 0 - ktrace2 = 0 + kte - ktrace3 = 0 + kte*2 -! - do k = kts,kte - do i = its,ite - thx(i,k) = tx(i,k)/pi2d(i,k) - thlix(i,k) = (tx(i,k)-xlv*qx(i,ktrace2+k)/cp-2.834E6*qx(i,ktrace3+k)/cp)/pi2d(i,k) - enddo - enddo -! - do k = kts,kte - do i = its,ite - tvcon = (1.+ep1*qx(i,k)) - thvx(i,k) = thx(i,k)*tvcon - enddo - enddo -! - do i = its,ite - tvcon = (1.+ep1*qx(i,1)) - rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) - govrth(i) = g/thx(i,1) - enddo -! -!-----compute the height of full- and half-sigma levels above ground -! level, and the layer thicknesses. -! - do i = its,ite - zq(i,1) = 0. - enddo -! - do k = kts,kte - do i = its,ite - zq(i,k+1) = dz8w2d(i,k)+zq(i,k) - tvcon = (1.+ep1*qx(i,k)) - rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) - enddo - enddo -! - do k = kts,kte - do i = its,ite - za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - enddo - enddo -! - do i = its,ite - dza(i,1) = za(i,1) - enddo -! - do k = kts+1,kte - do i = its,ite - dza(i,k) = za(i,k)-za(i,k-1) - enddo - enddo -! -! -!-----initialize vertical tendencies and -! - utnp(its:ite,:) = 0. - vtnp(its:ite,:) = 0. - ttnp(its:ite,:) = 0. - qtnp(its:ite,:) = 0. -! - do i = its,ite - wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9 - enddo -! -!---- compute vertical diffusion -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! compute preliminary variables -! - dtstep = dt - dt2 = 2.*dtstep - rdt = 1./dt2 -! - do i = its,ite - bfxpbl(i) = 0.0 - hfxpbl(i) = 0.0 - qfxpbl(i) = 0.0 - ufxpbl(i) = 0.0 - vfxpbl(i) = 0.0 - hgamu(i) = 0.0 - hgamv(i) = 0.0 - delta(i) = 0.0 - wstar3_2(i) = 0.0 - enddo -! - do k = kts,klpbl - do i = its,ite - wscalek(i,k) = 0.0 - wscalek2(i,k) = 0.0 - enddo - enddo -! - do k = kts,klpbl - do i = its,ite - zfac(i,k) = 0.0 - enddo - enddo - do k = kts,klpbl-1 - do i = its,ite - xkzom(i,k) = xkzminm - xkzoh(i,k) = xkzminh - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - enddo -! - do i = its,ite - hgamt(i) = 0. - hgamq(i) = 0. - wscale(i) = 0. - kpbl(i) = 1 - hpbl(i) = zq(i,1) - zl1(i) = za(i,1) - thermal(i)= thvx(i,1) - thermalli(i) = thlix(i,1) - pblflg(i) = .true. - sfcflg(i) = .true. - sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) - if(br(i).gt.0.0) sfcflg(i) = .false. - enddo -! -! compute the first guess of pbl height -! - do i = its,ite - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! - do i = its,ite - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - enddo -! - do i = its,ite - fm = psim(i) - fh = psih(i) - zol1(i) = max(br(i)*fm*fm/fh,rimin) - if(sfcflg(i))then - zol1(i) = min(zol1(i),-zfmin) - else - zol1(i) = max(zol1(i),zfmin) - endif - hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac - if(sfcflg(i))then - phim(i) = (1.-aphi16*hol1)**(-1./4.) - phih(i) = (1.-aphi16*hol1)**(-1./2.) - bfx0 = max(sflux(i),0.) - hfx0 = max(hfx(i)/rhox(i)/cp,0.) - qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) - wstar3(i) = (govrth(i)*bfx0*hpbl(i)) - wstar(i) = (wstar3(i))**h1 - else - phim(i) = (1.+aphi5*hol1) - phih(i) = phim(i) - wstar(i) = 0. - wstar3(i) = 0. - endif - ust3(i) = ust(i)**3. - wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 - wscale(i) = min(wscale(i),ust(i)*aphi16) - wscale(i) = max(wscale(i),ust(i)/aphi5) - enddo -! -! compute the surface variables for pbl height estimation -! under unstable conditions -! - do i = its,ite - if(sfcflg(i).and.sflux(i).gt.0.0)then - gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) - hgamq(i) = min(gamfac*qfx(i),gamcrq) - vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac - thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) - thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) - hgamt(i) = max(hgamt(i),0.0) - hgamq(i) = max(hgamq(i),0.0) - brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) - hgamu(i) = brint*ux(i,1) - hgamv(i) = brint*vx(i,1) - else - pblflg(i) = .false. - endif - enddo -! -! enhance the pbl height by considering the thermal -! - do i = its,ite - if(pblflg(i))then - kpbl(i) = 1 - hpbl(i) = zq(i,1) - endif - enddo -! - do i = its,ite - if(pblflg(i))then - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - endif - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i).and.pblflg(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! -! enhance pbl by theta-li -! - if (ysu_topdown_pblmix.eq.1)then - do i = its,ite - kpblold(i) = kpbl(i) - definebrup=.false. - do k = kpblold(i), kte-1 - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 - stable(i) = bruptmp.ge.brcr(i) - if (definebrup) then - kpbl(i) = k - brup(i) = bruptmp - definebrup=.false. - endif - if (.not.stable(i)) then !overwrite brup brdn values - brdn(i)=bruptmp - definebrup=.true. - pblflg(i)=.true. - endif - enddo - enddo - endif + ! Local tile-sized arrays for contiguous data for bl_ysu_run call. - do i = its,ite - if(pblflg(i)) then - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -! -! stable boundary layer -! - do i = its,ite - if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then - brup(i) = br(i) - stable(i) = .false. - else - stable(i) = .true. - endif - enddo -! - do i = its,ite - if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then - wspd10 = u10(i)*u10(i) + v10(i)*v10(i) - wspd10 = sqrt(wspd10) - ross = wspd10 / (cori*znt(i)) - brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) - endif - enddo -! - do i = its,ite - if(.not.stable(i))then - if((xland(i)-1.5).ge.0)then - brcr(i) = brcr_sbro(i) - else - brcr(i) = brcr_sb - endif - endif - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! - do i = its,ite - if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -! -! estimate the entrainment parameters -! - do i = its,ite - cloudflg(i)=.false. - if(pblflg(i)) then - k = kpbl(i) - 1 - wm3 = wstar3(i) + 5. * ust3(i) - wm2(i) = wm3**h2 - bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) - if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then - if ( kpbl(i) .ge. 2) then - cloudflg(i)=.true. - templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) - temps=templ + ((qx(i,k)+qx(i,ktrace2+k))-rvls)/(cp/xlv + & - ep2*xlv*rvls/(rd*templ**2)) - rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) - rcldb=max((qx(i,k)+qx(i,ktrace2+k))-rvls,0.) - !entrainment efficiency - dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2)+qx(i,ktrace2+k+2))) & - - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k) +qx(i,ktrace2+k))) - dthvx(i) = max(dthvx(i),0.1) - tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) - ent_eff = 0.2 * 8. * tmp1 +0.2 + real(kind=kind_phys), dimension(its:ite,kts:kte,nmix) :: & + qmix_hv , & + rqmixblten_hv - radsum=0. - do kk = 1,kpbl(i)-1 - radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s - radflux=radflux*cp/g*(p2diORG(i,kk)-p2diORG(i,kk+1)) ! converts temp/s to W/m^2 - if (radflux < 0.0 ) radsum=abs(radflux)+radsum - enddo - radsum=max(radsum,0.0) + real(kind=kind_phys), dimension(its:ite,kts:kte) :: & + u3d_hv , & + v3d_hv , & + t3d_hv , & + qv3d_hv , & + qc3d_hv , & + qi3d_hv , & + p3d_hv , & + pi3d_hv , & + rublten_hv , & + rvblten_hv , & + rthblten_hv , & + rqvblten_hv , & + rqcblten_hv , & + rqiblten_hv , & + dz8w_hv , & + exch_h_hv , & + exch_m_hv , & + rthraten_hv - !recompute entrainment from sfc thermals - bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) - bfx0 = max(sflux(i),0.0) - wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) - wm2(i) = wm3**h2 - bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + real(kind=kind_phys), dimension(its:ite,kts:kte) :: & + a_u_hv , & + a_v_hv , & + a_t_hv , & + a_e_hv , & + b_u_hv , & + a_q_hv , & + b_q_hv , & + b_v_hv , & + b_t_hv , & + b_e_hv , & + dlg_hv , & + dl_u_hv , & + vlk_hv , & + sfk_hv + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: & + p3di_hv - !entrainment from PBL top thermals - bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) - bfx0 = max(radsum/rhox2(i,k)/cp,0.) - wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) - wm2(i) = wm2(i)+wm3**h2 - bfxpbl(i) = - ent_eff * bfx0 - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) - we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + real(kind=kind_phys), dimension(its:ite) :: & + psfc_hv , & + znt_hv , & + ust_hv , & + hpbl_hv , & + psim_hv , & + psih_hv , & + xland_hv , & + hfx_hv , & + qfx_hv , & + wspd_hv , & + br_hv , & + wstar_hv , & + delta_hv , & + u10_hv , & + v10_hv , & + uoce_hv , & + voce_hv , & + ctopo_hv , & + ctopo2_hv - !wstar3_2 - bfx0 = max(radsum/rhox2(i,k)/cp,0.) - wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) - !recompute hgamt - wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 - wscale(i) = min(wscale(i),ust(i)*aphi16) - wscale(i) = max(wscale(i),ust(i)/aphi5) - gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) - hgamq(i) = min(gamfac*qfx(i),gamcrq) - gamfac = bfac/rhox2(i,k)/wscale(i) - hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) - hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) - brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) - hgamu(i) = brint*ux(i,1) - hgamv(i) = brint*vx(i,1) - endif - endif - prpbl(i) = 1.0 - dthx = max(thx(i,k+1)-thx(i,k),tmin) - dqx = min(qx(i,k+1)-qx(i,k),0.0) - hfxpbl(i) = we(i)*dthx - qfxpbl(i) = we(i)*dqx -! - dux = ux(i,k+1)-ux(i,k) - dvx = vx(i,k+1)-vx(i,k) - if(dux.gt.tmin) then - ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) - elseif(dux.lt.-tmin) then - ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) - else - ufxpbl(i) = 0.0 - endif - if(dvx.gt.tmin) then - vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) - elseif(dvx.lt.-tmin) then - vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) - else - vfxpbl(i) = 0.0 - endif - delb = govrth(i)*d3*hpbl(i) - delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) - endif - enddo -! - do k = kts,klpbl - do i = its,ite - if(pblflg(i).and.k.ge.kpbl(i))then - entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. - else - entfac(i,k) = 1.e30 - endif - enddo - enddo -! -! compute diffusion coefficients below pbl -! - do k = kts,klpbl - do i = its,ite - if(k.lt.kpbl(i)) then - zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) - zfacent(i,k) = (1.-zfac(i,k))**3. - wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 - wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 - if(sfcflg(i)) then - prfac = conpr - prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) - prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. - else - prfac = 0. - prfac2 = 0. - prnumfac = 0. - phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) - wscalek(i,k) = ust(i)/phim8z - wscalek(i,k) = max(wscalek(i,k),0.001) - endif - prnum0 = (phih(i)/phim(i)+prfac) - prnum0 = max(min(prnum0,prmax),prmin) - xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & - wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac - !Do not include xkzm at kpbl-1 since it changes entrainment - if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then - xkzm(i,k) = 0.0 - endif - prnum = 1. + (prnum0-1.)*exp(prnumfac) - xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) - prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) - prnum = 1. + (prnum0-1.)*exp(prnumfac) - xkzh(i,k) = xkzm(i,k)/prnum - xkzm(i,k) = xkzm(i,k)+xkzom(i,k) - xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) - xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzq(i,k) = min(xkzq(i,k),xkzmax) - endif - enddo - enddo -! -! compute diffusion coefficients over pbl (free atmosphere) -! - do k = kts,kte-1 - do i = its,ite - if(k.ge.kpbl(i)) then - ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & - +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & - /(dza(i,k+1)*dza(i,k+1))+1.e-9 - govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) - ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) - if(imvdif.eq.1.and.ndiff.ge.3)then - if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.(qx(i & - ,ktrace2+k+1)+qx(i,ktrace3+k+1)).gt.0.01e-3)then -! in cloud - qmean = 0.5*(qx(i,k)+qx(i,k+1)) - tmean = 0.5*(tx(i,k)+tx(i,k+1)) - alph = xlv*qmean/rd/tmean - chi = xlv*xlv*qmean/cp/rv/tmean/tmean - ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) - endif - endif - zk = karman*zq(i,k+1) - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - rl2 = (zk*rlamdz/(rlamdz+zk))**2 - dk = rl2*sqrt(ss) - if(ri.lt.0.)then -! unstable regime - ri = max(ri, rimin) - sri = sqrt(-ri) - xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) - xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) - else -! stable regime - xkzh(i,k) = dk/(1+5.*ri)**2 - prnum = 1.0+2.1*ri - prnum = min(prnum,prmax) - xkzm(i,k) = xkzh(i,k)*prnum - endif -! - xkzm(i,k) = xkzm(i,k)+xkzom(i,k) - xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzml(i,k) = xkzm(i,k) - xkzhl(i,k) = xkzh(i,k) - endif - enddo - enddo -! -! compute tridiagonal matrix elements for heat -! - do k = kts,kte - do i = its,ite - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - enddo - enddo -! - do i = its,ite - ad(i,1) = 1. - f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzh(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzt - f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) - xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - f1(i,k+1) = thx(i,k+1)-300. - else - f1(i,k+1) = thx(i,k+1)-300. - endif - tem1 = dsig*xkzh(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - enddo - enddo -! - call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) -! -! recover tendencies of heat -! - do k = kte,kts,-1 - do i = its,ite - ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) - ttnp(i,k) = ttnp(i,k)+ttend - dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) - enddo - enddo -! -! compute tridiagonal matrix elements for moisture, clouds, and gases -! - do k = kts,kte - do i = its,ite - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - enddo - enddo -! - do ic = 1,ndiff - do i = its,ite - do k = kts,kte - f3(i,k,ic) = 0. - enddo - enddo - enddo -! - do i = its,ite - ad(i,1) = 1. - f3(i,1,1) = qx(i,1)+qfx(i)*g/del(i,1)*dt2 - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do i = its,ite - f3(i,1,ic) = qx(i,1+is) - enddo - enddo - endif -! - do k = kts,kte-1 - do i = its,ite - if(k.ge.kpbl(i)) then - xkzq(i,k) = xkzh(i,k) - endif - enddo - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzq(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) - f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq - f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) - xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) - xkzq(i,k) = min(xkzq(i,k),xkzmax) - f3(i,k+1,1) = qx(i,k+1) - else - f3(i,k+1,1) = qx(i,k+1) - endif - tem1 = dsig*xkzq(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) -! exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do k = kts,kte-1 - do i = its,ite - f3(i,k+1,ic) = qx(i,k+1+is) - enddo - enddo - enddo - endif -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - enddo - enddo -! - do ic = 1,ndiff - do k = kts,kte - do i = its,ite - r3(i,k,ic) = f3(i,k,ic) - enddo - enddo - enddo -! -! solve tridiagonal problem for moisture, clouds, and gases -! - call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) -! -! recover tendencies of heat and moisture -! - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,1)-qx(i,k))*rdt - qtnp(i,k) = qtnp(i,k)+qtend - dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,ic)-qx(i,k+is))*rdt - qtnp(i,k+is) = qtnp(i,k+is)+qtend - enddo - enddo - enddo - endif -! -! compute tridiagonal matrix elements for momentum -! - do i = its,ite - do k = kts,kte - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - f2(i,k) = 0. - enddo - enddo -! -! paj: ctopo=1 if topo_wind=0 (default) -!raquel---paj tke code (could be replaced with shin-hong tke in future - do i = its,ite - do k= kts, kte-1 - shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) & - + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1)) - buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1)) + integer, dimension(its:ite) :: & + kpbl2d_hv + real, dimension(its:ite) :: & + frcurb_hv - zk = karman*zq(i,k+1) - !over pbl - if (k.ge.kpbl(i)) then - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - else - !in pbl - rlamdz = 150.0 - endif - el_ysu(i,k) = zk*rlamdz/(rlamdz+zk) - tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k)) - !q2 when q3 positive - if(tke_ysu(i,k).le.0) then - tke_ysu(i,k)=0.0 - else - tke_ysu(i,k)=(tke_ysu(i,k))**0.66 - endif - enddo - !Hybrid pblh of MYNN - !tke is q2 - CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),& - & tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i)) -!--- end of paj tke -! compute vconv -! Use Beljaars over land - if (xland(i).lt.1.5) then - fluxc = max(sflux(i),0.0) - vconvc=1. - VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33 - else -! for water there is no topo effect so vconv not needed - VCONV = 0. - endif - vconvfx(i) = vconv -!raquel -!ctopo stability correction - fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - if(present(ctopo)) then - vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0)) - vconvlim = min(vconvnew,1.0) - ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim) - else - ad(i,1) = 1.+fric(i,1) - endif - f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzm(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i))then - dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) - dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzu - f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu - f2(i,k) = f2(i,k)+dtodsd*dsdzv - f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzm(i,k) = prpbl(i)*xkzh(i,k) - xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) - xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - f1(i,k+1) = ux(i,k+1) - f2(i,k+1) = vx(i,k+1) - else - f1(i,k+1) = ux(i,k+1) - f2(i,k+1) = vx(i,k+1) - endif - tem1 = dsig*xkzm(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_mx(i,k+1) = xkzm(i,k) - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - r2(i,k) = f2(i,k) - enddo - enddo -! -! solve tridiagonal problem for momentum -! - call tridi1n(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) -! -! recover tendencies of momentum -! - do k = kte,kts,-1 - do i = its,ite - utend = (f1(i,k)-ux(i,k))*rdt - vtend = (f2(i,k)-vx(i,k))*rdt - utnp(i,k) = utnp(i,k)+utend - vtnp(i,k) = vtnp(i,k)+vtend - dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) - dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) - enddo - enddo -! -! paj: ctopo2=1 if topo_wind=0 (default) -! - do i = its,ite - if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM - u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) - v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) - endif !mchen - enddo -! -!---- end of vertical diffusion -! - do i = its,ite - kpbl1d(i) = kpbl(i) - enddo -! - end subroutine ysu2d -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: its,ite, kts,kte, nt -! - real, dimension( its:ite, kts+1:kte+1 ) , & - intent(in ) :: cl -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: cm, & - r1 - real, dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 -! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: au, & - cu, & - f1 - real, dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do i = its,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - f1(i,1) = fk*r1(i,1) - enddo -! - do it = 1,nt - do i = its,l - fk = 1./cm(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo -! - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) - enddo - enddo -! - do it = 1,nt - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) - enddo - enddo - enddo -! - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) - enddo -! - do it = 1,nt - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) - enddo - enddo -! - do k = n-1,kts,-1 - do i = its,l - f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) - enddo - enddo -! - do it = 1,nt - do k = n-1,kts,-1 - do i = its,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridi1n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: its,ite, kts,kte, nt -! - real, dimension( its:ite, kts+1:kte+1 ) , & - intent(in ) :: cl -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: cm - real, dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 -! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: au, & - cu - real, dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do it = 1,nt - do i = its,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo -! - do it = 1,nt - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) - enddo - enddo - enddo -! - do it = 1,nt - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) - enddo - enddo -! - do it = 1,nt - do k = n-1,kts,-1 - do i = its,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridin_ysu -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine ysuinit(rublten,rvblten,rthblten,rqvblten, & - rqcblten,rqiblten,p_qi,p_first_scalar, & - restart, 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) :: restart, allowed_to_read - 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_qi,p_first_scalar - real , dimension( ims:ime , kms:kme , jms:jme ), intent(out) :: & - rublten, & - rvblten, & - rthblten, & - rqvblten, & - rqcblten, & - rqiblten - 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 - rublten(i,k,j) = 0. - rvblten(i,k,j) = 0. - rthblten(i,k,j) = 0. - rqvblten(i,k,j) = 0. - rqcblten(i,k,j) = 0. - enddo - enddo - enddo - endif -! - if (p_qi .ge. p_first_scalar .and. .not.restart) then - do j = jts,jtf - do k = kts,ktf - do i = its,itf - rqiblten(i,k,j) = 0. - enddo - enddo - enddo - endif + do j = jts,jte ! - end subroutine ysuinit -!------------------------------------------------------------------------------- -! ================================================================== - - SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea) -! Copied from MYNN PBL - - !--------------------------------------------------------------- - ! NOTES ON THE PBLH FORMULATION - ! - !The 1.5-theta-increase method defines PBL heights as the level at - !which the potential temperature first exceeds the minimum potential - !temperature within the boundary layer by 1.5 K. When applied to - !observed temperatures, this method has been shown to produce PBL- - !height estimates that are unbiased relative to profiler-based - !estimates (Nielsen-Gammon et al. 2008). However, their study did not - !include LLJs. Banta and Pichugina (2008) show that a TKE-based - !threshold is a good estimate of the PBL height in LLJs. Therefore, - !a hybrid definition is implemented that uses both methods, weighting - !the TKE-method more during stable conditions (PBLH < 400 m). - !A variable tke threshold (TKEeps) is used since no hard-wired - !value could be found to work best in all conditions. - !--------------------------------------------------------------- + ! Assign input data to local tile-sized arrays. - INTEGER,INTENT(IN) :: KTS,KTE - REAL, INTENT(OUT) :: zi - REAL, INTENT(IN) :: landsea - REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D - REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D - !LOCAL VARS - REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv - REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !Theta-v PBL lower limit of trust (m). - REAL, PARAMETER :: sbl_damp = 400. !Damping range for averaging with TKE-based PBLH (m). - INTEGER :: I,J,K,kthv,ktke + do n = 1, nmix + do k = kts, kte + do i = its, ite + qmix_hv(i,k,n) = qmix(i,k,j,n) + end do + end do + end do - !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M - k = kts+1 - kthv = 1 - ktke = 1 - maxqke = 0. - minthv = 9.E9 + do k = kts, kte+1 + do i = its, ite + p3di_hv(i,k) = p3di(i,k,j) + end do + end do - DO WHILE (zw1D(k) .LE. 500.) - qtke =MAX(Qke1D(k),0.) ! maximum QKE - IF (maxqke < qtke) then - maxqke = qtke - ktke = k - ENDIF - IF (minthv > thetav1D(k)) then - minthv = thetav1D(k) - kthv = k - ENDIF - k = k+1 - ENDDO - !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.025) - TKEeps = MIN(TKEeps,0.25) + do k = kts, kte + do i = its, ite + u3d_hv(i,k) = u3d(i,k,j) + v3d_hv(i,k) = v3d(i,k,j) + t3d_hv(i,k) = t3d(i,k,j) + qv3d_hv(i,k) = qv3d(i,k,j) + qc3d_hv(i,k) = qc3d(i,k,j) + qi3d_hv(i,k) = qi3d(i,k,j) + p3d_hv(i,k) = p3d(i,k,j) + pi3d_hv(i,k) = pi3d(i,k,j) + dz8w_hv(i,k) = dz8w(i,k,j) + rthraten_hv(i,k) = rthraten(i,k,j) + end do + end do - !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). - zi=0. - k = kthv+1 - IF((landsea-1.5).GE.0)THEN - ! WATER - delt_thv = 0.75 - ELSE - ! LAND - delt_thv = 1.5 - ENDIF - - zi=0. - k = kthv+1 - DO WHILE (zi .EQ. 0.) - IF (thetav1D(k) .GE. (minthv + delt_thv))THEN - zi = zw1D(k) - dz1D(k-1)* & - & MIN((thetav1D(k)-(minthv + delt_thv))/MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0) - ENDIF - k = k+1 - IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO + if(present(a_u_bep) .and. present(a_v_bep) .and. present(a_t_bep) .and. & + present(a_q_bep) .and. present(a_e_bep) .and. present(b_u_bep) .and. & + present(b_v_bep) .and. present(b_t_bep) .and. present(b_q_bep) .and. & + present(b_e_bep) .and. present(dlg_bep) .and. present(dl_u_bep) .and. & + present(sf_bep) .and. present(vl_bep) .and. present(frc_urb2d)) then + do k = kts, kte + do i = its,ite + a_u_hv(i,k) = a_u_bep(i,k,j) + a_v_hv(i,k) = a_v_bep(i,k,j) + a_t_hv(i,k) = a_t_bep(i,k,j) + a_q_hv(i,k) = a_q_bep(i,k,j) + a_e_hv(i,k) = a_e_bep(i,k,j) + b_u_hv(i,k) = b_u_bep(i,k,j) + b_v_hv(i,k) = b_v_bep(i,k,j) + b_t_hv(i,k) = b_t_bep(i,k,j) + b_q_hv(i,k) = b_q_bep(i,k,j) + b_e_hv(i,k) = b_e_bep(i,k,j) + dlg_hv(i,k) = dlg_bep(i,k,j) + dl_u_hv(i,k) = dl_u_bep(i,k,j) + vlk_hv(i,k) = vl_bep(i,k,j) + sfk_hv(i,k) = sf_bep(i,k,j) + enddo + enddo + do i = its, ite + frcurb_hv(i) = frc_urb2d(i,j) + enddo + endif - !print*,"IN GET_PBLH:",thsfc,zi - !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE - !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM). - !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE - !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM. - !FIND TKE-BASED PBLH (BEST FOR NOCTURNAL/STABLE CONDITIONS). + do i = its, ite + psfc_hv(i) = psfc(i,j) + znt_hv(i) = znt(i,j) + ust_hv(i) = ust(i,j) + wspd_hv(i) = wspd(i,j) + psim_hv(i) = psim(i,j) + psih_hv(i) = psih(i,j) + xland_hv(i) = xland(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + br_hv(i) = br(i,j) + u10_hv(i) = u10(i,j) + v10_hv(i) = v10(i,j) + uoce_hv(i) = uoce(i,j) + voce_hv(i) = voce(i,j) + ctopo_hv(i) = ctopo(i,j) + ctopo2_hv(i) = ctopo2(i,j) + end do +! + call bl_ysu_run(ux=u3d_hv,vx=v3d_hv & + ,tx=t3d_hv & + ,qvx=qv3d_hv,qcx=qc3d_hv,qix=qi3d_hv & + ,f_qc=flag_qc,f_qi=flag_qi & + ,nmix=nmix,qmix=qmix_hv & + ,p2d=p3d_hv,p2di=p3di_hv & + ,pi2d=pi3d_hv & + ,utnp=rublten_hv,vtnp=rvblten_hv & + ,ttnp=rthblten_hv,qvtnp=rqvblten_hv & + ,qctnp=rqcblten_hv,qitnp=rqiblten_hv & + ,qmixtnp=rqmixblten_hv & + ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & + ,xlv=xlv,rv=rv & + ,ep1=ep1,ep2=ep2,karman=karman & + ,dz8w2d=dz8w_hv & + ,psfcpa=psfc_hv,znt=znt_hv,ust=ust_hv & + ,hpbl=hpbl_hv & + ,psim=psim_hv & + ,psih=psih_hv,xland=xland_hv & + ,hfx=hfx_hv,qfx=qfx_hv & + ,wspd=wspd_hv,br=br_hv & + ,dt=dt,kpbl1d=kpbl2d_hv & + ,exch_hx=exch_h_hv & + ,exch_mx=exch_m_hv & + ,wstar=wstar_hv & + ,delta=delta_hv & + ,u10=u10_hv,v10=v10_hv & + ,uox=uoce_hv,vox=voce_hv & + ,rthraten=rthraten_hv & + ,ysu_topdown_pblmix=ysu_topdown_pblmix & + ,ctopo=ctopo_hv,ctopo2=ctopo2_hv & + ,a_u=a_u_hv,a_v=a_v_hv,a_t=a_t_hv,a_q=a_q_hv,a_e=a_e_hv & + ,b_u=b_u_hv,b_v=b_v_hv,b_t=b_t_hv,b_q=b_q_hv,b_e=b_e_hv & + ,sfk=sfk_hv,vlk=vlk_hv,dlu=dl_u_hv,dlg=dlg_hv,frcurb=frcurb_hv & + ,flag_bep=flag_bep & + ,its=its,ite=ite,kte=kte,kme=kme & + ,errmsg=errmsg,errflg=errflg ) +! + ! Assign local data back to full-sized arrays. + ! Only required for the INTENT(OUT) or INTENT(INOUT) arrays. - PBLH_TKE=0. - k = ktke+1 - DO WHILE (PBLH_TKE .EQ. 0.) - !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE. - qtke =MAX(Qke1D(k)/2.,0.) ! maximum TKE - qtkem1=MAX(Qke1D(k-1)/2.,0.) - IF (qtke .LE. TKEeps) THEN - PBLH_TKE = zw1D(k) - dz1D(k-1)* & - & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0) - !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL. - PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1)) - !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1) - ENDIF - k = k+1 - IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD - ENDDO + do n = 1, nmix + do k = kts, kte + do i = its, ite + rqmixblten(i,k,j,n) = rqmixblten_hv(i,k,n) + end do + end do + end do - !BLEND THE TWO PBLH TYPES HERE: + do k = kts, kte + do i = its, ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) +#if (NEED_B4B_DURING_CCPP_TESTING == 1) + rthblten(i,k,j) = rthblten_hv(i,k)/pi3d_hv(i,k) +#elif (NEED_B4B_DURING_CCPP_TESTING != 1) + rthblten(i,k,j) = rthblten_hv(i,k) +#endif + rqvblten(i,k,j) = rqvblten_hv(i,k) + rqcblten(i,k,j) = rqcblten_hv(i,k) + rqiblten(i,k,j) = rqiblten_hv(i,k) + exch_h(i,k,j) = exch_h_hv(i,k) + exch_m(i,k,j) = exch_m_hv(i,k) + end do + end do - wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - zi=PBLH_TKE*(1.-wt) + zi*wt + do i = its, ite + u10(i,j) = u10_hv(i) + v10(i,j) = v10_hv(i) + hpbl(i,j) = hpbl_hv(i) + kpbl2d(i,j) = kpbl2d_hv(i) + wstar(i,j) = wstar_hv(i) + delta(i,j) = delta_hv(i) + end do + enddo - END SUBROUTINE GET_PBLH -! ================================================================== + end subroutine ysu -end module module_bl_ysu -!------------------------------------------------------------------------------- +!================================================================================================================= + end module module_bl_ysu +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F index f798bf62ea..9f45378d9c 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F @@ -1,165 +1,38 @@ -!----------------------------------------------------------------------- -! -!wrf:model_layer:physics -! -!####################tiedtke scheme######################### -! m.tiedtke e.c.m.w.f. 1989 -! j.morcrette 1992 -!-------------------------------------------- -! modifications -! C. zhang & Yuqing Wang 2011-2017 -! -! modified from IPRC IRAM - yuqing wang, university of hawaii -! & ICTP REGCM4.4 -! -! The current version is stable. There are many updates to the old Tiedtke scheme (cu_physics=6) -! update notes: -! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. -! the major differences to the old Tiedtke (cu_physics=6) scheme are, -! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; -! Bechtold et al. 2004, 2008, 2014). -! (b) Non-equilibrium situations are considered in the closure for deep convection -! (Bechtold et al. 2014). -! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). -! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). -! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). -! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; -! Wu and Yanai 1994) -! -! other refenrence: tiedtke (1989, mwr, 117, 1779-1800) -! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 -! -!=========================================================== -! Note for climate simulation of Tropical Cyclones -! This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation -! schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km -! Set: momtrans = 2. -! pgcoef = 0.7 to 1.0 is good depends on the basin -! nonequil = .false. -!=========================================================== -! Note for the diurnal simulation of precipitaton -! When nonequil = .true., the CAPE is relaxed toward to a value from PBL -! It can improve the diurnal precipitation over land. -!=========================================================== -!########################################################### - -module module_cu_ntiedtke - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -#if defined(mpas) - use mpas_atmphys_constants, only: rd=>R_d, rv=>R_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g=>gravity -#else - use module_model_constants, only:rd=>r_d, rv=>r_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g -#endif - - implicit none - real,private :: t13,rcpd,vtmpc1,tmelt, & - c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg - - real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice - real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon,pgcoef - integer,private :: momtrans - - parameter( & - t13=1.0/3.0, & - rcpd=1.0/cpd, & - tmelt=273.16, & - zrg=1.0/g, & - c1es=610.78, & - c2es=c1es*rd/rv, & - c3les=17.2693882, & - c3ies=21.875, & - c4les=35.86, & - c4ies=7.66, & - c5les=c3les*(tmelt-c4les), & - c5ies=c3ies*(tmelt-c4ies), & - r5alvcp=c5les*alv*rcpd, & - r5alscp=c5ies*als*rcpd, & - ralvdcp=alv*rcpd, & - ralsdcp=als*rcpd, & - ralfdcp=alf*rcpd, & - rtwat=tmelt, & - rtber=tmelt-5., & - rtice=tmelt-23., & - vtmpc1=rv/rd-1.0 ) -! -! entrdd: average entrainment & detrainment rate for downdrafts -! ------ -! - parameter(entrdd = 2.0e-4) -! -! 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) - -! zdnoprc: deep cloud is thicker than this height (Unit:Pa) -! - parameter(zdnoprc = 2.0e4) -! ------- -! -! cprcon: coefficient from cloud water to rain water -! - parameter(cprcon = 1.4e-3) -! ------- -! -! momtrans: momentum transport method -! ( 1 = IFS40r1 method; 2 = new method ) -! - parameter(momtrans = 2 ) -! ------- -! -! coefficient for pressure gradient intensity -! (0.7 - 1.0 is recommended in this vesion of Tiedtke scheme) - parameter(pgcoef=0.7) -! ------- -! - logical :: nonequil -! nonequil: representing equilibrium and nonequilibrium convection -! ( .false. [equilibrium: removing all CAPE]; .true. [nonequilibrium: relaxing CAPE toward CAPE from PBL]. -! Ref. Bechtold et al. 2014 JAS ) -! - parameter(nonequil = .true. ) -! -!-------------------- -! switches for deep, mid, shallow convections, downdraft, and momentum transport -! ------------------ - logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv - parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) -!-------------------- -!#################### end of variables definition########################## -!----------------------------------------------------------------------- -! -contains -!----------------------------------------------------------------------- - subroutine cu_ntiedtke( & - dt,itimestep,stepcu & - ,raincv,pratec,qfx,hfx & - ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & - ,qvften,thften & - ,dz8w,pcps,p8w,xland,cu_act_flag,dx & - ,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 -!------------------------------------------------------------------- +!================================================================================================================= + module module_cu_ntiedtke + use mpas_kind_types,only: RKIND,StrKIND + + use cu_ntiedtke,only: cu_ntiedtke_run, & + cu_ntiedtke_init, & + cu_ntiedtke_timestep_init, & + cu_ntiedtke_timestep_final + use cu_ntiedtke_common + + implicit none + private + public:: cu_ntiedtke_driver, & + ntiedtkeinit + + + contains + + +!================================================================================================================= + subroutine cu_ntiedtke_driver( & + dt,itimestep,stepcu & + ,raincv,pratec,qfx,hfx & + ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & + ,qvften,thften & + ,dz8w,pcps,p8w,xland,cu_act_flag,dx & + ,f_qv,f_qc,f_qr,f_qi,f_qs & + ,grav,xlf,xls,xlv,rd,rv,cp & + ,rthcuten,rqvcuten,rqccuten,rqicuten & + ,rucuten,rvcuten & + ,ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte & + ,errmsg,errflg) +!================================================================================================================= !-- 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) @@ -210,3665 +83,275 @@ subroutine cu_ntiedtke( & !-- 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) :: & - dx - - 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, & - pcps, & - p8w, & - pi3d, & - qc3d, & - qvften, & - thften, & - qi3d, & - qv3d, & - rho3d, & - t3d, & - u3d, & - v3d, & - w - real, dimension(ims:ime, jms:jme) :: & - qfx, & - hfx - -!--------------------------- 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 - -!--------------------------- local vars ------------------------------ - real :: & - delt, & - rdelt - - real , dimension(its:ite) :: & - rcs, & - rn, & - evap, & - heatflux, & - dx2d - - integer , dimension(its:ite) :: slimsk - - - real , dimension(its:ite, kts:kte+1) :: & - prsi, & - ghti, & - zi - - real , dimension(its:ite, kts:kte) :: & - dot, & - prsl, & - q1, & - q2, & - q3, & - q1b, & - t1b, & - q11, & - q12, & - t1, & - u1, & - v1, & - zl, & - omg, & - ghtl - - integer, dimension(its:ite) :: & - kbot, & - ktop - - integer :: & - i, & - im, & - j, & - k, & - km, & - kp, & - kx, & - kx1 - -!-------other local variables---- - integer :: zz, pp -!----------------------------------------------------------------------- -! -! -!*** check to see if this is a convection timestep -! - -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - cu_act_flag(i,j)=.true. - enddo - enddo - - im=ite-its+1 - kx=kte-kts+1 - kx1=kx+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,kte - do i=its,ite - zi(i,k+1)=zi(i,k)+dz8w(i,k,j) - enddo - enddo -! - do k=kts,kte - do i=its,ite - zl(i,k)=0.5*(zi(i,k)+zi(i,k+1)) - enddo - enddo - -! --------------- end compute zi and zl ------------------------------------- - do i=its,ite - slimsk(i)=int(abs(xland(i,j)-2.)) - enddo - - do i=its,ite - dx2d(i) = dx(i,j) - 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 - - pp = 0 - do k=kts,kte - zz = kte-pp - 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. - t1b(i,zz)=0. - else - q1b(i,zz)=qvften(i,k,j) - t1b(i,zz)=thften(i,k,j) - endif - q2(i,zz)=qc3d(i,k,j) - q3(i,zz)=qi3d(i,k,j) - omg(i,zz)=dot(i,k) - ghtl(i,zz)=zl(i,k) - prsl(i,zz) = pcps(i,k,j) - enddo - pp = pp + 1 - enddo - - pp = 0 - do k=kts,kte+1 - zz = kte+1-pp - do i=its,ite - ghti(i,zz) = zi(i,k) - prsi(i,zz) = p8w(i,k,j) - enddo - pp = pp + 1 - enddo -! - do i=its,ite - evap(i) = qfx(i,j) - heatflux(i)= hfx(i,j) - enddo -! -!######################################################################## - call tiecnvn(u1,v1,t1,q1,q2,q3,q1b,t1b,ghtl,ghti,omg,prsl,prsi,evap,heatflux, & - rn,slimsk,im,kx,kx1,delt,dx2d) - - do i=its,ite - raincv(i,j)=rn(i)/stepcu - pratec(i,j)=rn(i)/(stepcu * dt) - enddo - - pp = 0 - do k=kts,kte - zz = kte-pp - 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 - pp = pp + 1 - enddo - - if(present(rqccuten))then - if ( f_qc ) then - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt - enddo - pp = pp + 1 +!----------------------------------------------------------------------------------------------------------------- + +!--- input arguments: + logical,intent(in),optional:: f_qv,f_qc,f_qr,f_qi,f_qs + + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: itimestep,stepcu + + real(kind=RKIND),intent(in):: cp,grav,rd,rv,xlf,xls,xlv + + real(kind=kind_phys),intent(in):: dt + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: dx,hfx,qfx,xland + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + pcps, & + p8w, & + pi3d, & + qc3d, & + qvften, & + thften, & + qi3d, & + qv3d, & + rho3d, & + t3d, & + u3d, & + v3d, & + w + +!--- inout arguments: + logical,intent(inout),dimension(ims:ime,jms:jme):: cu_act_flag + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: raincv, pratec + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + rqccuten, & + rqicuten, & + rqvcuten, & + rthcuten, & + rucuten, & + rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,im,j,k,kx,kx1 + integer,dimension(its:ite):: slimsk + + real(kind=kind_phys):: delt + real(kind=kind_phys),dimension(its:ite):: rn + real(kind=kind_phys),dimension(its:ite,kts:kte):: prsl,omg,ghtl + real(kind=kind_phys),dimension(its:ite,kts:kte):: uf,vf,tf,qvf,qcf,qif + real(kind=kind_phys),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: prsi,ghti,zi + + real(kind=kind_phys),dimension(its:ite):: dx_hv,hfx_hv,qfx_hv,xland_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: dz_hv,pi_hv,prsl_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,rho_hv,t_hv,u_hv,v_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qvften_hv,thften_hv + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: prsi_hv,w_hv + + real(kind=kind_phys),dimension(its:ite):: raincv_hv,pratec_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: rthcuten_hv,rqvcuten_hv,rqccuten_hv,rqicuten_hv, & + rucuten_hv,rvcuten_hv + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = ' ' + errflg = 0 + +!call cu_ntiedtke_init(cp,rd,rv,xlv,xls,xlf,grav,errmsg,errflg) + call cu_ntiedtke_init( & + con_cp = cp , con_rd = rd , con_rv = rv , con_xlv = xlv , & + con_xls = xls , con_xlf = xlf , con_grav = grav , errmsg = errmsg , & + errflg = errflg & + ) + + do j = jts,jte + do i = its,ite + cu_act_flag(i,j)=.true. + enddo + enddo + + do j = jts,jte + + do i = its,ite + dx_hv(i) = dx(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + xland_hv(i) = xland(i,j) + enddo + + do k = kts,kte + do i = its,ite + dz_hv(i,k) = dz8w(i,k,j) + pi_hv(i,k) = pi3d(i,k,j) + prsl_hv(i,k) = pcps(i,k,j) + qv_hv(i,k) = qv3d(i,k,j) + qc_hv(i,k) = qc3d(i,k,j) + qi_hv(i,k) = qi3d(i,k,j) + rho_hv(i,k) = rho3d(i,k,j) + t_hv(i,k) = t3d(i,k,j) + u_hv(i,k) = u3d(i,k,j) + v_hv(i,k) = v3d(i,k,j) + + qvften_hv(i,k) = qvften(i,k,j) + thften_hv(i,k) = thften(i,k,j) + enddo + enddo + do k = kts,kte+1 + do i = its,ite + prsi_hv(i,k) = p8w(i,k,j) + w_hv(i,k) = w(i,k,j) + enddo + enddo + + call cu_ntiedtke_timestep_init( & + its = its , ite = ite , kts = kts , kte = kte , & + im = im , kx = kx , kx1 = kx1 , itimestep = itimestep , & + stepcu = stepcu , dt = dt , grav = grav , xland = xland_hv , & + dz = dz_hv , pres = prsl_hv , presi = prsi_hv , t = t_hv , & + rho = rho_hv , qv = qv_hv , qc = qc_hv , qi = qi_hv , & + u = u_hv , v = v_hv , w = w_hv , qvften = qvften_hv , & + thften = thften_hv , qvftenz = qvftenz , thftenz = thftenz , slimsk = slimsk , & + delt = delt , prsl = prsl , ghtl = ghtl , tf = tf , & + qvf = qvf , qcf = qcf , qif = qif , uf = uf , & + vf = vf , prsi = prsi , ghti = ghti , omg = omg , & + errmsg = errmsg , errflg = errflg & + ) + + call cu_ntiedtke_run( & + pu = uf , pv = vf , pt = tf , pqv = qvf , & + pqc = qcf , pqi = qif , pqvf = qvftenz , ptf = thftenz , & + poz = ghtl , pzz = ghti , pomg = omg , pap = prsl , & + paph = prsi , evap = qfx_hv , hfx = hfx_hv , zprecc = rn , & + lndj = slimsk , lq = im , km = kx , km1 = kx1 , & + dt = delt , dx = dx_hv , errmsg = errmsg , errflg = errflg & + ) + + call cu_ntiedtke_timestep_final( & + its = its , ite = ite , kts = kts , kte = kte , & + stepcu = stepcu , dt = dt , exner = pi_hv , qv = qv_hv , & + qc = qc_hv , qi = qi_hv , t = t_hv , u = u_hv , & + v = v_hv , qvf = qvf , qcf = qcf , qif = qif , & + tf = tf , uf = uf , vf = vf , rn = rn , & + raincv = raincv_hv , pratec = pratec_hv , rthcuten = rthcuten_hv , rqvcuten = rqvcuten_hv , & + rqccuten = rqccuten_hv , rqicuten = rqicuten_hv , rucuten = rucuten_hv , rvcuten = rvcuten_hv , & + errmsg = errmsg , errflg = errflg & + ) + + do i = its,ite + raincv(i,j) = raincv_hv(i) + pratec(i,j) = pratec_hv(i) + enddo + + do k = kts,kte + do i = its,ite + rucuten(i,k,j) = rucuten_hv(i,k) + rvcuten(i,k,j) = rvcuten_hv(i,k) + rthcuten(i,k,j) = rthcuten_hv(i,k) + rqvcuten(i,k,j) = rqvcuten_hv(i,k) + enddo + enddo + + if(present(rqccuten))then + if(f_qc) then + do k = kts,kte + do i = its,ite + rqccuten(i,k,j) = rqccuten_hv(i,k) + enddo enddo - endif - endif - - if(present(rqicuten))then - if ( f_qi ) then - pp = 0 - do k=kts,kte - zz = kte-pp - do i=its,ite - rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt - enddo - pp = pp + 1 + endif + endif + + if(present(rqicuten))then + if(f_qi) then + do k = kts,kte + do i = its,ite + rqicuten(i,k,j) = rqicuten_hv(i,k) + enddo enddo - endif - endif - - - enddo - - end subroutine cu_ntiedtke - -!==================================================================== - subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & - rucuten,rvcuten,rthften,rqvften, & - 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,& - rthften,rqvften - - 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 - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - rthften(i,k,j)=0. - rqvften(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 ntiedtkeinit - -!----------------------------------------------------------------- -! level 1 subroutine 'tiecnvn' -!----------------------------------------------------------------- - subroutine tiecnvn(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & - & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx) -!----------------------------------------------------------------- -! this is the interface between the model and the mass -! flux convection module -!----------------------------------------------------------------- - implicit none -! - real pu(lq,km), pv(lq,km), pt(lq,km), pqv(lq,km) - real poz(lq,km), pomg(lq,km), evap(lq), zprecc(lq) - real pzz(lq,km1) - - real pum1(lq,km), pvm1(lq,km), ztt(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), & - & prsfc(lq), pssfc(lq), pcte(lq,km), & - & phhfl(lq), hfx(lq), pgeoh(lq,km1) - 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 pqvf(lq,km), ptf(lq,km) - real dx(lq) - - integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) - logical locum(lq) -! - real ztmst,fliq,fice,ztc,zalf,tt - integer i,j,k,lq,km,km1 - real dt,ztpp1 - real zew,zqs,zcor -! - ztmst=dt -! -! masv flux diagnostics. -! - do j=1,lq - zrain(j)=0.0 - locum(j)=.false. - prsfc(j)=0.0 - pssfc(j)=0.0 - pqhfl(j)=evap(j) - phhfl(j)=hfx(j) - pgeoh(j,km1)=g*pzz(j,km1) - end do -! -! convert model variables for mflux scheme -! - do k=1,km - do j=1,lq - 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) - pgeoh(j,k)=g*pzz(j,k) - tt=ztp1(j,k) - zew = foeewm(tt) - zqs = zew/pap(j,k) - zqs = min(0.5,zqs) - zcor = 1./(1.-vtmpc1*zqs) - zqsat(j,k)=zqs*zcor - pqte(j,k)=pqvf(j,k) - zqq(j,k) =pqte(j,k) - ptte(j,k)=ptf(j,k) - ztt(j,k) =ptte(j,k) - end do - end do -! -!----------------------------------------------------------------------- -!* 2. call 'cumastrn'(master-routine for cumulus parameterization) -! - call cumastrn & - & (lq, km, km1, km-1, ztp1, & - & zqp1, pum1, pvm1, pverv, zqsat,& - & pqhfl, ztmst, pap, paph, pgeo, & - & ptte, pqte, pvom, pvol, prsfc,& - & pssfc, locum, & - & ktype, icbot, ictop, ztu, zqu, & - & zlu, zlude, zmfu, zmfd, zrain,& - & pcte, phhfl, lndj, pgeoh, dx) -! -! to include the cloud water and cloud ice detrained from convection -! - do k=1,km - do j=1,lq - if(pcte(j,k).gt.0.) then - fliq=foealfa(ztp1(j,k)) - 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 - endif - end do - end do -! - do k=1,km - do j=1,lq - pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(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)) - end do - end do - - do j=1,lq - zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) - end do - - if (lmfdudv) then - do k=1,km - do j=1,lq - pu(j,k)=pu(j,k)+pvom(j,k)*ztmst - pv(j,k)=pv(j,k)+pvol(j,k)*ztmst - end do - end do - endif -! - return - end subroutine tiecnvn - -!############################################################# -! -! level 2 subroutines -! -!############################################################# -!*********************************************************** -! subroutine cumastrn -!*********************************************************** - subroutine cumastrn & - & (klon, klev, klevp1, klevm1, pten, & - & pqen, puen, pven, pverv, pqsen,& - & pqhfl, ztmst, pap, paph, pgeo, & - & ptte, pqte, pvom, pvol, prsfc,& - & pssfc, ldcum, & - & ktype, kcbot, kctop, ptu, pqu,& - & plu, plude, pmfu, pmfd, prain,& - & pcte, phhfl, lndj, zgeoh, dx) - implicit none -! -!***cumastrn* master routine for cumulus massflux-scheme -! m.tiedtke e.c.m.w.f. 1986/1987/1989 -! modifications -! y.wang i.p.r.c 2001 -! c.zhang 2012 -!***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. -!***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 'cuinin' -! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, -! and specify cloud base massflux -! (4) do cloud ascent in 'cuascn' in absence of downdrafts -! (5) do downdraft calculations: -! (a) determine values at lfs in 'cudlfsn' -! (b) determine moist descent in 'cuddrafn' -! (c) recalculate cloud base massflux considering the -! effect of cu-downdrafts -! (6) do final adjusments to convective fluxes in 'cuflxn', -! do evaporation in subcloud layer -! (7) calculate increments of t and q in 'cudtdqn' -! (8) calculate increments of u and v in 'cududvn' -!***externals. -! ---------- -! cuinin: initializes values at vertical grid used in cu-parametr. -! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus -! cuascn: cloud ascent for entraining plume -! cudlfsn: determines values at lfs for downdrafts -! cuddrafn:does moist descent for cumulus downdrafts -! cuflxn: final adjustments to convective fluxes (also in pbl) -! cudqdtn: updates tendencies for t and q -! cududvn: updates tendencies for u and v -!***switches. -! -------- -! 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) -! ------------------------------------------------ -! entrdd entrainment rate for cumulus downdrafts -! 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) -!----------------------------------------------------------------- - integer klev,klon,klevp1,klevm1 - 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),& - & phhfl(klon) - real ptu(klon,klev), pqu(klon,klev),& - & plu(klon,klev), plude(klon,klev),& - & pmfu(klon,klev), pmfd(klon,klev),& - & prain(klon),& - & prsfc(klon), pssfc(klon) - real ztenh(klon,klev), zqenh(klon,klev),& - & zgeoh(klon,klevp1), 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),& - & zlglac(klon,klev) - real pmflxr(klon,klevp1), pmflxs(klon,klevp1) - real zhcbase(klon),& - & zmfub(klon), zmfub1(klon),& - & zdhpbl(klon) - real zsfl(klon), zdpmel(klon,klev),& - & pcte(klon,klev), zcape(klon),& - & zcape1(klon), zcape2(klon),& - & ztauc(klon), ztaubl(klon),& - & zheat(klon) - real wup(klon), zdqcv(klon) - real wbase(klon), zmfuub(klon) - real upbl(klon) - real dx(klon) - real pmfude_rate(klon,klev), pmfdde_rate(klon,klev) - real zmfuus(klon,klev), zmfdus(klon,klev) - real zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) - real zmfuvb(klon),zsum12(klon),zsum22(klon) - integer ilab(klon,klev), idtop(klon),& - & ictop0(klon), ilwmin(klon) - integer kdpl(klon) - integer kcbot(klon), kctop(klon),& - & ktype(klon), lndj(klon) - logical ldcum(klon) - logical loddraf(klon), llo1, llo2(klon) - -! local varaiables - real zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax - real zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat - real zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed - integer jl,jk,ik - integer ikb,ikt,icum,itopm2 - real ztmst,ztau,zerate,zderate,zmfa - real zmfs(klon),pmean(klev),zlon - real zduten,zdvten,ztdis,pgf_u,pgf_v -!------------------------------------------- -! 1. specify constants and parameters -!------------------------------------------- - zcons=1./(g*ztmst) - zcons2=3./(g*ztmst) - -!-------------------------------------------------------------- -!* 2. initialize values at vertical grid points in 'cuini' -!-------------------------------------------------------------- - call cuinin & - & (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 -!---------------------------------- -!* (a) determine cloud base values in 'cutypen', -! and the cumulus type 1 or 2 -! ------------------------------------------- - call cutypen & - & ( klon, klev, klevp1, klevm1, pqen,& - & ztenh, zqenh, zqsenh, zgeoh, paph,& - & phhfl, pqhfl, pgeo, pqsen, pap,& - & pten, lndj, ptu, pqu, ilab,& - & ldcum, kcbot, ictop0, ktype, wbase, plu, kdpl) - -!* (b) assign the first guess mass flux at cloud base -! ------------------------------------------ - do jl=1,klon - zdhpbl(jl)=0.0 - upbl(jl) = 0.0 - idtop(jl)=0 - end do - - do jk=2,klev - do jl=1,klon - if(jk.ge.kcbot(jl) .and. ldcum(jl)) then - zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& - & *(paph(jl,jk+1)-paph(jl,jk)) - if(lndj(jl) .eq. 0) then - wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) - upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) - end if - end if - end do - end do - - do jl=1,klon - if(ldcum(jl)) then - ikb=kcbot(jl) - zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 - if(ktype(jl) == 1) then - zmfub(jl)= 0.1*zmfmax - else if ( ktype(jl) == 2 ) then - zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) - zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) - zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe - zdh = g*max(zdh,1.e5*zdqmin) - if ( zdhpbl(jl) > 0. ) then - zmfub(jl) = zdhpbl(jl)/zdh - zmfub(jl) = min(zmfub(jl),zmfmax) - else - zmfub(jl) = 0.1*zmfmax - ldcum(jl) = .false. - end if - end if - else - zmfub(jl) = 0. - end if - end do -!------------------------------------------------------ -!* 4.0 determine cloud ascent for entraining plume -!------------------------------------------------------ -!* (a) do ascent in 'cuasc'in absence of downdrafts -!---------------------------------------------------------- - call cuascn & - & (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,& - & zmfus, zmfuq, zmful, plude, zdmfup,& - & kcbot, kctop, ictop0, icum, ztmst,& - & zqsenh, zlglac, lndj, wup, wbase, kdpl, pmfude_rate ) - -!* (b) check cloud depth and change entrainment rate accordingly -! calculate precipitation rate (for downdraft calculation) -!------------------------------------------------------------------ - do jl=1,klon - if ( ldcum(jl) ) then - ikb = kcbot(jl) - itopm2 = kctop(jl) - zpbmpt = paph(jl,ikb) - paph(jl,itopm2) - if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 - if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 - ictop0(jl) = kctop(jl) - end if - zrfl(jl)=zdmfup(jl,1) - end do - - do jk=2,klev - do jl=1,klon - zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) - end do - end do - - do jk = 1,klev - do jl = 1,klon - pmfd(jl,jk) = 0. - zmfds(jl,jk) = 0. - zmfdq(jl,jk) = 0. - zdmfdp(jl,jk) = 0. - zdpmel(jl,jk) = 0. - end do - end do - -!----------------------------------------- -!* 6.0 cumulus downdraft calculations -!----------------------------------------- - if(lmfdd) then -!* (a) determine lfs in 'cudlfsn' -!-------------------------------------- - call cudlfsn & - & (klon, klev,& - & kcbot, kctop, lndj, ldcum, & - & ztenh, zqenh, puen, pven, & - & pten, pqsen, pgeo, & - & zgeoh, paph, ptu, pqu, plu, & - & zuu, zvu, zmfub, zrfl, & - & ztd, zqd, zud, zvd, & - & pmfd, zmfds, zmfdq, zdmfdp, & - & idtop, loddraf) -!* (b) determine downdraft t,q and fluxes in 'cuddrafn' -!------------------------------------------------------------ - call cuddrafn & - & ( klon, klev, loddraf, & - & ztenh, zqenh, puen, pven, & - & pgeo, zgeoh, paph, zrfl, & - & ztd, zqd, zud, zvd, pmfu, & - & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate ) -!----------------------------------------------------------- - end if -! -!----------------------------------------------------------------------- -!* 6.0 closure and clean work -! ------ -!-- 6.1 recalculate cloud base massflux from a cape closure -! for deep convection (ktype=1) -! - do jl=1,klon - if(ldcum(jl) .and. ktype(jl) .eq. 1) then - ikb = kcbot(jl) - ikt = kctop(jl) - zheat(jl)=0.0 - zcape(jl)=0.0 - zcape1(jl)=0.0 - zcape2(jl)=0.0 - zmfub1(jl)=zmfub(jl) - - ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & - ((2.+ min(15.0,wup(jl)))*g) - if(lndj(jl) .eq. 0) then - upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) - ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) - ztaubl(jl) = min(300., ztaubl(jl)) - else - ztaubl(jl) = ztauc(jl) - end if - end if - end do -! - do jk = 1 , klev - do jl = 1 , klon - llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 - if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then - ikb = kcbot(jl) - zdz = pgeo(jl,jk-1)-pgeo(jl,jk) - zdp = pap(jl,jk)-pap(jl,jk-1) - zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & - ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & - (g*(pmfu(jl,jk)+pmfd(jl,jk))) - zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & - vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp - end if - - if ( llo1 .and. jk >= kcbot(jl) ) then - if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then - zdp = paph(jl,jk+1)-paph(jl,jk) - zcape2(jl) = zcape2(jl) + ztaubl(jl)* & - ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp - end if - end if - end do - end do - - do jl=1,klon - if(ldcum(jl).and.ktype(jl).eq.1) then - ikb = kcbot(jl) - ikt = kctop(jl) - ztau = ztauc(jl) * (1.+1.33e-5*dx(jl)) - ztau = max(ztmst,ztau) - ztau = max(360.,ztau) - ztau = min(10800.,ztau) - if(nonequil) then - zcape2(jl)= max(0.,zcape2(jl)) - zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) - else - zcape(jl) = max(0.,min(zcape1(jl),5000.)) - end if - zheat(jl) = max(1.e-4,zheat(jl)) - zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) - zmfub1(jl) = max(zmfub1(jl),0.001) - zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 - zmfub1(jl)=min(zmfub1(jl),zmfmax) - end if - end do -! -!* 6.2 recalculate convective fluxes due to effect of -! downdrafts on boundary layer moist static energy budget (ktype=2) -!-------------------------------------------------------- - do jl=1,klon - if(ldcum(jl) .and. ktype(jl) .eq. 2) then - ikb=kcbot(jl) - if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then - zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) - 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),cmfcmin) - zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 -! using moist static engergy closure instead of moisture closure - zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & - & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe - zdh=g*max(zdh,1.e5*zdqmin) - if(zdhpbl(jl).gt.0.)then - zmfub1(jl)=zdhpbl(jl)/zdh - else - zmfub1(jl) = zmfub(jl) - end if - zmfub1(jl) = min(zmfub1(jl),zmfmax) - end if - -!* 6.3 mid-level convection - nothing special -!--------------------------------------------------------- - if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then - zmfub1(jl) = zmfub(jl) - end if - - end do - -!* 6.4 scaling the downdraft mass flux -!--------------------------------------------------------- - do jk=1,klev - do jl=1,klon - if( ldcum(jl) ) then - zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) - 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 - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac - end if - end do - end do - -!* 6.5 scaling the updraft mass flux -! -------------------------------------------------------- - do jl = 1,klon - if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) - end do - do jk = 2 , klev - do jl = 1,klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - ikb = kcbot(jl) - if ( jk>ikb ) then - zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) - pmfu(jl,jk) = pmfu(jl,ikb)*zdz - end if - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then - zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) - end if - end if - end do - end do - do jk = 2 , klev - do jl = 1,klon - if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then - pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) - zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) - zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) - zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) - plude(jl,jk) = plude(jl,jk)*zmfs(jl) - pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) - end if - end do - end do - -!* 6.6 if ktype = 2, kcbot=kctop is not allowed -! --------------------------------------------------- - do jl = 1,klon - if ( ktype(jl) == 2 .and. & - kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then - ldcum(jl) = .false. - ktype(jl) = 0 - end if - end do - - if ( .not. lmfscv .or. .not. lmfpen ) then - do jl = 1,klon - llo2(jl) = .false. - if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & - (.not. lmfpen .and. ktype(jl) == 1) ) then - llo2(jl) = .true. - ldcum(jl) = .false. - end if - end do - end if - -!* 6.7 set downdraft mass fluxes to zero above cloud top -!---------------------------------------------------- - do jl = 1,klon - if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then - idtop(jl) = kctop(jl) + 1 - end if - end do - do jk = 2 , klev - do jl = 1,klon - if ( loddraf(jl) ) then - if ( jk < idtop(jl) ) then - pmfd(jl,jk) = 0. - zmfds(jl,jk) = 0. - zmfdq(jl,jk) = 0. - pmfdde_rate(jl,jk) = 0. - zdmfdp(jl,jk) = 0. - else if ( jk == idtop(jl) ) then - pmfdde_rate(jl,jk) = 0. - end if - end if - end do - end do -!---------------------------------------------------------- -!* 7.0 determine final convective fluxes in 'cuflx' -!---------------------------------------------------------- - call cuflxn & - & ( klon, klev, ztmst & - & , pten, pqen, pqsen, ztenh, zqenh & - & , paph, pap, zgeoh, lndj, ldcum & - & , kcbot, kctop, idtop, itopm2 & - & , ktype, loddraf & - & , pmfu, pmfd, zmfus, zmfds & - & , zmfuq, zmfdq, zmful, plude & - & , zdmfup, zdmfdp, zdpmel, zlglac & - & , prain, pmfdde_rate, pmflxr, pmflxs ) - -! some adjustments needed - do jl=1,klon - zmfs(jl) = 1. - zmfuub(jl)=0. - end do - do jk = 2 , klev - do jl = 1,klon - if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then - zmfmax = pmfu(jl,jk)*0.98 - if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then - zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) - end if - end if - end do - end do - - do jk = 2 , klev - do jl = 1 , klon - if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then - pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) - zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) - zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) - zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) - pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) - zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) - end if - end do - end do - - do jk = 2 , klev - 1 - do jl = 1, klon - if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then - zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) - if ( zerate < 0. ) then - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate - end if - end if - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) - if ( zerate < 0. ) then - pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate - end if - zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & - pmflxr(jl,jk) - pmflxs(jl,jk) - zdmfdp(jl,jk) = 0. - end if - end do - end do - -! avoid negative humidities at ddraught top - do jl = 1,klon - if ( loddraf(jl) ) then - jk = idtop(jl) - ik = min(jk+1,klev) - if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then - zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) - end if - end if - end do - -! avoid negative humidities near cloud top because gradient of precip flux -! and detrainment / liquid water flux are too large - do jk = 2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then - zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) - zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & - zmfuq(jl,jk) - zmfdq(jl,jk) + & - zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) - zmfa = (zmfa-plude(jl,jk))*zdz - if ( pqen(jl,jk)+zmfa < 0. ) then - plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz - end if - if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. - end if - if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. - if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. - end do - end do - - do jl=1,klon - prsfc(jl) = pmflxr(jl,klev+1) - pssfc(jl) = pmflxs(jl,klev+1) - end do - -!---------------------------------------------------------------- -!* 8.0 update tendencies for t and q in subroutine cudtdq -!---------------------------------------------------------------- - call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & - ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & - zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & - zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) -!---------------------------------------------------------------- -!* 9.0 update tendencies for u and u in subroutine cududv -!---------------------------------------------------------------- - if(lmfdudv) then - do jk = klev-1 , 2 , -1 - ik = jk + 1 - do jl = 1,klon - if ( ldcum(jl) ) then - if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then - ikb = kdpl(jl) - zuu(jl,jk) = puen(jl,ikb-1) - zvu(jl,jk) = pven(jl,ikb-1) - else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then - zuu(jl,jk) = puen(jl,jk-1) - zvu(jl,jk) = pven(jl,jk-1) - end if - if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then - if(momtrans .eq. 1)then - zfac = 0. - if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. - if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. - zerate = pmfu(jl,jk) - pmfu(jl,ik) + & - (1.+zfac)*pmfude_rate(jl,jk) - zderate = (1.+zfac)*pmfude_rate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & - zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa - zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & - zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa - else - pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& - pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) - pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& - pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) - zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) - zderate = pmfude_rate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & - zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa - zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & - zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa - end if - end if - end if - end do - end do - - if(lmfdd) then - do jk = 3 , klev - ik = jk - 1 - do jl = 1,klon - if ( ldcum(jl) ) then - if ( jk == idtop(jl) ) then - zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) - zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) - else if ( jk > idtop(jl) ) then - zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) - zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) - zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & - zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa - zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & - zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa - end if - end if - end do - end do - end if -! -------------------------------------------------- -! rescale massfluxes for stability in Momentum -!------------------------------------------------------------------------ - zmfs(:) = 1. - do jk = 2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons - if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then - zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) - end if - end if - end do - end do - do jk = 1 , klev - do jl = 1, klon - zmfuus(jl,jk) = pmfu(jl,jk) - zmfdus(jl,jk) = pmfd(jl,jk) - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) - end if - end do - end do -!* 9.1 update u and v in subroutine cududvn -!------------------------------------------------------------------- - do jk = 1 , klev - do jl = 1, klon - ztenu(jl,jk) = pvom(jl,jk) - ztenv(jl,jk) = pvol(jl,jk) - end do - end do - - call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & - ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & - zud,zvu,zvd,pvom,pvol) - -! calculate KE dissipation - do jl = 1, klon - zsum12(jl) = 0. - zsum22(jl) = 0. - end do - do jk = 1 , klev - do jl = 1, klon - zuv2(jl,jk) = 0. - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zdz = (paph(jl,jk+1)-paph(jl,jk)) - zduten = pvom(jl,jk) - ztenu(jl,jk) - zdvten = pvol(jl,jk) - ztenv(jl,jk) - zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) - zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz - zsum12(jl) = zsum12(jl) - & - (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz - end if - end do - end do - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then - ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) - ptte(jl,jk) = ptte(jl,jk) + ztdis - end if - end do - end do - - end if - -!---------------------------------------------------------------------- -!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF -! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO -! --------------------------------------------------- - if ( .not. lmfscv .or. .not. lmfpen ) then - do jk = 2 , klev - do jl = 1, klon - if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then - ptu(jl,jk) = pten(jl,jk) - pqu(jl,jk) = pqen(jl,jk) - plu(jl,jk) = 0. - pmfude_rate(jl,jk) = 0. - pmfdde_rate(jl,jk) = 0. - end if - end do - end do - do jl = 1, klon - if ( llo2(jl) ) then - kctop(jl) = klev - 1 - kcbot(jl) = klev - 1 - end if - end do - end if - - return - end subroutine cumastrn - -!********************************************** -! level 3 subroutine cuinin -!********************************************** -! - subroutine cuinin & - & (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) - implicit none -! 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 -! ---------------------------------------------------------------- - integer klon,klev,klevp1,klevm1 - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & pqsen(klon,klev), pverv(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klevp1),& - & 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) -! local variables - integer jl,jk - integer icall,ik - real zzs -!------------------------------------------------------------ -!* 1. specify large scale parameters at half levels -!* adjust temperature fields if staticly unstable -!* find level of maximum vertical velocity -! ----------------------------------------------------------- - do jk=2,klev - do jl=1,klon - ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & - & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd - pqenh(jl,jk) = pqen(jl,jk-1) - pqsenh(jl,jk)= pqsen(jl,jk-1) - zph(jl)=paph(jl,jk) - loflag(jl)=.true. - end do - - if ( jk >= klev-1 .or. jk < 2 ) cycle - ik=jk - icall=0 - call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) - do 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.) - end do - end do - - do 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) - klwmin(jl)=klev - zwmax(jl)=0. - end do - - do jk=klevm1,2,-1 - do 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 - end do - end do - - do jk=klev,3,-1 - do jl=1,klon - if(pverv(jl,jk).lt.zwmax(jl)) then - zwmax(jl)=pverv(jl,jk) - klwmin(jl)=jk - end if - end do - end do -!----------------------------------------------------------- -!* 2.0 initialize values for updrafts and downdrafts -!----------------------------------------------------------- - do jk=1,klev - ik=jk-1 - if(jk.eq.1) ik=1 - do 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) - klab(jl,jk)=0 - end do - end do - return - end subroutine cuinin - -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cutypen & - & ( klon, klev, klevp1, klevm1, pqen,& - & ptenh, pqenh, pqsenh, pgeoh, paph,& - & hfx, qfx, pgeo, pqsen, pap,& - & pten, lndj, cutu, cuqu, culab,& - & ldcum, cubot, cutop, ktype, wbase, culu, kdpl ) -! zhang & wang iprc 2011-2013 -!***purpose. -! -------- -! to produce first guess updraught for cu-parameterizations -! calculates condensation level, and sets updraught base variables and -! first guess cloud type -!***interface -! --------- -! this routine is called from *cumastr*. -! input are environm. values of t,q,p,phi at half levels. -! it returns cloud types as follows; -! ktype=1 for deep cumulus -! ktype=2 for shallow cumulus -!***method. -! -------- -! based on a simplified updraught equation -! partial(hup)/partial(z)=eta(h - hup) -! eta is the entrainment rate for test parcel -! h stands for dry static energy or the total water specific humidity -! references: christian jakob, 2003: a new subcloud model for -! mass-flux convection schemes -! influence on triggering, updraft properties, and model -! climate, mon.wea.rev. -! 131, 2765-2778 -! and -! ifs documentation - cy36r1,cy38r1 -!***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) -! rho - density of the lowest model level -! qfx - net upward moisture flux at the surface (kg/m^2/s) -! hfx - net upward heat flux at the surface (w/m^2) -!***variables output by cutype: -! ktype - convection type - 1: penetrative (cumastr) -! 2: stratocumulus (cumastr) -! 3: mid-level (cuasc) -! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) -! ---------------------------------------------------------------- -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - integer klon, klev, klevp1, klevm1 - real ptenh(klon,klev), pqenh(klon,klev),& - & pqsen(klon,klev), pqsenh(klon,klev),& - & pgeoh(klon,klevp1), paph(klon,klevp1),& - & pap(klon,klev), pqen(klon,klev) - real pten(klon,klev) - real ptu(klon,klev),pqu(klon,klev),plu(klon,klev) - real pgeo(klon,klev) - integer klab(klon,klev) - integer kctop(klon),kcbot(klon) - - real qfx(klon),hfx(klon) - real zph(klon) - integer lndj(klon) - logical loflag(klon), deepflag(klon), resetflag(klon) - -! output variables - real cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) - integer culab(klon,klev) - real wbase(klon) - integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) - logical ldcum(klon) - -! local variables - real zqold(klon) - real rho, part1, part2, root, conw, deltt, deltq - real eta(klon),dz(klon),coef(klon) - real dhen(klon,klev), dh(klon,klev) - real plude(klon,klev) - real kup(klon,klev) - real vptu(klon,klev),vten(klon,klev) - real zbuo(klon,klev),abuoy(klon,klev) - - real zz,zdken,zdq - real fscale,crirh1,pp - real atop1,atop2,abot - real tmix,zmix,qmix,pmix - real zlglac,dp - integer nk,is,ikb,ikt - - real zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp - real zpdifftop, zpdiffbot - integer zcbase(klon), itoppacel(klon) - integer jl,jk,ik,icall,levels - logical needreset, lldcum(klon) -!-------------------------------------------------------------- - do jl=1,klon - kcbot(jl)=klev - kctop(jl)=klev - kdpl(jl) =klev - ktype(jl)=0 - wbase(jl)=0. - ldcum(jl)=.false. - end do - -!----------------------------------------------------------- -! let's do test,and check the shallow convection first -! the first level is klev -! define deltat and deltaq -!----------------------------------------------------------- - do jk=1,klev - do jl=1,klon - plu(jl,jk)=culu(jl,jk) ! parcel liquid water - ptu(jl,jk)=cutu(jl,jk) ! parcel temperature - pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity - klab(jl,jk)=culab(jl,jk) - dh(jl,jk)=0.0 ! parcel dry static energy - dhen(jl,jk)=0.0 ! environment dry static energy - kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading - vten(jl,jk)=0.0 ! environment virtual temperature - zbuo(jl,jk)=0.0 ! parcel buoyancy - abuoy(jl,jk)=0.0 - end do - end do - - do jl=1,klon - zqold(jl) = 0. - lldcum(jl) = .false. - loflag(jl) = .true. - end do - -! check the levels from lowest level to second top level - do jk=klevm1,2,-1 - -! define the variables at the first level - if(jk .eq. klevm1) then - do jl=1,klon - rho=pap(jl,klev)/ & - & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) - part1 = 1.5*0.4*pgeo(jl,klev)/ & - & (rho*pten(jl,klev)) - part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) - root = 0.001-part1*part2 - if(part2 .lt. 0.) then - conw = 1.2*(root)**t13 - deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) - deltq = max(1.5*qfx(jl)/(rho*conw),0.) - kup(jl,klev) = 0.5*(conw**2) - pqu(jl,klev)= pqenh(jl,klev) + deltq - dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd - dh(jl,klev) = dhen(jl,klev) + deltt*cpd - ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd - vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) - vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) - zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) - klab(jl,klev) = 1 - else - loflag(jl) = .false. - end if - end do - end if - - is=0 - do jl=1,klon - if(loflag(jl))then - is=is+1 - endif - enddo - if(is.eq.0) exit - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(loflag(jl)) then - eta(jl) = 0.8/(pgeo(jl,jk)*zrg)+2.e-4 - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= 0.5*eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& - & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) - pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& - & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) - ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd - zqold(jl) = pqu(jl,jk) - zph(jl)=paph(jl,jk) - end if - end do -! check if the parcel is saturated - ik=jk - icall=1 - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - do jl=1,klon - if( loflag(jl) ) then - zdq = max((zqold(jl) - pqu(jl,jk)),0.) - plu(jl,jk) = plu(jl,jk+1) + zdq - zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & - (1.-foealfa(ptu(jl,jk+1)))) - plu(jl,jk) = min(plu(jl,jk),5.e-3) - dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) -! compute the updraft speed - vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& - ralfdcp*zlglac - vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) - abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g - atop1 = 1.0 - 2.*coef(jl) - atop2 = 2.0*dz(jl)*abuoy(jl,jk) - abot = 1.0 + 2.*coef(jl) - kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot - -! let's find the exact cloud base - if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then - ik = jk + 1 - zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) - zqsu = min(0.5,zqsu) - zcor = 1./(1.-vtmpc1*zqsu) - zqsu = zqsu*zcor - zdq = min(0.,pqu(jl,ik)-zqsu) - zalfaw = foealfa(ptu(jl,ik)) - zfacw = c5les/((ptu(jl,ik)-c4les)**2) - zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) - zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci - zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) - zcor = 1./(1.-vtmpc1*zesdp) - zdqsdt = zfac*zcor*zqsu - zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) - zdp = zdq/(zdqsdt*zdtdp) - zcbase(jl) = paph(jl,ik) + zdp -! chose nearest half level as cloud base (jk or jk+1) - zpdifftop = zcbase(jl) - paph(jl,jk) - zpdiffbot = paph(jl,jk+1) - zcbase(jl) - if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then - ikb = min(klev-1,jk+1) - klab(jl,ikb) = 2 - klab(jl,jk) = 2 - kcbot(jl) = ikb - plu(jl,jk+1) = 1.0e-8 - else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then - klab(jl,jk) = 2 - kcbot(jl) = jk - end if - end if - - if(kup(jl,jk) .lt. 0.)then - loflag(jl) = .false. - if(plu(jl,jk+1) .gt. 0.) then - kctop(jl) = jk - lldcum(jl) = .true. - else - lldcum(jl) = .false. - end if - else - if(plu(jl,jk) .gt. 0.)then - klab(jl,jk)=2 - else - klab(jl,jk)=1 - end if - end if - end if - end do - - end do ! end all the levels - - do jl=1,klon - ikb = kcbot(jl) - ikt = kctop(jl) - if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. - if(lldcum(jl)) then - ktype(jl) = 2 - ldcum(jl) = .true. - wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) - cubot(jl) = ikb - cutop(jl) = ikt - kdpl(jl) = klev - else - cutop(jl) = -1 - cubot(jl) = -1 - kdpl(jl) = klev - 1 - ldcum(jl) = .false. - wbase(jl) = 0. - end if - end do - - do jk=klev,1,-1 - do jl=1,klon - ikt = kctop(jl) - if(jk .ge. ikt)then - culab(jl,jk) = klab(jl,jk) - cutu(jl,jk) = ptu(jl,jk) - cuqu(jl,jk) = pqu(jl,jk) - culu(jl,jk) = plu(jl,jk) - end if - end do - end do - -!----------------------------------------------------------- -! next, let's check the deep convection -! the first level is klevm1-1 -! define deltat and deltaq -!---------------------------------------------------------- -! we check the parcel starting level by level -! assume the mix-layer is 60hPa - deltt = 0.2 - deltq = 1.0e-4 - do jl=1,klon - deepflag(jl) = .false. - end do - - do jk=klev,1,-1 - do jl=1,klon - if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk - end do - end do - - do levels=klevm1-1,klev/2+1,-1 ! loop starts - do jk=1,klev - do jl=1,klon - plu(jl,jk)=0.0 ! parcel liquid water - ptu(jl,jk)=0.0 ! parcel temperature - pqu(jl,jk)=0.0 ! parcel specific humidity - dh(jl,jk)=0.0 ! parcel dry static energy - dhen(jl,jk)=0.0 ! environment dry static energy - kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading - vten(jl,jk)=0.0 ! environment virtual temperature - abuoy(jl,jk)=0.0 - zbuo(jl,jk)=0.0 - klab(jl,jk)=0 - end do - end do - - do jl=1,klon - kcbot(jl) = levels - kctop(jl) = levels - zqold(jl) = 0. - lldcum(jl) = .false. - resetflag(jl)= .false. - loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) - end do - -! start the inner loop to search the deep convection points - do jk=levels,2,-1 - is=0 - do jl=1,klon - if(loflag(jl))then - is=is+1 - endif - enddo - if(is.eq.0) exit - -! define the variables at the departure level - if(jk .eq. levels) then - do jl=1,klon - if(loflag(jl)) then - if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then - tmix=0. - qmix=0. - zmix=0. - pmix=0. - do nk=jk+2,jk,-1 - if(pmix < 50.e2) then - dp = paph(jl,nk) - paph(jl,nk-1) - tmix=tmix+dp*ptenh(jl,nk) - qmix=qmix+dp*pqenh(jl,nk) - zmix=zmix+dp*pgeoh(jl,nk) - pmix=pmix+dp - end if - end do - tmix=tmix/pmix - qmix=qmix/pmix - zmix=zmix/pmix - else - tmix=ptenh(jl,jk+1) - qmix=pqenh(jl,jk+1) - zmix=pgeoh(jl,jk+1) - end if - - pqu(jl,jk+1) = qmix + deltq - dhen(jl,jk+1)= zmix + tmix*cpd - dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd - ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd - kup(jl,jk+1) = 0.5 - klab(jl,jk+1)= 1 - vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) - vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) - zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) - end if - end do - end if - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(loflag(jl)) then -! define the fscale - fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) - eta(jl) = 1.75e-3*fscale - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= 0.5*eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& - & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) - pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& - & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) - ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd - zqold(jl) = pqu(jl,jk) - zph(jl)=paph(jl,jk) - end if - end do -! check if the parcel is saturated - ik=jk - icall=1 - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - - do jl=1,klon - if( loflag(jl) ) then - zdq = max((zqold(jl) - pqu(jl,jk)),0.) - plu(jl,jk) = plu(jl,jk+1) + zdq - zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & - (1.-foealfa(ptu(jl,jk+1)))) - plu(jl,jk) = 0.5*plu(jl,jk) - dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) -! compute the updraft speed - vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& - ralfdcp*zlglac - vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) - abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g - atop1 = 1.0 - 2.*coef(jl) - atop2 = 2.0*dz(jl)*abuoy(jl,jk) - abot = 1.0 + 2.*coef(jl) - kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot -! let's find the exact cloud base - if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then - ik = jk + 1 - zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) - zqsu = min(0.5,zqsu) - zcor = 1./(1.-vtmpc1*zqsu) - zqsu = zqsu*zcor - zdq = min(0.,pqu(jl,ik)-zqsu) - zalfaw = foealfa(ptu(jl,ik)) - zfacw = c5les/((ptu(jl,ik)-c4les)**2) - zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) - zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci - zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) - zcor = 1./(1.-vtmpc1*zesdp) - zdqsdt = zfac*zcor*zqsu - zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) - zdp = zdq/(zdqsdt*zdtdp) - zcbase(jl) = paph(jl,ik) + zdp -! chose nearest half level as cloud base (jk or jk+1) - zpdifftop = zcbase(jl) - paph(jl,jk) - zpdiffbot = paph(jl,jk+1) - zcbase(jl) - if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then - ikb = min(klev-1,jk+1) - klab(jl,ikb) = 2 - klab(jl,jk) = 2 - kcbot(jl) = ikb - plu(jl,jk+1) = 1.0e-8 - else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then - klab(jl,jk) = 2 - kcbot(jl) = jk - end if - end if - - if(kup(jl,jk) .lt. 0.)then - loflag(jl) = .false. - if(plu(jl,jk+1) .gt. 0.) then - kctop(jl) = jk - lldcum(jl) = .true. - else - lldcum(jl) = .false. - end if - else - if(plu(jl,jk) .gt. 0.)then - klab(jl,jk)=2 - else - klab(jl,jk)=1 - end if - end if - end if - end do - - end do ! end all the levels - - needreset = .false. - do jl=1,klon - ikb = kcbot(jl) - ikt = kctop(jl) - if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. - if(lldcum(jl)) then - ktype(jl) = 1 - ldcum(jl) = .true. - deepflag(jl) = .true. - wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) - cubot(jl) = ikb - cutop(jl) = ikt - kdpl(jl) = levels+1 - needreset = .true. - resetflag(jl)= .true. - end if - end do - - if(needreset) then - do jk=klev,1,-1 - do jl=1,klon - if(resetflag(jl)) then - ikt = kctop(jl) - ikb = kdpl(jl) - if(jk .le. ikb .and. jk .ge. ikt )then - culab(jl,jk) = klab(jl,jk) - cutu(jl,jk) = ptu(jl,jk) - cuqu(jl,jk) = pqu(jl,jk) - culu(jl,jk) = plu(jl,jk) - else - culab(jl,jk) = 1 - cutu(jl,jk) = ptenh(jl,jk) - cuqu(jl,jk) = pqenh(jl,jk) - culu(jl,jk) = 0. - end if - if ( jk .lt. ikt ) culab(jl,jk) = 0 - end if - end do - end do - end if - - end do ! end all cycles - - return - end subroutine cutypen - -!----------------------------------------------------------------- -! level 3 subroutines 'cuascn' -!----------------------------------------------------------------- - subroutine cuascn & - & (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, & - & pmfus, pmfuq, pmful, plude, pdmfup,& - & kcbot, kctop, kctop0, kcum, ztmst,& - & pqsenh, plglac, lndj, wup, wbase, kdpl, pmfude_rate) - implicit none -! 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. -! c.zhang iprc 05/12 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 -! --------- -! *cuadjtqn* adjust t and q due to condensation in ascent -! *cuentrn* calculate entrainment/detrainment rates -! *cubasmcn* 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. -! 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 - cloud top level -! kctop0 [ictop0] - estimate of cloud top. (cumastr) -! kcum [icum] - flag to control the call - - integer klev,klon,klevp1,klevm1 - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev),& - & pten(klon,klev), pqen(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klevp1),& - & 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), & - & 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) - real phcbase(klon), zluold(klon) - real zprecip(klon), zlrain(klon,klev) - real zbuo(klon,klev), kup(klon,klev) - real wup(klon) - real wbase(klon), zodetr(klon,klev) - real plglac(klon,klev) - - real eta(klon),dz(klon) - - integer klwmin(klon), ktype(klon),& - & klab(klon,klev), kcbot(klon),& - & kctop(klon), kctop0(klon) - integer lndj(klon) - logical ldcum(klon), loflag(klon) - logical llo2,llo3, llo1(klon) - - integer kdpl(klon) - real zoentr(klon), zdpmean(klon) - real pdmfen(klon,klev), pmfude_rate(klon,klev) -! local variables - integer jl,jk - integer ikb,icum,itopm2,ik,icall,is,kcum,jlm,jll - integer jlx(klon) - real ztmst,zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 - real zmftest,zmfmax,zqeen,zseen,zscde,zqude - real zmfusk,zmfuqk,zmfulk - real zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco - real zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold - real zrnew,zz,zdmfeu,zdmfdu,dp - real zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd - real atop1,atop2,abot -!-------------------------------- -!* 1. specify parameters -!-------------------------------- - zcons2=3./(g*ztmst) - zfacbuo = 0.5/(1.+0.5) - zprcdgw = cprcon*zrg - z_cldmax = 5.e-3 - z_cwifrac = 0.5 - z_cprc2 = 0.5 - z_cwdrag = (3.0/8.0)*0.506/0.2 -!--------------------------------- -! 2. set default values -!--------------------------------- - llo3 = .false. - do jl=1,klon - zluold(jl)=0. - wup(jl)=0. - zdpmean(jl)=0. - zoentr(jl)=0. - if(.not.ldcum(jl)) then - ktype(jl)=0 - kcbot(jl) = -1 - pmfub(jl) = 0. - pqu(jl,klev) = 0. - end if - end do - - ! initialize variout quantities - do jk=1,klev - do jl=1,klon - if(jk.ne.kcbot(jl)) plu(jl,jk)=0. - pmfu(jl,jk)=0. - pmfus(jl,jk)=0. - pmfuq(jl,jk)=0. - pmful(jl,jk)=0. - plude(jl,jk)=0. - plglac(jl,jk)=0. - pdmfup(jl,jk)=0. - zlrain(jl,jk)=0. - zbuo(jl,jk)=0. - kup(jl,jk)=0. - pdmfen(jl,jk) = 0. - pmfude_rate(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 - end do - end do - - do jl = 1,klon - if ( ktype(jl) == 3 ) ldcum(jl) = .false. - end do -!------------------------------------------------ -! 3.0 initialize values at cloud base level -!------------------------------------------------ - do jl=1,klon - kctop(jl)=kcbot(jl) - if(ldcum(jl)) then - ikb = kcbot(jl) - kup(jl,ikb) = 0.5*wbase(jl)**2 - pmfu(jl,ikb) = pmfub(jl) - pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) - pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) - pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) - end if - end do -! -!----------------------------------------------------------------- -! 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 *cuadjtqn*, -! then check for buoyancy and set flags accordingly -!----------------------------------------------------------------- -! - do jk=klevm1,3,-1 -! specify cloud base values for midlevel convection -! in *cubasmc* in case there is not already convection -! --------------------------------------------------------------------- - ik=jk - call cubasmcn& - & (klon, klev, klevm1, ik, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, pgeoh, ldcum, ktype, klab, zlrain,& - & pmfu, pmfub, kcbot, ptu,& - & pqu, plu, puu, pvu, pmfus,& - & pmfuq, pmful, pdmfup) - is = 0 - jlm = 0 - do jl = 1,klon - loflag(jl) = .false. - zprecip(jl) = 0. - llo1(jl) = .false. - is = is + klab(jl,jk+1) - if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 - if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & - (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then - loflag(jl) = .true. - jlm = jlm + 1 - jlx(jlm) = jl - end if - zph(jl) = paph(jl,jk) - if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - if ( pmfub(jl) > 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 - pmfub(jl) = zmfmax - end if - pmfub(jl)=min(pmfub(jl),zmfmax) - end if - end do - - if(is.gt.0) llo3 = .true. -! -!* specify entrainment rates in *cuentr* -! ------------------------------------- - ik=jk - call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & - pgeoh,pmfu,zdmfen,zdmfde) -! -! do adiabatic ascent for entraining/detraining plume - if(llo3) then -! ------------------------------------------------------- -! - do jl = 1,klon - zqold(jl) = 0. - end do - do jll = 1 , jlm - jl = jlx(jll) - zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) - if ( jk == kcbot(jl) ) then - zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & - 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) - end if - if ( jk < kcbot(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - zxs = max(pmfu(jl,jk+1)-zmfmax,0.) - wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) - zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) - zdmfen(jl) = zoentr(jl) - if ( ktype(jl) >= 2 ) then - zdmfen(jl) = 2.0*zdmfen(jl) - zdmfde(jl) = zdmfen(jl) - end if - zdmfde(jl) = zdmfde(jl) * & - (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) - zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - zchange = max(zmftest-zmfmax,0.) - zxe = max(zchange-zxs,0.) - zdmfen(jl) = zdmfen(jl) - zxe - zchange = zchange - zxe - zdmfde(jl) = zdmfde(jl) + zchange - end if - pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) - pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - zqeen = pqenh(jl,jk+1)*zdmfen(jl) - zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) - zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) - zqude = pqu(jl,jk+1)*zdmfde(jl) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - 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) - zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & - (1./max(cmfcmin,pmfu(jl,jk))) - zluold(jl) = plu(jl,jk) - end do -! reset to environmental values if below departure level - do jl = 1,klon - if ( jk > kdpl(jl) ) then - ptu(jl,jk) = ptenh(jl,jk) - pqu(jl,jk) = pqenh(jl,jk) - plu(jl,jk) = 0. - zluold(jl) = plu(jl,jk) - end if - end do -!* do corrections for moist ascent -!* by adjusting t,q and l in *cuadjtq* -!------------------------------------------------ - ik=jk - icall=1 -! - if ( jlm > 0 ) then - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - end if -! compute the upfraft speed in cloud layer - do jll = 1 , jlm - jl = jlx(jll) - if ( pqu(jl,jk) /= zqold(jl) ) then - plglac(jl,jk) = plu(jl,jk) * & - ((1.-foealfa(ptu(jl,jk)))- & - (1.-foealfa(ptu(jl,jk+1)))) - ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) - end if - end do - do jll = 1 , jlm - jl = jlx(jll) - if ( pqu(jl,jk) /= zqold(jl) ) then - klab(jl,jk) = 2 - plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) - zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & - zlrain(jl,jk+1)) - zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = zbc - zbe -! set flags for the case of midlevel convection - if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then - if ( zbuo(jl,jk) > -0.5 ) then - ldcum(jl) = .true. - kctop(jl) = jk - kup(jl,jk) = 0.5 - else - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - plude(jl,jk) = 0. - plu(jl,jk) = 0. - end if - end if - if ( klab(jl,jk+1) == 2 ) then - if ( zbuo(jl,jk) < 0. ) then - ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) - pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) - zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - end if - zbuoc = (zbuo(jl,jk) / & - (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & - (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 - zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc -! mixing and "pressure" gradient term in upper troposphere - if ( zdmfen(jl) > 0. ) then - zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & - max(cmfcmin,pmfu(jl,jk+1))) - else - zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & - max(cmfcmin,pmfu(jl,jk+1))) - end if - kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & - (1.+zdken) - if ( zbuo(jl,jk) < 0. ) then - zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) - zkedke = max(0.,min(1.,zkedke)) - zmfun = sqrt(zkedke)*pmfu(jl,jk+1) - zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - end if - if ( zbuo(jl,jk) > -0.2 ) then - ikb = kcbot(jl) - zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & - pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & - zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 - zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) - else - zoentr(jl) = 0. - end if -! erase values if below departure level - if ( jk > kdpl(jl) ) then - pmfu(jl,jk) = pmfu(jl,jk+1) - kup(jl,jk) = 0.5 - end if - if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then - kctop(jl) = jk - llo1(jl) = .true. - else - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - kup(jl,jk) = 0. - zdmfde(jl) = pmfu(jl,jk+1) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - end if -! save detrainment rates for updraught - if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) - end if - else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - kup(jl,jk) = 0. - zdmfde(jl) = pmfu(jl,jk+1) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - pmfude_rate(jl,jk) = zdmfde(jl) - end if - end do - - do jl = 1,klon - if ( llo1(jl) ) then -! conversions only proceeds if plu is greater than a threshold liquid water -! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation -! generation from small water contents. - if ( lndj(jl).eq.1 ) then - zdshrd = 5.e-4 - else - zdshrd = 3.e-4 - end if - ikb=kcbot(jl) - if ( plu(jl,jk) > zdshrd )then - zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) - zprcon = zprcdgw/(0.75*zwu) -! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) - zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) - zcbf = 1. + z_cprc2*sqrt(zdt) - zzco = zprcon*zcbf - zlcrit = zdshrd/zcbf - zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) - zc = (plu(jl,jk)-zluold(jl)) - zarg = (plu(jl,jk)/zlcrit)**2 - if ( zarg < 25.0 ) then - zd = zzco*(1.-exp(-zarg))*zdfi - else - zd = zzco*zdfi - end if - zint = exp(-zd) - zlnew = zluold(jl)*zint + zc/zd*(1.-zint) - zlnew = max(0.,min(plu(jl,jk),zlnew)) - zlnew = min(z_cldmax,zlnew) - zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) - pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) - zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) - plu(jl,jk) = zlnew - end if - end if - end do - do jl = 1, klon - if ( llo1(jl) ) then - if ( zlrain(jl,jk) > 0. ) then - zvw = 21.18*zlrain(jl,jk)**0.2 - zvi = z_cwifrac*zvw - zalfaw = foealfa(ptu(jl,jk)) - zvv = zalfaw*zvw + (1.-zalfaw)*zvi - zrold = zlrain(jl,jk) - zprecip(jl) - zc = zprecip(jl) - zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) - zd = zvv/zwu - zint = exp(-zd) - zrnew = zrold*zint + zc/zd*(1.-zint) - zrnew = max(0.,min(zlrain(jl,jk),zrnew)) - zlrain(jl,jk) = zrnew - end if - end if - end do - do jll = 1 , jlm - jl = jlx(jll) - 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 do - end if - end do -!---------------------------------------------------------------------- -! 5. final calculations -! ------------------ - do jl = 1,klon - if ( kctop(jl) == -1 ) ldcum(jl) = .false. - kcbot(jl) = max(kcbot(jl),kctop(jl)) - if ( ldcum(jl) ) then - wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) - wup(jl) = sqrt(2.*wup(jl)) - end if - end do - - return - end subroutine cuascn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudlfsn & - & (klon, klev, & - & kcbot, kctop, lndj, ldcum, & - & ptenh, pqenh, puen, pven, & - & pten, pqsen, pgeo, & - & pgeoh, paph, ptu, pqu, plu,& - & puu, pvu, 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. - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level - -! input parameters (logical): - -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points - -! input parameters (real): - -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pten* provisional environment temperature (t+1) k -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *ptu* temperature in updrafts k -! *pqu* spec. humidity in updrafts kg/kg -! *plu* liquid water content in updrafts kg/kg -! *puu* u-velocity in updrafts m/s -! *pvu* v-velocity in updrafts m/s -! *pmfub* massflux in updrafts at cloud base kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) - -! output parameters (integer): - -! *kdtop* top level of downdrafts - -! output parameters (logical): - -! *lddraf* .true. if downdrafts exist - -! externals -! --------- -! *cuadjtq* for calculating wet bulb t and q at lfs -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pten(klon,klev), pqsen(klon,klev), & - & pgeo(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1),& - & ptu(klon,klev), pqu(klon,klev), & - & puu(klon,klev), pvu(klon,klev), & - & plu(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) - integer kcbot(klon), kctop(klon), & - & kdtop(klon), ikhsmin(klon) - logical ldcum(klon), & - & lddraf(klon) - integer lndj(klon) - - real ztenwb(klon,klev), zqenwb(klon,klev), & - & zcond(klon), zph(klon), & - & zhsmin(klon) - logical llo2(klon) -! local variables - integer jl,jk - integer is,ik,icall,ike - real zhsk,zttest,zqtest,zbuo,zmftop - -!---------------------------------------------------------------------- - -! 1. set default values for downdrafts -! --------------------------------- - do jl=1,klon - lddraf(jl)=.false. - kdtop(jl)=klev+1 - ikhsmin(jl)=klev+1 - zhsmin(jl)=1.e8 - enddo -!---------------------------------------------------------------------- - -! 2. determine level of free sinking: -! downdrafts shall start at model level of minimum -! of saturation moist static energy or below -! respectively - -! for every point and proceed as follows: - -! (1) determine level of minimum of hs -! (2) determine wet bulb environmental t and q -! (3) do mixing with cumulus cloud air -! (4) check for negative buoyancy -! (5) if buoyancy>0 repeat (2) to (4) for next -! level below - -! 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) -! ---------------------------------------------------- - do jk=3,klev-2 - do jl=1,klon - zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & - & foelhm(pten(jl,jk))*pqsen(jl,jk) - if(zhsk .lt. zhsmin(jl)) then - zhsmin(jl) = zhsk - ikhsmin(jl)= jk - end if - end do - end do - - - ike=klev-3 - do jk=3,ike - -! 2.1 calculate wet-bulb temperature and moisture -! for environmental air in *cuadjtq* -! ------------------------------------------- - is=0 - do 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)).and. jk.ge.ikhsmin(jl) - if(llo2(jl))then - is=is+1 - endif - enddo - if(is.eq.0) cycle - - ik=jk - icall=2 - call cuadjtqn & - & ( 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. -! ---------------------------------------- - do 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) - endif - endif - enddo - - enddo - - return - end subroutine cudlfsn - -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- -!********************************************** -! subroutine cuddrafn -!********************************************** - subroutine cuddrafn & - & ( klon, klev, lddraf & - & , ptenh, pqenh, puen, pven & - & , pgeo, pgeoh, paph, prfl & - & , ptd, pqd, pud, pvd, pmfu & - & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) - -! 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. - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels - -! input parameters (logical): - -! *lddraf* .true. if downdrafts exist - -! input parameters (real): - -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *pmfu* massflux updrafts kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) - -! externals -! --------- -! *cuadjtq* for adjusting t and q due to evaporation in -! saturated descent -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1), & - & pgeo(klon,klev), pmfu(klon,klev) - - 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 pmfdde_rate(klon,klev) - logical lddraf(klon) - - real zdmfen(klon), zdmfde(klon), & - & zcond(klon), zoentr(klon), & - & zbuoy(klon) - real zph(klon) - logical llo2(klon) - logical llo1 -! local variables - integer jl,jk - integer is,ik,icall,ike, itopde(klon) - real zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp - real zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk - -!---------------------------------------------------------------------- -! 1. calculate moist descent for cumulus downdraft by -! (a) calculating entrainment/detrainment rates, -! including organized entrainment dependent on -! negative buoyancy and 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 -! ------------------------------------------------- - do jl=1,klon - zoentr(jl)=0. - zbuoy(jl)=0. - zdmfen(jl)=0. - zdmfde(jl)=0. - enddo - - do jk=klev,1,-1 - do jl=1,klon - pmfdde_rate(jl,jk) = 0. - if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk - end do - end do - - do jk=3,klev - is=0 - do 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 - enddo - if(is.eq.0) cycle - - do jl=1,klon - if(llo2(jl)) then - zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zdmfen(jl)=zentr - zdmfde(jl)=zentr - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - if(jk.gt.itopde(jl)) then - zdmfen(jl)=0. - zdmfde(jl)=pmfd(jl,itopde(jl))* & - & (paph(jl,jk)-paph(jl,jk-1))/ & - & (paph(jl,klev+1)-paph(jl,itopde(jl))) - endif - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - if(jk.le.itopde(jl)) then - zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) - zdmfen(jl)=zdmfen(jl)+zzentr - zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) - zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & - & (pmfd(jl,jk-1)-zdmfde(jl))) - zdmfen(jl)=min(zdmfen(jl),0.) - endif - endif - enddo - - do 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) - endif - enddo - - ik=jk - icall=2 - call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) - - do 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(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then - zrain=prfl(jl)/pmfu(jl,jk) - zbuo=zbuo-ptd(jl,jk)*zrain - endif - if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then - pmfd(jl,jk)=0. - zbuo=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 - -! compute organized entrainment for use at next level - zbuoyz=zbuo/ptenh(jl,jk) - zbuoyz=min(zbuoyz,0.0) - zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) - zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz - zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) - pmfdde_rate(jl,jk) = -zdmfde(jl) - endif - enddo - - enddo - - return - end subroutine cuddrafn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cuflxn & - & ( klon, klev, ztmst & - & , pten, pqen, pqsen, ptenh, pqenh & - & , paph, pap, pgeoh, lndj, ldcum & - & , kcbot, kctop, kdtop, ktopm2 & - & , ktype, lddraf & - & , pmfu, pmfd, pmfus, pmfds & - & , pmfuq, pmfdq, pmful, plude & - & , pdmfup, pdmfdp, pdpmel, plglac & - & , prain, pmfdde_rate, pmflxr, pmflxs ) - -! 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*. - - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level -! *kdtop* top level of downdrafts - -! input parameters (logical): - -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points - -! input parameters (real): - -! *ptsphy* time step for the physics s -! *pten* provisional environment temperature (t+1) k -! *pqen* provisional environment spec. humidity (t+1) kg/kg -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *paph* provisional pressure on half levels pa -! *pap* provisional pressure on full levels pa -! *pgeoh* geopotential on half levels m2/s2 - -! updated parameters (integer): - -! *ktype* set to zero if ldcum=.false. - -! updated parameters (logical): - -! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) - if ( llddraf .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 - if ( llddraf .and. pmfd(jl,jk) < 0. .and. & - abs(pmfd(jl,ikb)) < 1.e-20 ) then - idbas(jl) = jk - 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. - plglac(jl,jk)=0. - pdmfup(jl,jk-1)=0. - pdmfdp(jl,jk-1)=0. - plude(jl,jk-1)=0. - endif - enddo - enddo - - do jl=1,klon - pmflxr(jl,klev+1) = 0. - pmflxs(jl,klev+1) = 0. - end do - do jl=1,klon - if(ldcum(jl)) then - ikb=kcbot(jl) - ik=ikb+1 - zzp=((paph(jl,klev+1)-paph(jl,ik))/ & - & (paph(jl,klev+1)-paph(jl,ikb))) - if(ktype(jl).eq.3) then - zzp=zzp**2 - endif - pmfu(jl,ik)=pmfu(jl,ikb)*zzp - pmfus(jl,ik)=(pmfus(jl,ikb)- & - & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp - pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp - pmful(jl,ik)=0. - endif - enddo - - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then - ikb=kcbot(jl)+1 - zzp=((paph(jl,klev+1)-paph(jl,jk))/ & - & (paph(jl,klev+1)-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)=0. - endif - ik = idbas(jl) - llddraf = lddraf(jl) .and. jk > ik .and. ik < klev - if ( llddraf .and. ik == kcbot(jl)+1 ) then - zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) - if ( ktype(jl) == 3 ) zzp = zzp*zzp - pmfd(jl,jk) = pmfd(jl,ik)*zzp - pmfds(jl,jk) = pmfds(jl,ik)*zzp - pmfdq(jl,jk) = pmfdq(jl,ik)*zzp - pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) - else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then - pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) - end if - enddo - enddo -!* 2. calculate rain/snow fall rates -!* calculate melting of snow -!* calculate evaporation of precip -! ------------------------------- - - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then - prain(jl)=prain(jl)+pdmfup(jl,jk) - if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then - zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) - zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) - zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) - pdpmel(jl,jk)=zsnmlt - pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) - endif - zalfaw=foealfa(pten(jl,jk)) - ! - ! No liquid precipitation above melting level - ! - if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then - plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) - zalfaw = 0. - end if - pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & - & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) - pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & - & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) - if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then - pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) - pmflxr(jl,jk+1)=0.0 - pmflxs(jl,jk+1)=0.0 - pdpmel(jl,jk) =0.0 - else if ( pmflxr(jl,jk+1) < 0. ) then - pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) - pmflxr(jl,jk+1) = 0. - else if ( pmflxs(jl,jk+1) < 0. ) then - pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) - pmflxs(jl,jk+1) = 0. - end if - endif - enddo - enddo - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl).and.jk.ge.kcbot(jl)) then - zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) - if(zrfl.gt.1.e-20) then - zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & - & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & - & zrfl/zcucov)**0.5777* & - & (paph(jl,jk+1)-paph(jl,jk)) - zrnew=zrfl-zdrfl1 - zrmin=zrfl-zcucov*max(0.,rhevap(jl)*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) - zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) - zalfaw=foealfa(pten(jl,jk)) - if ( pten(jl,jk) < tmelt ) zalfaw = 0. - zpdr=zalfaw*pdmfdp(jl,jk) - zpds=(1.-zalfaw)*pdmfdp(jl,jk) - pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & - & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom - pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & - & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom - pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl - if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then - pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) - pmflxr(jl,jk+1) = 0. - pmflxs(jl,jk+1) = 0. - pdpmel(jl,jk) = 0. - else if ( pmflxr(jl,jk+1) < 0. ) then - pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) - pmflxr(jl,jk+1) = 0. - else if ( pmflxs(jl,jk+1) < 0. ) then - pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) - pmflxs(jl,jk+1) = 0. - end if - else - pmflxr(jl,jk+1)=0.0 - pmflxs(jl,jk+1)=0.0 - pdmfdp(jl,jk)=0.0 - pdpmel(jl,jk)=0.0 - endif - endif - enddo - enddo - - return - end subroutine cuflxn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & - lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & - pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & - pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) - implicit none - integer klon,klev,ktopm2 - integer kctop(klon), kdtop(klon) - logical ldcum(klon), lddraf(klon) - real ztmst - real paph(klon,klev+1), pgeoh(klon,klev+1) - real pgeo(klon,klev), pten(klon,klev), & - pqen(klon,klev), ptenh(klon,klev),& - pqenh(klon,klev), pqsen(klon,klev),& - plglac(klon,klev), plude(klon,klev) - real pmfu(klon,klev), pmfd(klon,klev),& - pmfus(klon,klev), pmfds(klon,klev),& - pmfuq(klon,klev), pmfdq(klon,klev),& - pmful(klon,klev), pdmfup(klon,klev),& - pdpmel(klon,klev), pdmfdp(klon,klev) - real ptent(klon,klev), ptenq(klon,klev) - real pcte(klon,klev) - -! local variables - integer jk , ik , jl - real zalv , zzp - real zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) - !* 1.0 SETUP AND INITIALIZATIONS - ! ------------------------- - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - end if - end do - end do - !----------------------------------------------------------------------- - !* 2.0 COMPUTE TENDENCIES - ! ------------------ - do jk = ktopm2 , klev - if ( jk < klev ) then - do jl = 1,klon - if ( ldcum(jl) ) then - zalv = foelhm(pten(jl,jk)) - zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & - (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - & - pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) - zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - & - pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - & - pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) - end if - end do - else - do jl = 1,klon - if ( ldcum(jl) ) then - zalv = foelhm(pten(jl,jk)) - zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & - (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk))) - zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + & - pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) - end if - end do - end if - end do - !--------------------------------------------------------------- - !* 3.0 UPDATE TENDENCIES - ! ----------------- - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) - ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) - pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) - end if - end do - end do - - return - end subroutine cudtdqn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & - ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & - ptenv) - implicit none - integer klon,klev,ktopm2 - integer ktype(klon), kcbot(klon), kctop(klon) - logical ldcum(klon) - real ztmst - real paph(klon,klev+1) - real puen(klon,klev), pven(klon,klev),& - pmfu(klon,klev), pmfd(klon,klev),& - puu(klon,klev), pud(klon,klev),& - pvu(klon,klev), pvd(klon,klev) - real ptenu(klon,klev), ptenv(klon,klev) - -!local variables - real zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & - zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) - - integer ik , ikb , jk , jl - real zzp, zdtdt - - real zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) -! - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - zuen(jl,jk) = puen(jl,jk) - zven(jl,jk) = pven(jl,jk) - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - end if - end do - end do -!---------------------------------------------------------------------- -!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES -! ---------------------------------------------- - do jk = ktopm2 , klev - ik = jk - 1 - do jl = 1,klon - if ( ldcum(jl) ) then - zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) - zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) - zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) - zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) - end if - end do - end do - ! linear fluxes below cloud - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk > kcbot(jl) ) then - ikb = kcbot(jl) - zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) - if ( ktype(jl) == 3 ) zzp = zzp*zzp - 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 - end do - end do -!---------------------------------------------------------------------- -!* 2.0 COMPUTE TENDENCIES -! ------------------ - do jk = ktopm2 , klev - if ( jk < klev ) then - ik = jk + 1 - do jl = 1,klon - if ( ldcum(jl) ) then - zdudt(jl,jk) = zdp(jl,jk) * & - (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) - zdvdt(jl,jk) = zdp(jl,jk) * & - (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) - end if - end do - else - do jl = 1,klon - if ( ldcum(jl) ) then - zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) - zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) - end if - end do - end if - end do -!--------------------------------------------------------------------- -!* 3.0 UPDATE TENDENCIES -! ----------------- - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) - ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) - end if - end do - end do -!---------------------------------------------------------------------- - return - end subroutine cududvn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cuadjtqn & - & (klon, klev, kk, psp, pt, pq, ldflag, kcall) -! m.tiedtke e.c.m.w.f. 12/89 -! purpose. -! -------- -! to produce t,q and l values for cloud ascent - -! interface -! --------- -! this routine is called from subroutines: -! *cond* (t and q at condensation level) -! *cubase* (t and q at condensation 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 - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kk* level -! *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) -! input parameters (real): - -! *psp* pressure pa - -! updated parameters (real): - -! *pt* temperature k -! *pq* specific humidity kg/kg -! externals -! --------- -! for condensation calculations. -! the tables are initialised in *suphec*. - -!---------------------------------------------------------------------- - - implicit none - - integer klev,klon - real pt(klon,klev), pq(klon,klev), & - & psp(klon) - logical ldflag(klon) -! local variables - integer jl,jk - integer isum,kcall,kk - real zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf -!---------------------------------------------------------------------- -! 1. define constants -! ---------------- - zqmax=0.5 - -! 2. calculate condensation and adjust t and q accordingly -! ----------------------------------------------------- - - if ( kcall == 1 ) then - do jl = 1,klon - if ( ldflag(jl) ) then - zqp = 1./psp(jl) - zl = 1./(pt(jl,kk)-c4les) - zi = 1./(pt(jl,kk)-c4ies) - zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & - (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) - zqsat = zqsat*zqp - zqsat = min(0.5,zqsat) - zcor = 1. - vtmpc1*zqsat - zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & - (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 - zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) - if ( zcond > 0. ) then - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond - pq(jl,kk) = pq(jl,kk) - zcond - zl = 1./(pt(jl,kk)-c4les) - zi = 1./(pt(jl,kk)-c4ies) - zqsat = c2es*(foealfa(pt(jl,kk)) * & - exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & - exp(c3ies*(pt(jl,kk)-tmelt)*zi)) - zqsat = zqsat*zqp - zqsat = min(0.5,zqsat) - zcor = 1. - vtmpc1*zqsat - zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & - (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 - zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) - if ( abs(zcond) < 1.e-20 ) zcond1 = 0. - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end if - end if - end do - elseif ( kcall == 2 ) then - do jl = 1,klon - if ( ldflag(jl) ) then - zqp = 1./psp(jl) - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - zcond = min(zcond,0.) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond - pq(jl,kk) = pq(jl,kk) - zcond - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end if - end do - else if ( kcall == 0 ) then - do jl = 1,klon - zqp = 1./psp(jl) - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end do - end if - - return - end subroutine cuadjtqn -!--------------------------------------------------------- -! level 4 souroutines -!-------------------------------------------------------- - subroutine cubasmcn & - & (klon, klev, klevm1, kk, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, pgeoh, ldcum, ktype, klab, plrain,& - & pmfu, pmfub, kcbot, ptu,& - & pqu, plu, puu, pvu, pmfus,& - & pmfuq, pmful, pdmfup) - implicit none -! m.tiedtke e.c.m.w.f. 12/89 -! c.zhang iprc 05/2012 -!***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 -! ---------------------------------------------------------------- - 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+1) - real ptu(klon,klev), pqu(klon,klev),& - & puu(klon,klev), pvu(klon,klev),& - & plu(klon,klev), pmfu(klon,klev),& - & pmfub(klon), & - & pmfus(klon,klev), pmfuq(klon,klev),& - & pmful(klon,klev), pdmfup(klon,klev),& - & plrain(klon,klev) - integer ktype(klon), kcbot(klon),& - & klab(klon,klev) - logical ldcum(klon) -! local variabels - integer jl,kk,klev,klon,klevp1,klevm1 - real zzzmb -!-------------------------------------------------------- -!* 1. calculate entrainment and detrainment rates -! ------------------------------------------------------- - do jl=1,klon - if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then - if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & - pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & - & pgeo(jl,kk)*zrg .lt. 1.0e4 ) 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)*zrg) - 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 - plrain(jl,kk+1)=0.0 - ktype(jl)=3 - end if - end if - end do - return - end subroutine cubasmcn -!--------------------------------------------------------- -! level 4 souroutines -!--------------------------------------------------------- - subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & - pgeoh,pmfu,pdmfen,pdmfde) - implicit none - integer klon,klev,kk - integer kcbot(klon) - logical ldcum(klon) - logical ldwork - real pgeoh(klon,klev+1) - real pmfu(klon,klev) - real pdmfen(klon) - real pdmfde(klon) - logical llo1 - integer jl - real zdz , zmf - real zentr(klon) - ! - !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES - ! ------------------------------------------- - if ( ldwork ) then - do jl = 1,klon - pdmfen(jl) = 0. - pdmfde(jl) = 0. - zentr(jl) = 0. - end do - ! - !* 1.1 SPECIFY ENTRAINMENT RATES - ! ------------------------- - do jl = 1, klon - if ( ldcum(jl) ) then - zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg - zmf = pmfu(jl,kk+1)*zdz - llo1 = kk < kcbot(jl) - if ( llo1 ) then - pdmfen(jl) = zentr(jl)*zmf - pdmfde(jl) = 0.75e-4*zmf - end if - end if - end do - end if - end subroutine cuentrn -!-------------------------------------------------------- -! external functions -!------------------------------------------------------ - real function foealfa(tt) -! foealfa is calculated to distinguish the three cases: -! -! foealfa=1 water phase -! foealfa=0 ice phase -! 0 < foealfa < 1 mixed phase -! -! input : tt = temperature -! - implicit none - real tt - foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & - & /(rtwat-rtice))**2) - - return - end function foealfa - - real function foelhm(tt) - implicit none - real tt - foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als - return - end function foelhm - - real function foeewm(tt) - implicit none - real tt - foeewm = c2es * & - & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & - & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) - return - end function foeewm - - real function foedem(tt) - implicit none - real tt - foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & - & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) - return - end function foedem - - real function foeldcpm(tt) - implicit none - real tt - foeldcpm = foealfa(tt)*ralvdcp+ & - & (1.-foealfa(tt))*ralsdcp - return - end function foeldcpm + endif + endif + + enddo + + end subroutine cu_ntiedtke_driver + +!================================================================================================================= + subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & + rucuten,rvcuten,rthften,rqvften, & + 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) +!================================================================================================================= + +!--- input arguments: + 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 + +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,rthften,rqvften + +!--- local variables and arrays: + 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 + + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rthften(i,k,j)=0. + rqvften(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 module module_cu_ntiedtke + end subroutine ntiedtkeinit +!================================================================================================================= + end module module_cu_ntiedtke +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F b/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F index a2b57f8377..33e2842ad2 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_tiedtke.F @@ -564,6 +564,7 @@ subroutine tiecnv(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & !----------------------------------------------------------------- implicit none + integer lq,km,km1 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) @@ -589,7 +590,7 @@ subroutine tiecnv(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & real psheat,psrain,psevap,psmelt,psdiss,tt real ztmst,ztpp1,fliq,fice,ztc,zalf - integer i,j,k,lq,lp,km,km1 + integer i,j,k,lp ! real tlucua ! external tlucua diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F b/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F index d68951187f..ebe64ee153 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F @@ -25,6 +25,7 @@ MODULE module_mp_radar #if defined(mpas) USE mpas_atmphys_functions USE mpas_atmphys_utilities + USE mpas_kind_types, ONLY : R8KIND #else USE module_wrf_error #endif @@ -44,12 +45,16 @@ MODULE module_mp_radar PRIVATE :: GAMMLN #endif +#if !defined(mpas) + INTEGER, PARAMETER :: R8KIND = SELECTED_REAL_KIND(12) +#endif + INTEGER, PARAMETER, PUBLIC:: nrbins = 50 DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10 ! in meters DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4 - COMPLEX*16, PUBLIC:: m_w_0, m_i_0 + COMPLEX(KIND=R8KIND), PUBLIC:: m_w_0, m_i_0 DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = & (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) @@ -130,7 +135,7 @@ subroutine radar_init xxDx(1) = 100.D-6 xxDx(nrbins+1) = 0.02d0 do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & + xxDx(n) = DEXP(REAL(n-1,KIND=R8KIND)/REAL(nrbins,KIND=R8KIND) & *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) enddo do n = 1, nrbins @@ -142,7 +147,7 @@ subroutine radar_init xxDx(1) = 100.D-6 xxDx(nrbins+1) = 0.05d0 do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & + xxDx(n) = DEXP(REAL(n-1,KIND=R8KIND)/REAL(nrbins,KIND=R8KIND) & *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) enddo do n = 1, nrbins @@ -197,7 +202,7 @@ end subroutine radar_init !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) + COMPLEX(KIND=R8KIND) FUNCTION m_complex_water_ray(lambda,T) ! Complex refractive Index of Water as function of Temperature T ! [deg C] and radar wavelength lambda [m]; valid for @@ -208,7 +213,7 @@ COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) DOUBLE PRECISION, INTENT(IN):: T,lambda DOUBLE PRECISION:: epsinf,epss,epsr,epsi DOUBLE PRECISION:: alpha,lambdas,sigma,nenner - COMPLEX*16, PARAMETER:: i = (0d0,1d0) + COMPLEX(KIND=R8KIND), PARAMETER:: i = (0d0,1d0) DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0 epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T @@ -232,7 +237,7 @@ END FUNCTION m_complex_water_ray !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T) + COMPLEX(KIND=R8KIND) FUNCTION m_complex_ice_maetzler(lambda,T) ! complex refractive index of ice as function of Temperature T ! [deg C] and radar wavelength lambda [m]; valid for @@ -281,11 +286,11 @@ subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, & DOUBLE PRECISION, INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, & meltratio_outside DOUBLE PRECISION, INTENT(out):: C_back - COMPLEX*16, INTENT(in):: m_w, m_i + COMPLEX(KIND=R8KIND), INTENT(in):: m_w, m_i CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, & host, hostmatrix, hostinclusion - COMPLEX*16:: m_core, m_air + COMPLEX(KIND=R8KIND):: m_core, m_air DOUBLE PRECISION:: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, & volg, vg, volair, volice, volwater, & meltratio_outside_grenz, mra @@ -368,20 +373,20 @@ end subroutine rayleigh_soak_wetgraupel !+---+-----------------------------------------------------------------+ - complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, & + complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & volice, volwater, mixingrule, host, matrix, & inclusion, hostmatrix, hostinclusion, cumulerror) IMPLICIT NONE DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w + COMPLEX(KIND=R8KIND), INTENT(in):: m_a, m_i, m_w CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, & inclusion, hostmatrix, hostinclusion INTEGER, INTENT(out):: cumulerror DOUBLE PRECISION:: vol1, vol2 - COMPLEX*16:: mtmp + COMPLEX(KIND=R8KIND):: mtmp INTEGER:: error !..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be @@ -538,13 +543,13 @@ end function get_m_mix_nested !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & + COMPLEX(KIND=R8KIND) FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & volwater, mixingrule, matrix, inclusion, error) IMPLICIT NONE DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w + COMPLEX(KIND=R8KIND), INTENT(in):: m_a, m_i, m_w CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion INTEGER, INTENT(out):: error @@ -594,16 +599,16 @@ END FUNCTION get_m_mix !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & + COMPLEX(KIND=R8KIND) FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & m1, m2, m3, inclusion, error) IMPLICIT NONE - COMPLEX*16 :: m1, m2, m3 + COMPLEX(KIND=R8KIND) :: m1, m2, m3 DOUBLE PRECISION :: vol1, vol2, vol3 CHARACTER(len=*) :: inclusion - COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t + COMPLEX(KIND=R8KIND) :: beta2, beta3, m1t, m2t, m3t INTEGER, INTENT(out) :: error error = 0 @@ -639,7 +644,7 @@ COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & #else CALL wrf_debug(150, radar_debug) #endif - m_complex_maxwellgarnett=DCMPLX(-999.99d0,-999.99d0) + m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0,kind=R8KIND) error = 1 return endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F index a2d28456b7..b5b9189b95 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F @@ -63,7 +63,8 @@ MODULE module_mp_thompson use mpas_kind_types use mpas_atmphys_functions, only: gammp,wgamma,rslf,rsif use mpas_atmphys_utilities - use module_mp_radar + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + use mp_radar implicit none logical, parameter, private:: iiwarm = .false. @@ -421,6 +422,7 @@ subroutine thompson_init(l_mp_tables) integer:: i,j,k,l,m,n integer:: istat logical:: micro_init + integer:: mp_unit !..Allocate space for lookup tables (J. Michalakes 2009Jun08). micro_init = .FALSE. @@ -659,7 +661,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0i*1.0d0 xDx(nbi+1) = 5.0d0*D0s do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbi,KIND=R8SIZE) & *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbi @@ -671,7 +673,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0r*1.0d0 xDx(nbr+1) = 0.005d0 do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbr,KIND=R8SIZE) & *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbr @@ -683,7 +685,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0s*1.0d0 xDx(nbs+1) = 0.02d0 do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbs,KIND=R8SIZE) & *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbs @@ -695,7 +697,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0g*1.0d0 xDx(nbg+1) = 0.05d0 do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbg,KIND=R8SIZE) & *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbg @@ -707,7 +709,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = 1.0d0 xDx(nbc+1) = 3000.0d0 do n = 2, nbc - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbc,KIND=R8SIZE) & *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbc @@ -833,18 +835,23 @@ subroutine thompson_init(l_mp_tables) call table_dropEvap !..Rain collecting graupel & graupel collecting rain. - open(unit=11,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & +#if defined(mpas) + call mpas_new_unit(mp_unit, unformatted = .true.) +#else + mp_unit = 11 +#endif + open(unit=mp_unit,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat = istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_QRacrQG.DBL') - read(11) tcg_racg - read(11) tmr_racg - read(11) tcr_gacr - read(11) tmg_gacr - read(11) tnr_racg - read(11) tnr_gacr - close(unit=11) + read(mp_unit) tcg_racg + read(mp_unit) tmr_racg + read(mp_unit) tcr_gacr + read(mp_unit) tmg_gacr + read(mp_unit) tnr_racg + read(mp_unit) tnr_gacr + close(unit=mp_unit) ! write(0,*) '--- end read MP_THOMPSON_QRacrQG.DBL' ! write(0,*) 'max tcg_racg =',maxval(tcg_racg) ! write(0,*) 'min tcg_racg =',minval(tcg_racg) @@ -860,24 +867,24 @@ subroutine thompson_init(l_mp_tables) ! write(0,*) 'min tnr_gacr =',minval(tnr_gacr) !..Rain collecting snow & snow collecting rain. - open(unit=11,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & + open(unit=mp_unit,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat=istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_QRacrQS.DBL') - read(11) tcs_racs1 - read(11) tmr_racs1 - read(11) tcs_racs2 - read(11) tmr_racs2 - read(11) tcr_sacr1 - read(11) tms_sacr1 - read(11) tcr_sacr2 - read(11) tms_sacr2 - read(11) tnr_racs1 - read(11) tnr_racs2 - read(11) tnr_sacr1 - read(11) tnr_sacr2 - close(unit=11) + read(mp_unit) tcs_racs1 + read(mp_unit) tmr_racs1 + read(mp_unit) tcs_racs2 + read(mp_unit) tmr_racs2 + read(mp_unit) tcr_sacr1 + read(mp_unit) tms_sacr1 + read(mp_unit) tcr_sacr2 + read(mp_unit) tms_sacr2 + read(mp_unit) tnr_racs1 + read(mp_unit) tnr_racs2 + read(mp_unit) tnr_sacr1 + read(mp_unit) tnr_sacr2 + close(unit=mp_unit) ! write(0,*) '--- end read MP_THOMPSON_QRacrQS.DBL' ! write(0,*) 'max tcs_racs1 =',maxval(tcs_racs1) ! write(0,*) 'min tcs_racs1 =',minval(tcs_racs1) @@ -905,18 +912,18 @@ subroutine thompson_init(l_mp_tables) ! write(0,*) 'min tnr_sacr2 =',minval(tnr_sacr2) !..Cloud water and rain freezing (Bigg, 1953). - open(unit=11,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & + open(unit=mp_unit,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat=istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_freezeH2O.DBL') - read(11) tpi_qrfz - read(11) tni_qrfz - read(11) tpg_qrfz - read(11) tnr_qrfz - read(11) tpi_qcfz - read(11) tni_qcfz - close(unit=11) + read(mp_unit) tpi_qrfz + read(mp_unit) tni_qrfz + read(mp_unit) tpg_qrfz + read(mp_unit) tnr_qrfz + read(mp_unit) tpi_qcfz + read(mp_unit) tni_qcfz + close(unit=mp_unit) ! write(0,*) '--- end read MP_THOMPSON_freezeH2O.DBL:' ! write(0,*) 'max tpi_qrfz =',maxval(tpi_qrfz) ! write(0,*) 'min tpi_qrfz =',minval(tpi_qrfz) @@ -932,15 +939,18 @@ subroutine thompson_init(l_mp_tables) ! write(0,*) 'min tni_qcfz =',minval(tni_qcfz) !..Conversion of some ice mass into snow category. - open(unit=11,file='MP_THOMPSON_QIautQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & + open(unit=mp_unit,file='MP_THOMPSON_QIautQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat=istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_QIautQS.DBL') - read(11) tpi_ide - read(11) tps_iaus - read(11) tni_iaus - close(unit=11) + read(mp_unit) tpi_ide + read(mp_unit) tps_iaus + read(mp_unit) tni_iaus + close(unit=mp_unit) +#if defined(mpas) + call mpas_release_unit(mp_unit) +#endif ! write(0,*) '--- end read MP_THOMPSON_QIautQS.DBL ' ! write(0,*) 'max tps_iaus =',maxval(tps_iaus) ! write(0,*) 'min tps_iaus =',minval(tps_iaus) @@ -3841,7 +3851,7 @@ subroutine freezeH2O T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) do k = 1, 45 ! print*, ' Freezing water for temp = ', -k - Texp = DEXP( DFLOAT(k) - T_adjust*1.0D0 ) - 1.0D0 + Texp = DEXP( REAL(k,KIND=R8SIZE) - T_adjust*1.0D0 ) - 1.0D0 do j = 1, ntb_r1 do i = 1, ntb_r lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F b/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F index 5c52d40f28..07c0de6b38 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F @@ -1,2674 +1,239 @@ -#if ( (defined(wrfmodel) ) && ( RWORDSIZE == 4 ) ) || ( ( defined(mpas) ) && defined(SINGLE_PRECISION) ) -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -MODULE module_mp_wsm6 -! - USE module_mp_radar -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain -! REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow -! REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow -! REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow - REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur - REAL, SAVE :: & - qc0, qck1, pidnc, & - bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - bvtr6,g6pbr, & - precr1,precr2,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc,pi, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & - g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & - precg1,precg2,pidn0g, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -CONTAINS -!=================================================================== -! - SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & - ,den, pii, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,rain, rainncv & - ,snow, snowncv & - ,sr & - ,refl_10cm, diagflag, do_radar_ref & - ,graupel, graupelncv & - ,has_reqc, has_reqi, has_reqs & ! for radiation - ,re_cloud, re_ice, re_snow & ! for radiation - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & -#ifdef WRF_CHEM - ,evapprod, rainprod & -#endif - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(INOUT) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs, & - qg - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr -! for radiation connecting - INTEGER, INTENT(IN):: & - has_reqc, & - has_reqi, & - has_reqs - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - INTENT(INOUT):: & - re_cloud, & - re_ice, & - re_snow -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, & ! GT - INTENT(INOUT) :: refl_10cm -!+---+-----------------------------------------------------------------+ + module module_mp_wsm6 + use mpas_log + use mpas_kind_types,only: RKIND - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv + use mp_wsm6,only: mp_wsm6_run + use mp_wsm6_effectrad,only: mp_wsm6_effectRad_run -#ifdef WRF_CHEM - REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(INOUT) :: & - rainprod, & - evapprod -! local variable - REAL, DIMENSION( its:ite , kts:kte ) :: & - rainprod2d, & - evapprod2d -#endif - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs - INTEGER :: i,j,k -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(kts:kte):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ - LOGICAL, OPTIONAL, INTENT(IN) :: diagflag - INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref -!+---+-----------------------------------------------------------------+ -! to calculate effective radius for radiation - REAL, DIMENSION( kts:kte ) :: den1d - REAL, DIMENSION( kts:kte ) :: qc1d - REAL, DIMENSION( kts:kte ) :: qi1d - REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs + implicit none + private + public:: wsm6 - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) - qrs(i,k,3) = qg(i,k,j) - ENDDO - ENDDO - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - CALL wsm62D(t, q(ims,kms,j), qci, qrs & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & -#ifdef WRF_CHEM - ,rainprod2d, evapprod2d & -#endif - ) - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) - qg(i,k,j) = qrs(i,k,3) - ENDDO - ENDDO -!+---+-----------------------------------------------------------------+ - IF ( PRESENT (diagflag) ) THEN - if (diagflag .and. do_radar_ref == 1) then - DO I=its,ite - DO K=kts,kte - t1d(k)=th(i,k,j)*pii(i,k,j) - p1d(k)=p(i,k,j) - qv1d(k)=q(i,k,j) - qr1d(k)=qr(i,k,j) - qs1d(k)=qs(i,k,j) - qg1d(k)=qg(i,k,j) - ENDDO - call refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, i, j) - do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) - enddo - ENDDO - endif - ENDIF + contains - if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then - do i=its,ite - do k=kts,kte - re_qc(k) = 2.51E-6 - re_qi(k) = 10.01E-6 - re_qs(k) = 25.E-6 - t1d(k) = th(i,k,j)*pii(i,k,j) - den1d(k)= den(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qs1d(k) = qs(i,k,j) - enddo - call effectRad_wsm6(t1d, qc1d, qi1d, qs1d, den1d, & - qmin, t0c, re_qc, re_qi, re_qs, & - kts, kte, i, j) - do k=kts,kte - re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) - re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) - re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) - enddo - enddo - endif ! has_reqc, etc... -!+---+-----------------------------------------------------------------+ -#ifdef WRF_CHEM - do i=its,ite - do k=kts,kte - rainprod(i,k,j) = rainprod2d(i,k) - evapprod(i,k,j) = evapprod2d(i,k) - enddo - enddo +!================================================================================================================= + subroutine wsm6(th,q,qc,qr,qi,qs,qg,den,pii,p,delz, & + delt,g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin, & + xls,xlv0,xlf0,den0,denr,cliq,cice,psat, & + rain,rainncv,snow,snowncv,graupel,graupelncv,sr, & + refl_10cm,diagflag,do_radar_ref, & + has_reqc,has_reqi,has_reqs,re_qc_bg,re_qi_bg, & + re_qs_bg,re_qc_max,re_qi_max,re_qs_max, & + re_cloud,re_ice,re_snow, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + errmsg,errflg & +#if(WRF_CHEM == 1) + ,wetscav_on,evapprod,rainprod & #endif - ENDDO - END SUBROUTINE wsm6 -!=================================================================== -! - SUBROUTINE wsm62D(t, q & - ,qci, qrs, den, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & -#ifdef WRF_CHEM - ,rainprod2d, evapprod2d & + ) +!================================================================================================================= + +!--- input arguments: + logical,intent(in),optional:: diagflag + + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: has_reqc,has_reqi,has_reqs + integer,intent(in),optional:: do_radar_ref + + real(kind=RKIND),intent(in):: & + delt,g,rd,rv,t0c,den0,cpd,cpv,ep1,ep2,qmin,xls,xlv0,xlf0, & + cliq,cice,psat,denr + + real(kind=RKIND),intent(in):: & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max + + real(kind=RKIND),intent(in),dimension(ims:ime,kms:kme,jms:jme ):: & + den, & + pii, & + p, & + delz + +!inout arguments: + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme):: & + rain,rainncv,sr + + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme),optional:: & + snow,snowncv + + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme),optional:: & + graupel,graupelncv + + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + th, & + q, & + qc, & + qi, & + qr, & + qs, & + qg + + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + re_cloud, & + re_ice, & + re_snow + + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + refl_10cm + +#if(WRF_CHEM == 1) + logical,intent(in):: wetscav_on + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme ):: & + rainprod,evapprod #endif - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! further modifications : -! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 -! ==> higher accuracy and efficient at lower resolutions -! reflectivity computation from greg thompson, lim, jun 2011 -! ==> only diagnostic, but with removal of too large drops -! add hail option from afwa, aug 2014 -! ==> switch graupel or hail by changing no, den, fall vel. -! effective radius of hydrometeors, bae from kiaps, jan 2015 -! ==> consistency in solar insolation of rrtmg radiation -! bug fix in melting terms, bae from kiaps, nov 2015 -! ==> density of air is divided, which has not been -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! Juang and Hong (JH, 2010) Mon. Wea. Rev. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv - -#ifdef WRF_CHEM - REAL, DIMENSION( its:ite , kts:kte ), INTENT(INOUT) :: & - rainprod2d, & - evapprod2d -#endif - -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 3) :: & - rh, & - qs, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - qrs_tmp, & - falk, & - fall, & - work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & - fallc, & - falkc, & - work1c, & - work2c, & - workr, & - worka - REAL, DIMENSION( its:ite , kts:kte ) :: & - den_tmp, & - delz_tmp - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, & - pidep, & - pcond, & - prevp, & - psevp, & - pgevp, & - psdep, & - pgdep, & - praut, & - psaut, & - pgaut, & - piacr, & - pracw, & - praci, & - pracs, & - psacw, & - psaci, & - psacr, & - pgacw, & - pgaci, & - pgacr, & - pgacs, & - paacw, & - psmlt, & - pgmlt, & - pseml, & - pgeml - REAL, DIMENSION( its:ite , kts:kte ) :: & - qsum, & - xl, & - cpm, & - work2, & - denfac, & - xni, & - denqrs1, & - denqrs2, & - denqrs3, & - denqci, & - n0sfac - REAL, DIMENSION( its:ite ) :: delqrs1, & - delqrs2, & - delqrs3, & - delqi - REAL, DIMENSION( its:ite ) :: tstepsnow, & - tstepgraup - INTEGER, DIMENSION( its:ite ) :: mstep, & - numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: & - cpmcal, xlcal, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - REAL :: vt2ave - REAL :: holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n, idim, kdim -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! Optimizatin : A**B => exp(log(A)*(B)) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - idim = ite-its+1 - kdim = kte-kts+1 -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - qrs(i,k,3) = max(qrs(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo - do k = kts, kte - do i = its, ite - delz_tmp(i,k) = delz(i,k) - den_tmp(i,k) = den(i,k) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the surface rain, snow, graupel -! - do i = its, ite - rainncv(i) = 0. - if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i,lat) = 0. - if(PRESENT (graupelncv) .AND. PRESENT (graupel)) graupelncv(i,lat) = 0. - sr(i) = 0. -! new local array to catch step snow and graupel - tstepsnow(i) = 0. - tstepgraup(i) = 0. - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- - do k = kts, kte - do i = its, ite - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -!---------------------------------------------------------------- - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - workr(i,k) = work1(i,k,1) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - IF ( qsum(i,k) .gt. 1.e-15 ) THEN - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - ELSE - worka(i,k) = 0. - ENDIF - denqrs1(i,k) = den(i,k)*qrs(i,k,1) - denqrs2(i,k) = den(i,k)*qrs(i,k,2) - denqrs3(i,k) = den(i,k)*qrs(i,k,3) - if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0 - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & - delqrs1,dtcld,1,1) - call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & - denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) - do k = kts, kte - do i = its, ite - qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.) - qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) - qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.) - fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) - fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) - fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) - enddo - enddo - do i = its, ite - fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld - fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld - fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld - enddo - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres)/den(i,k) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/den(i,k) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work1c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - endif - enddo - enddo -! -! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) -! - do k = kte, kts, -1 - do i = its, ite - denqci(i,k) = den(i,k)*qci(i,k,2) - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & - delqi,dtcld,1,0) - do k = kts, kte - do i = its, ite - qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) - enddo - enddo - do i = its, ite - fallc(i,1) = delqi(i)/delz(i,1)/dtcld - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i) - rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) - endif - if(fallsum_qsi.gt.0.) then - tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - +tstepsnow(i) - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - +snowncv(i,lat) - snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat) - ENDIF - endif - if(fallsum_qg.gt.0.) then - tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - +tstepgraup(i) - IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN - graupelncv(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - + graupelncv(i,lat) - graupel(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i,lat) - ENDIF - endif - IF ( PRESENT (snowncv)) THEN - if(fallsum.gt.0.)sr(i)=(snowncv(i,lat) + graupelncv(i,lat))/(rainncv(i)+1.e-12) - ELSE - if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) - ENDIF - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qci(i,k,1).gt.qmin) then -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) - supcolt=min(supcol,50.) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! *(exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & -! *rslope(i,k,1)*dtcld,qrs(i,k,1)) - temp = rslope3(i,k,1) - temp = temp*temp*rslope(i,k,1) - supcolt=min(supcol,50.) - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qrs(i,k,1)) - qrs(i,k,3) = qrs(i,k,3) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! update the slope parameters for microphysics computation -! - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -!------------------------------------------------------------------ -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qci(i,k,1).gt.qc0) then - praut(i,k) = qck1*qci(i,k,1)**(7./3.) - praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0.and.qci(i,k,2).gt.qmin) then - if(qrs(i,k,1).gt.qcrmin) then -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & - +diameter**2*rslope(i,k,1) - praci(i,k) = pi*qci(i,k,2)*n0r*abs(vt2r-vt2i)*acrfac/4. - ! reduce collection efficiency (suggested by B. Wilt) - praci(i,k) = praci(i,k)*min(max(0.0,qrs(i,k,1)/qci(i,k,2)),1.)**2 - praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) -!------------------------------------------------------------- -! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & - *g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & - *rslopeb(i,k,1)/24./den(i,k) - ! reduce collection efficiency (suggested by B. Wilt) - piacr(i,k) = piacr(i,k)*min(max(0.0,qci(i,k,2)/qrs(i,k,1)),1.)**2 - piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - +diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - +diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - ! reduce collection efficiency (suggested by B. Wilt) - *min(max(0.0,qrs(i,k,2)/qci(i,k,1)),1.)**2 & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & - ! reduce collection efficiency (suggested by B. Wilt) - *min(max(0.0,qrs(i,k,3)/qci(i,k,1)),1.)**2 & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qsum(i,k) .gt. 1.e-15) then - paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k)) & - /(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & - +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & - +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) - pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - *(dens/den(i,k))*acrfac - ! reduce collection efficiency (suggested by B. Wilt) - pracs(i,k) = pracs(i,k)*min(max(0.0,qrs(i,k,1)/qrs(i,k,2)),1.)**2 - pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *(denr/den(i,k))*acrfac - ! reduce collection efficiency (suggested by B. Wilt) - psacr(i,k) = psacr(i,k)*min(max(0.0,qrs(i,k,2)/qrs(i,k,1)),1.)**2 - psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - *acrfac - ! reduce collection efficiency (suggested by B. Wilt) - pgacr(i,k) = pgacr(i,k)*min(max(0.0,qrs(i,k,3)/qrs(i,k,1)),1.)**2 - pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G): This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - /xlf,-qrs(i,k,2)/dtcld),0.) -!------------------------------------------------------------- -! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & - /xlf,-qrs(i,k,3)/dtcld),0.) - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.and.ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)),qrs(i,k,2)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & - *rslope2(i,k,2)+precs2*work2(i,k) & - *coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qrs(i,k,1).lt.1.e-4.and.qrs(i,k,2).lt.1.e-4) delta2=1. - if(qrs(i,k,1).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - +pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & - +pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & - *delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & - +psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qrs(i,k,3)) - source = -(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - +pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-piacr(i,k)-pgacr(i,k) & - -psacr(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & - +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - *dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - -pgaut(i,k)+piacr(i,k)*delta3 & - +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - *dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3) & - +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - +pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - +pgacr(i,k)+pgacs(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & - -paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qrs(i,k,3)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - -pgeml(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & - +pseml(i,k))*dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & - +pgeml(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops -#ifdef WRF_CHEM - rainprod2d = praut+pracw+praci+psaci+pgaci+psacw+pgacw+paacw+psaut - evapprod2d = -(prevp+psevp+pgevp+psdep+pgdep) -#endif +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg - END SUBROUTINE wsm62d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,hail_opt,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv - INTEGER, INTENT(IN) :: hail_opt ! RAS - LOGICAL, INTENT(IN) :: allowed_to_read +!local variables and arrays: + logical:: do_microp_re + integer:: i,j,k -! RAS13.1 define graupel parameters as graupel-like or hail-like, -! depending on namelist option - IF (hail_opt .eq. 1) THEN !Hail! - n0g = 4.e4 - deng = 700. - avtg = 285.0 - bvtg = 0.8 - lamdagmax = 2.e4 - ELSE !Graupel! - n0g = 4.e6 - deng = 500 - avtg = 330.0 - bvtg = 0.8 - lamdagmax = 6.e4 - ENDIF -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. ! syb -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr6 = 6.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g6pbr = rgmma(bvtr6) - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - pacrg = pi*n0g*avtg*g3pbg*.25 - g5pbgo2 = rgmma(bvtg2) - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax + real(kind=RKIND),dimension(kts:kte):: qv1d,t1d,p1d,qr1d,qs1d,qg1d,dBZ + real(kind=RKIND),dimension(kts:kte):: den1d,qc1d,qi1d,re_qc,re_qi,re_qs -!+---+-----------------------------------------------------------------+ -!..Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - xam_r = PI*denr/6. - xbm_r = 3. - xmu_r = 0. - xam_s = PI*dens/6. - xbm_s = 3. - xmu_s = 0. - xam_g = PI*deng/6. - xbm_g = 3. - xmu_g = 0. + real(kind=RKIND),dimension(its:ite):: rainncv_hv,rain_hv,sr_hv + real(kind=RKIND),dimension(its:ite):: snowncv_hv,snow_hv + real(kind=RKIND),dimension(its:ite):: graupelncv_hv,graupel_hv + real(kind=RKIND),dimension(its:ite,kts:kte):: t_hv,den_hv,p_hv,delz_hv + real(kind=RKIND),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,qr_hv,qs_hv,qg_hv + real(kind=RKIND),dimension(its:ite,kts:kte):: re_qc_hv,re_qi_hv,re_qs_hv - call radar_init -!+---+-----------------------------------------------------------------+ +!----------------------------------------------------------------------------------------------------------------- -! - END SUBROUTINE wsm6init -!------------------------------------------------------------------------------ - subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte,3) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt - REAL, DIMENSION( its:ite , kts:kte) :: & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, lamdas, lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) - vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) - vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) - if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 - if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 - if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 - enddo - enddo - END subroutine slope_wsm6 -!----------------------------------------------------------------------------- - subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtr - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_rain -!------------------------------------------------------------------------------ - subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdas, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = rslope(i,k)**bvts - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_snow -!---------------------------------------------------------------------------------- - subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopegmax - rslopeb(i,k) = rslopegbmax - rslope2(i,k) = rslopeg2max - rslope3(i,k) = rslopeg3max - else - rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtg - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_graup -!--------------------------------------------------------------------------------- -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),precip(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - enddo - qa(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - rql(i,:) = qn(:) -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter,ist - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 - precip1(:) = 0.0 - precip2(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - qq2(:) = rql2(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) + qq2(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qa2(k) = qq2(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - qr2(k) = qa2(k)/den(k) - enddo - qa(km+1) = 0.0 - qa2(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) - do k = 1, km - tmp(k) = max((qr(k)+qr2(k)), 1.E-15) - IF ( tmp(k) .gt. 1.e-15 ) THEN - wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) - ELSE - wa(k) = 0. - ENDIF - enddo - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & -! ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif - ist_loop : do ist = 1, 2 - if (ist.eq.2) then - qa(:) = qa2(:) - endif -! - precip(i) = 0. -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - if(ist.eq.1) then - rql(i,:) = qn(:) - precip1(i) = precip(i) - else - rql2(i,:) = qn(:) - precip2(i) = precip(i) - endif - enddo ist_loop -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm6 - -!+---+-----------------------------------------------------------------+ - - subroutine refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii, jj) - - IMPLICIT NONE - -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ - -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg - REAL:: temp_C - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg - DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g - DOUBLE PRECISION:: lamr, lams, lamg - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg - - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g - - INTEGER:: i, k, k_0, kbot, n - LOGICAL:: melti - - DOUBLE PRECISION:: cback, x, eta, f_d - REAL, PARAMETER:: R=287. - -!+---+ - - do k = kts, kte - dBZ(k) = -35.0 - enddo - -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - temp_C = min(-0.001, temp(K)-273.15) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) - - if (qr1d(k) .gt. 1.E-9) then - rr(k) = qr1d(k)*rho(k) - N0_r(k) = n0r - lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - L_qr(k) = .true. - else - rr(k) = 1.E-12 - L_qr(k) = .false. - endif - - if (qs1d(k) .gt. 1.E-9) then - rs(k) = qs1d(k)*rho(k) - N0_s(k) = min(n0smax, n0s*exp(-alpha*temp_C)) - lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - L_qs(k) = .true. - else - rs(k) = 1.E-12 - L_qs(k) = .false. - endif - - if (qg1d(k) .gt. 1.E-9) then - rg(k) = qg1d(k)*rho(k) - N0_g(k) = n0g - lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - L_qg(k) = .true. - else - rg(k) = 1.E-12 - L_qg(k) = .false. - endif - enddo - -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue - -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ - - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_s/900.0)*(xam_s/900.0) & - * N0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_g/900.0)*(xam_g/900.0) & - * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo - - -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ - - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 - -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n)) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif - - -!..Reflectivity contributed by melting graupel - - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxDg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif + do j = jts,jte + do i = its,ite + !input arguments: + do k = kts,kte + den_hv(i,k) = den(i,k,j) + p_hv(i,k) = p(i,k,j) + delz_hv(i,k) = delz(i,k,j) enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_wsm6 -!+---+-----------------------------------------------------------------+ -!----------------------------------------------------------------------- - subroutine effectRad_wsm6 (t, qc, qi, qs, rho, qmin, t0c, & - re_qc, re_qi, re_qs, kts, kte, ii, jj) - -!----------------------------------------------------------------------- -! Compute radiation effective radii of cloud water, ice, and snow for -! single-moment microphysics. -! These are entirely consistent with microphysics assumptions, not -! constant or otherwise ad hoc as is internal to most radiation -! schemes. -! Coded and implemented by Soo ya Bae, KIAPS, January 2015. -!----------------------------------------------------------------------- + !inout arguments: + rain_hv(i) = rain(i,j) + + do k = kts,kte + t_hv(i,k) = th(i,k,j)*pii(i,k,j) + qv_hv(i,k) = q(i,k,j) + qc_hv(i,k) = qc(i,k,j) + qi_hv(i,k) = qi(i,k,j) + qr_hv(i,k) = qr(i,k,j) + qs_hv(i,k) = qs(i,k,j) + qg_hv(i,k) = qg(i,k,j) + enddo + enddo - implicit none + if(present(snow) .and. present(snowncv)) then + do i = its,ite + snow_hv(i) = snow(i,j) + enddo + endif + if(present(graupel) .and. present(graupelncv)) then + do i = its,ite + graupel_hv(i) = graupel(i,j) + enddo + endif + +!--- call to cloud microphysics scheme: + call mp_wsm6_run(t=t_hv,q=qv_hv,qc=qc_hv,qi=qi_hv,qr=qr_hv,qs=qs_hv,qg=qg_hv, & + den=den_hv,p=p_hv,delz=delz_hv,delt=delt,g=g,cpd=cpd,cpv=cpv, & + rd=rd,rv=rv,t0c=t0c,ep1=ep1,ep2=ep2,qmin=qmin,xls=xls,xlv0=xlv0, & + xlf0=xlf0,den0=den0,denr=denr,cliq=cliq,cice=cice,psat=psat, & + rain=rain_hv,rainncv=rainncv_hv,sr=sr_hv,snow=snow_hv, & + snowncv=snowncv_hv,graupel=graupel_hv,graupelncv=graupelncv_hv, & + its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg & +#if(WRF_CHEM == 1) + ,rainprod2d=rainprod_hv,evapprod2d=evapprodhv & +#endif + ) + + do i = its,ite + !inout arguments: + rain(i,j) = rain_hv(i) + rainncv(i,j) = rainncv_hv(i) + sr(i,j) = sr_hv(i) + + do k = kts,kte + th(i,k,j) = t_hv(i,k)/pii(i,k,j) + q(i,k,j) = qv_hv(i,k) + qc(i,k,j) = qc_hv(i,k) + qi(i,k,j) = qi_hv(i,k) + qr(i,k,j) = qr_hv(i,k) + qs(i,k,j) = qs_hv(i,k) + qg(i,k,j) = qg_hv(i,k) + enddo + enddo -!..Sub arguments - integer, intent(in) :: kts, kte, ii, jj - real, intent(in) :: qmin - real, intent(in) :: t0c - real, dimension( kts:kte ), intent(in):: t - real, dimension( kts:kte ), intent(in):: qc - real, dimension( kts:kte ), intent(in):: qi - real, dimension( kts:kte ), intent(in):: qs - real, dimension( kts:kte ), intent(in):: rho - real, dimension( kts:kte ), intent(inout):: re_qc - real, dimension( kts:kte ), intent(inout):: re_qi - real, dimension( kts:kte ), intent(inout):: re_qs -!..Local variables - integer:: i,k - integer :: inu_c - real, dimension( kts:kte ):: ni - real, dimension( kts:kte ):: rqc - real, dimension( kts:kte ):: rqi - real, dimension( kts:kte ):: rni - real, dimension( kts:kte ):: rqs - real :: temp - real :: lamdac - real :: supcol, n0sfac, lamdas - real :: diai ! diameter of ice in m - logical :: has_qc, has_qi, has_qs -!..Minimum microphys values - real, parameter :: R1 = 1.E-12 - real, parameter :: R2 = 1.E-6 -!..Mass power law relations: mass = am*D**bm - real, parameter :: bm_r = 3.0 - real, parameter :: obmr = 1.0/bm_r - real, parameter :: nc0 = 3.E8 -!----------------------------------------------------------------------- - has_qc = .false. - has_qi = .false. - has_qs = .false. + if(present(snow) .and. present(snowncv)) then + do i = its,ite + snow(i,j) = snow_hv(i) + snowncv(i,j) = snowncv_hv(i) + enddo + endif + if(present(graupel) .and. present(graupelncv)) then + do i = its,ite + graupel(i,j) = graupel_hv(i) + graupelncv(i,j) = graupelncv_hv(i) + enddo + endif + +#if(WRF_CHEM == 1) + if(wetscav_on) then + do k = kts,kte + do i = its, ite + rainprod(i,k,j) = rainprod_hv(i,k) + evapprod(i,k,j) = evapprod_hv(i,k) + enddo + enddo + else + do k = kts,kte + do i = its, ite + rainprod(i,k,j) = 0. + evapprod(i,k,j) = 0. + enddo + enddo + endif +#endif - do k = kts, kte - ! for cloud - rqc(k) = max(R1, qc(k)*rho(k)) - if (rqc(k).gt.R1) has_qc = .true. - ! for ice - rqi(k) = max(R1, qi(k)*rho(k)) - temp = (rho(k)*max(qi(k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - ni(k) = min(max(5.38e7*temp,1.e3),1.e6) - rni(k)= max(R2, ni(k)*rho(k)) - if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. - ! for snow - rqs(k) = max(R1, qs(k)*rho(k)) - if (rqs(k).gt.R1) has_qs = .true. - enddo +!--- call to computation of effective radii for cloud water, cloud ice, and snow: + do_microp_re = .false. + if(has_reqc == 1 .and. has_reqi == 1 .and. has_reqs == 1) do_microp_re = .true. - if (has_qc) then - do k=kts,kte - if (rqc(k).le.R1) CYCLE - lamdac = (pidnc*nc0/rqc(k))**obmr - re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + do k = kts,kte + do i = its,ite + t_hv(i,k) = th(i,k,j)*pii(i,k,j) + re_qc_hv(i,k) = re_cloud(i,k,j) + re_qi_hv(i,k) = re_ice(i,k,j) + re_qs_hv(i,k) = re_snow(i,k,j) enddo - endif + enddo - if (has_qi) then - do k=kts,kte - if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE - diai = 11.9*sqrt(rqi(k)/ni(k)) - re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) - enddo - endif + call mp_wsm6_effectRad_run(do_microp_re,t_hv,qc_hv,qi_hv,qs_hv,den_hv,qmin,t0c, & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max,re_qc_hv, & + re_qi_hv,re_qs_hv,its,ite,kts,kte,errmsg,errflg) - if (has_qs) then - do k=kts,kte - if (rqs(k).le.R1) CYCLE - supcol = t0c-t(k) - n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) - lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) - re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + do k = kts,kte + do i = its,ite + re_cloud(i,k,j) = re_qc_hv(i,k) + re_ice(i,k,j) = re_qi_hv(i,k) + re_snow(i,k,j) = re_qs_hv(i,k) enddo - endif + enddo + + enddo - end subroutine effectRad_wsm6 -!----------------------------------------------------------------------- + end subroutine wsm6 -END MODULE module_mp_wsm6 +!================================================================================================================= + end module module_mp_wsm6 +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F b/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F index fb9481c9d8..5a3699aa7f 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F @@ -4,9 +4,14 @@ MODULE module_ra_cam_support ! background. ! Laura D. Fowler (birch.ucar.edu) / 2013-07-01. use mpas_atmphys_utilities -#endif + use mpas_kind_types, only : R8KIND + use mpas_io_units, only: mpas_new_unit, mpas_release_unit + implicit none + integer, parameter :: r8 = R8KIND +#else implicit none integer, parameter :: r8 = 8 +#endif real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90 integer, parameter:: bigint = int(O'17777777777') ! largest possible 32-bit integer @@ -3344,12 +3349,19 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & WRITE(message,*)'num_months = ',num_months CALL wrf_debug(50,message) +#if defined(mpas) + call mpas_new_unit(pin_unit) +#else pin_unit = 27 +#endif OPEN(pin_unit, FILE='ozone_plev.formatted',FORM='FORMATTED',STATUS='OLD') do k = 1,levsiz READ (pin_unit,*)pin(k) end do - close(27) + close(pin_unit) +#if defined(mpas) + call mpas_release_unit(pin_unit) +#endif do k=1,levsiz pin(k) = pin(k)*100. @@ -3357,17 +3369,28 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & !-- read in ozone lat data +#if defined(mpas) + call mpas_new_unit(lat_unit) +#else lat_unit = 28 +#endif OPEN(lat_unit, FILE='ozone_lat.formatted',FORM='FORMATTED',STATUS='OLD') do j = 1,latsiz READ (lat_unit,*)lat_ozone(j) end do - close(28) + close(lat_unit) +#if defined(mpas) + call mpas_release_unit(lat_unit) +#endif !-- read in ozone data +#if defined(mpas) + call mpas_new_unit(oz_unit) +#else oz_unit = 29 +#endif OPEN(oz_unit, FILE='ozone.formatted',FORM='FORMATTED',STATUS='OLD') do m=2,num_months @@ -3379,7 +3402,10 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & enddo enddo enddo - close(29) + close(oz_unit) +#if defined(mpas) + call mpas_release_unit(oz_unit) +#endif !-- latitudinally interpolate ozone data (and extend longitudinally) diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index a2ee96b621..be36c4afb1 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -9873,9 +9873,10 @@ subroutine rrtmg_swrad( & noznlevels,pin,o3clim,gsw,swcf,rthratensw, & has_reqc,has_reqi,has_reqs,re_cloud, & re_ice,re_snow, & - swupt, swuptc, swdnt, swdntc, & - swupb, swupbc, swdnb, swdnbc, & + swupt,swuptc,swdnt,swdntc, & + swupb,swupbc,swdnb,swdnbc, & swupflx, swupflxc, swdnflx, swdnflxc, & + swddir,swddni,swddif, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -9916,6 +9917,8 @@ subroutine rrtmg_swrad( & real,intent(inout),dimension(ims:ime,kms:kme,jms:jme):: rthratensw !--- output arguments: + real,intent(out),dimension(ims:ime,jms:jme),optional:: & + swddir,swddni,swddif real,intent(out),dimension(ims:ime,kms:kme+2,jms:jme ),optional:: & swupflx,swupflxc,swdnflx,swdnflxc @@ -10411,6 +10414,12 @@ subroutine rrtmg_swrad( & swdnbc(i,j) = swdflxc(1,1) endif + if(present(swddir) .and. present(swddni) .and. present(swddif)) then + swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10 + swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10 + swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10 + endif + if(present (swupflx)) then do k = kts, kte+2 swupflx(i,k,j) = swuflx(1,k) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F index 5278ff60b8..eea050b236 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F @@ -1,14 +1,20 @@ MODULE module_sf_bem -! ----------------------------------------------------------------------- -! Variables and constants used in the BEM module -! ----------------------------------------------------------------------- -#ifdef mpas -use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else -#define FATAL_ERROR(M) write(0,*) M ; stop +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif + +! ----------------------------------------------------------------------- +! Variables and constants used in the BEM module +! ----------------------------------------------------------------------- real emins !emissivity of the internal walls parameter (emins=0.9) @@ -27,6 +33,7 @@ MODULE module_sf_bem real hum_rat !power of the A.C. drying/moistening the indoor air [(Kg/kg)/s] parameter(hum_rat=1.e-06) + real,parameter :: effpv=0.19 ! Efficiency of PV panels installed at the roofs, typical values [0.10,0.15] CONTAINS @@ -35,16 +42,21 @@ MODULE module_sf_bem subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & nwal,nflo,nrof,ngrd,hswalout,gswal, & - hswinout,hsrof,gsrof, & + hswinout,hsrof,lsrof,gsrof,hspv, & latent,sigma,albwal,albwin,albrof, & emrof,emwal,emwin,rswal,rlwal,rair,cp, & rhoout,tout,humout,press, & - rs,rl,dzwal,cswal,kwal,pwin,cop,beta,sw_cond, & + rs,swddif,rl,dzwal,cswal,kwal,pwin,cop,beta,sw_cond, & timeon,timeoff,targtemp,gaptemp,targhum,gaphum, & - perflo,hsesf,hsequip,dzflo, & + perflo,gr_frac_roof,pv_frac_roof,gr_flag, & + uout,vout, & + hsesf,hsequip,dzflo, & csflo,kflo,dzgrd,csgrd,kgrd,dzrof,csrof, & krof,tlev,shumlev,twal,twin,tflo,tgrd,trof, & - hsout,hlout,consump,hsvent,hlvent) + hsout,hlout,consump,eppv,tpv,hsvent,hlvent,hfgr,& + tr_av,tpv_print,sfpv,sfr_indoor) + + ! --------------------------------------------------------------------- @@ -97,7 +109,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real dt !time step [s] - integer nzcanm !Maximum number of vertical levels in the urban grid + integer nzcanm !Maximum number of vertical levels in the urban grid integer nlev !number of floors in the building integer nwal !number of levels inside the wall integer nrof !number of levels inside the roof @@ -127,6 +139,11 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real, intent(in) :: targhum ! Target humidity of A/C systems real, intent(in) :: gaphum ! Comfort range of specific humidity real, intent(in) :: perflo ! Peak number of occupants per unit floor area + real gr_frac_roof + real pv_frac_roof + integer gr_flag + real uout(nzcanm) + real vout(nzcanm) real, intent(in) :: hsesf ! real, intent(in) :: hsequip(24) ! @@ -145,11 +162,12 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real dzflo(nflo) !Layer sizes of floors [m] real dzrof(nrof) !Layer sizes of roof [m] real dzgrd(ngrd) !Layer sizes of ground [m] - + real tpv + real tr_av real latent !latent heat of evaporation [J/Kg] - - real rs !external short wave radiation [W/m2] + real swddif + real rs !external short wave radiation [W/m2] real rl !external long wave radiation [W/m2] real rswal(4,nzcanm) !short wave radiation reaching the exterior walls [W/m2] real rlwal(4,nzcanm) !long wave radiation reaching the walls [W/m2] @@ -161,11 +179,11 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real hswalout(4,nzcanm) !outside walls sensible heat flux [W/m2] real hswinout(4,nzcanm) !outside window sensible heat flux [W/m2] real hsrof !Sensible heat flux at the roof [W/m2] - - real rair !ideal gas constant [J.kg-1.K-1] + real lsrof + real rair !ideal gas constant [J.kg-1.K-1] real sigma !parameter (wall is not black body) [W/m2.K4] real cp !specific heat of air [J/kg.K] - + real hfgr !Green roof heat flux !Input-Output !------------ @@ -181,9 +199,11 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real consump(nzcanm) !Consumption for the a.c. in each floor [W] real hsvent(nzcanm) !sensible heat generated by natural ventilation [W] real hlvent(nzcanm) !latent heat generated by natural ventilation [W] - real gsrof !heat flux flowing inside the roof [W/m^2] - real gswal(4,nzcanm) !heat flux flowing inside the floors [W/m^2] - + real gsrof !heat flux flowing inside the roof [W/m2] + real hspv !Sensible heat flux at the roof from the PV panels [W/m2] + real gswal(4,nzcanm) !heat flux flowing inside the floors [W/m2] + real eppv !Electricity production of PV panels [W] + real sfr_indoor,sfpv,tpv_print ! Local: ! ----- integer swwal !swich for the physical coefficients calculation @@ -234,10 +254,13 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real hsoutbuild !Total sensible heat ejected into the atmosphere[W] !by the air conditioning system and per building real nhourday !number of hours from midnight, local time + real hfgrd !Dummy variable to assign hfgr=0 to walls, windows and ground + +! + parameter(hfgrd=0) !-------------------------------------------- !Initialization !-------------------------------------------- - do ilev=1,nzcanm hseqocc(ilev)=0. hleqocc(ilev)=0. @@ -401,11 +424,15 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & end do ! ivw end do ! ilev -!Roof - - call radfluxs(radflux,albrof,rs,emrof,rl,sigma,trof(nrof)) - - hrrof=radflux +!Roof and PV panels + + if (pv_frac_roof.eq.0.) then + call radfluxs(radflux,albrof,rs,emrof,rl,sigma,tr_av) + hrrof=radflux + else + call radfluxspv(nzcanm,nlev,albrof,rs,swddif,emrof,rl,tr_av,tout,sigma,radflux,pv_frac_roof,tpv) + hrrof=radflux + endif !Internal walls for intermediate rooms @@ -548,7 +575,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & !Vertical fluxes for windows do ilev=1,nlev - + do ivw=1,4 call hsinsflux (2,1,tlev(ilev),twin(ivw,ilev),hs) @@ -594,7 +621,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & call hsinsflux (1,2,tlev(nlev),trof(1),hs) hswalins(6,nlev)=hs - + sfr_indoor= hswalins(6,nlev) else ! Bottom<--->Top call hsinsflux (1,2,tlev(1),tgrd(ngrd),hs) @@ -606,7 +633,15 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & hswalins(6,nlev)=hs end if +!! +!! Calculation of the sensible heat fluxes from the PV panels & electricity producti + + if(pv_frac_roof.gt.0)then + call hsfluxpv(nzcanm,nlev,bl,bw,albrof,rs,swddif,emrof,rl,tr_av,tout,sigma,hspv,eppv,pv_frac_roof,uout,vout,tpv,dt) + sfpv=hspv + tpv_print=tpv + endif !Calculation of the temperature for the different surfaces ! -------------------------------------------------------- @@ -624,7 +659,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & do iwal=1,nwal twal1D(iwal)=twal(ivw,iwal,ilev) end do - + call wall(swwal,nwal,dt,dzwal,kwal,cswal,htot,twal1D) do iwal=1,nwal @@ -695,19 +730,25 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & swwal=1 htot(1)=hswalins(6,nlev)+hrwalins(6,nlev) - htot(2)=hsrof+hrrof + htot(2)=hsrof+hrrof+lsrof gsrof=htot(2) do irof=1,nrof trof1D(irof)=trof(irof) - end do - - call wall(swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D) - + + end do + + if(gr_flag.eq.1)then + call wall_gr(hfgr,gr_frac_roof,swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D) + else + call wall(swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D) + endif do irof=1,nrof trof(irof)=trof1D(irof) - end do + + end do + ! Calculation of the heat fluxes and of the temperature of the rooms ! ------------------------------------------------------------------ @@ -728,6 +769,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & call fluxvent(cpint,rhoint,vollev,tlev(ilev),tout(ilev), & latent,humout(ilev),rhoout(ilev),shumlev(ilev),& beta,hsvent(ilev),hlvent(ilev)) + !Calculation of the heat generated by conduction @@ -782,11 +824,95 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & return end subroutine BEM - +!====6=8===============================================================72 +!====6=8===============================================================72 + subroutine hsfluxpv(nz,n,bl,bw,albr,rs,swddif,emr,rl,tr,tair,sigma,hspv,eppv,pv_frac_roof,uout,vout,tpv,dt) +! + implicit none +! +! Input variables +! + integer,intent(in) :: nz !Maximum number of vertical levels in the urban grid + real,intent(in) :: bl !Building length [m] + real,intent(in) :: bw !Building width [m] + real,intent(in) :: albr !albedo of the roof (ext.) + real,intent(in) :: emr !emissivity of the roof (ext.) + real,intent(in) :: rs !external short wave radiation [W/m2] + real,intent(in) :: rl !external long wave radiation [W/m2] + real,intent(in) :: tr !roof surface temperature [K] + real,intent(in) :: pv_frac_roof ! fraction of PV [] + real,intent(in) :: sigma !Stefan-Boltzmann constant [W/m2.K4] + real,intent(in),dimension(1:nz) :: tair !external temperature [K] + integer,intent(in) :: n !number of floors in the building + real,intent(in), dimension(1:nz) :: uout + real,intent(in), dimension(1:nz) :: vout + real,intent(in) :: dt + real,intent(in) :: swddif +! Output variables +! + real,intent(inout) :: hspv ! Sensible heat flux from the PV panels to the atmosphere [W/m2] + real,intent(inout) :: eppv ! Electricity production from PV panels [W] + real,intent(inout) :: tpv !Temperature of the PV panels [K] +! +! Local variables +! + real,parameter :: albpv=0.11 ! albedo of the PV panels + real,parameter :: empv_down=0.95 ! emissivity of the PV panels + real,parameter :: empv_up=0.79 + real, parameter :: T_amb=25 + real, parameter :: tiltangle=0. + real, parameter :: a=3.8 + real, parameter :: b=6.9 + + real, parameter :: r1=2330. + real, parameter :: r2=1200. + real, parameter :: r3=3000. + real, parameter :: c1=677. + real, parameter :: c2=1250. + real, parameter :: c3=500. + real, parameter :: d1=0.0003 + real, parameter :: d2=0.0005 + real, parameter :: d3=0.003 + real, parameter :: F12=1. + real :: lwuppv !Long-wave emitted by the PV panels to the sky [W/m2] + real :: lwdwr !Long-wave incoming radiation on the roof [W/m2] + real :: lwupr !Long-wave coming up from the roof intercepted by the PV panels [W/m2] + real :: enerpv !Energy produced by PV panels [W/m2] + real :: hc + real :: sw_d + real :: lw_d + real :: lwpv_out + real :: tpv_new + real :: hdown + real :: hup + real :: deltat + real :: uroof + real :: hrad + real :: Cm + real :: hf + Cm=r1*c1*d1+r2*c2*d2+r3*c3*d3 + hrad=sigma/((1-empv_down)/empv_down+1/F12+(1-emr)/emr) + uroof=(uout(n+1)**2+vout(n+1)**2)**0.5 + deltat=tpv-tair(n+1) + hf=2.5*(40./100.*uroof)**(0.5) + hc=9.842*abs(deltat)**(1./3.)/(7.283-abs(cos(tiltangle))) + hup=sqrt(hc**2.+(hf)**2.) + hc=1.810*abs(deltat)**(1./3.)/(1.382+abs(cos(tiltangle))) + hdown=sqrt(hc**2.+(hf)**2.) + enerpv=effpv*rs*min(1.,1.-0.005*(tpv-(T_amb+273.15))) + sw_d=(1-albpv)*(rs) + lw_d=empv_up*rl + lwpv_out=empv_up*sigma*tpv**4. + lwupr=hrad*(tr**4-tpv**4.) + hspv=(hup+hdown)*(tpv-tair(n+1)) + tpv=tpv+(sw_d+lw_d-lwpv_out+lwupr-hspv-enerpv)/Cm*dt + eppv=enerpv*pv_frac_roof*bl*bw + return + end subroutine hsfluxpv !====6=8===============================================================72 !====6=8===============================================================72 - subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) + subroutine wall_gr(hfgr,gr_frac_roof,swwall,nz,dt,dz,k,cs,flux,temp) !______________________________________________________________________ @@ -826,12 +952,16 @@ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) !Input: !----- + real hfgr !Green roof heat flux + real gr_frac_roof !Green roof fraction + integer nz !Number of layers inside the material real dt !Time step real dz(nz) !Layer sizes [m] real cs(nz) !Specific heat of the material [J/(m3.K)] real k(nz+1) !Thermal conductivity in each layers (face) [W/(m.K)] real flux(2) !Internal and external flux terms. + !Input-Output: !------------- @@ -875,25 +1005,140 @@ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) a(-1,1)=0. a(0,1)=1+k2(1) a(1,1)=-k2(1) - b(1)=temp(1)+flux(1)*kc(1) -!! -!!We can fixed the internal temperature -!! -!! a(-1,1)=0. -!! a(0,1)=1 -!! a(1,1)=0. -!! -!! b(1)=temp(1) -!! -!Computation of the internal values (iz=2,...,n-1) of A and B: + do iz=2,nz-1 + a(-1,iz)=-k1(iz) + if(iz.eq.5)then + a(-1,iz)=-k1(iz) + a(0,iz)=1+k1(iz)+(1-gr_frac_roof)*k2(iz) + b(iz)=temp(iz)+(gr_frac_roof*hfgr*dt)/dz(iz) + a(1,iz)=-k2(iz)*(1-gr_frac_roof) + else + a(0,iz)=1.+k1(iz)+k2(iz) + b(iz)=temp(iz) + a(1,iz)=-k2(iz) + endif + + + end do + +!Computation of the external value (iz=n) of A and B: + + a(-1,nz)=-k1(nz) + a(0,nz)=1.+k1(nz) + a(1,nz)=0. + b(nz)=temp(nz)+kc(nz)*flux(2) + +!Resolution of the system A*T(n+1)=B + + call tridia(nz,a,b,temp) + + + return + end subroutine wall_gr + +!====6=8===============================================================72 +!====6=8===============================================================72 + + + subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) + +!______________________________________________________________________ + +!The aim of this subroutine is to solve the 1D heat fiffusion equation +!for roof, walls and streets: +! +! dT/dt=d/dz[K*dT/dz] where: +! +! -T is the surface temperature(wall, street, roof) +! -Kz is the heat diffusivity inside the material. +! +!The resolution is done implicitly with a FV discretisation along the +!different layers of the material: + +! ____________________________ +! n * +! * +! * +! ____________________________ +! i+2 +! I+1 +! ____________________________ +! i+1 +! I ==> [T(I,n+1)-T(I,n)]/DT= +! ____________________________ [F(i+1)-F(i)]/DZI +! i +! I-1 ==> A*T(n+1)=B where: +! ____________________________ +! i-1 * * A is a TRIDIAGONAL matrix. +! * * B=T(n)+S takes into account the sources. +! * +! 1 ____________________________ + +!________________________________________________________________ + + implicit none + +!Input: +!----- + integer nz !Number of layers inside the material + real dt !Time step + real dz(nz) !Layer sizes [m] + real cs(nz) !Specific heat of the material [J/(m3.K)] + real k(nz+1) !Thermal conductivity in each layers (face) [W/(m.K)] + real flux(2) !Internal and external flux terms. + + +!Input-Output: +!------------- + + integer swwall !swich for the physical coefficients calculation + real temp(nz) !Temperature at each layer + +!Local: +!----- + + real a(-1:1,nz) ! a(-1,*) lower diagonal A(i,i-1) + ! a(0,*) principal diagonal A(i,i) + ! a(1,*) upper diagonal A(i,i+1). + + real b(nz) !Coefficients of the second term. + real k1(20) + real k2(20) + real kc(20) + save k1,k2,kc + integer iz + +!________________________________________________________________ +! +!Calculation of the coefficients + + if (swwall.eq.1) then + + if (nz.gt.20) then + write(*,*) 'number of layers in the walls/roofs too big ',nz + write(*,*) 'please decrease under of',20 + stop + endif + + call wall_coeff(nz,dt,dz,cs,k,k1,k2,kc) + swwall=0 + + end if + +!Computation of the first value (iz=1) of A and B: + + a(-1,1)=0. + a(0,1)=1+k2(1) + a(1,1)=-k2(1) + b(1)=temp(1)+flux(1)*kc(1) do iz=2,nz-1 - a(-1,iz)=-k1(iz) - a(0,iz)=1+k1(iz)+k2(iz) - a(1,iz)=-k2(iz) - b(iz)=temp(iz) + a(-1,iz)=-k1(iz) + a(0,iz)=1+k1(iz)+k2(iz) + b(iz)=temp(iz) + a(1,iz)=-k2(iz) end do !Computation of the external value (iz=n) of A and B: @@ -901,12 +1146,12 @@ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) a(-1,nz)=-k1(nz) a(0,nz)=1+k1(nz) a(1,nz)=0. - b(nz)=temp(nz)+flux(2)*kc(nz) - + !Resolution of the system A*T(n+1)=B call tridia(nz,a,b,temp) + return end subroutine wall @@ -983,7 +1228,7 @@ subroutine hsinsflux(swsurf,swwin,tin,tw,hsins) !Input !---- integer swsurf !swich for the type of surface (horizontal/vertical) - integer swwin !swich for the type of surface (window/wall) + integer swwin !swich for the type of surface (window/wall) real tin !Inside temperature [K] real tw !Internal wall temperature [K] @@ -993,7 +1238,7 @@ subroutine hsinsflux(swsurf,swwin,tin,tw,hsins) real hsins !internal sensible heat flux [W/m2] !Local !----- - real hc !heat conduction coefficient [W/C.m2] + real hc !heat conduction coefficient [W/\B0C.m2] !-------------------------------------------------------------------- if (swsurf.eq.2) then !vertical surface @@ -1031,7 +1276,7 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,& real albwin !albedo of the windows real albwal !albedo of the internal wall real rswal(4) !incoming short wave radiation [W/m2] - real surwal(6) !surface of the indoor walls [m2] + real surwal(6) !surface of the indoor walls [m2] real bw,bl !width of the walls [m] real zw !height of the wall [m] real pwin !window proportion @@ -1043,8 +1288,8 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,& !Local !----- real transmit !transmittance of the direct/diffused radiation - real rstr !solar radiation transmitted through the windows - real surtotwal !total indoor surface of the walls in the room + real rstr !solar radiation transmitted through the windows + real surtotwal !total indoor surface of the walls in the room integer iw real b(6) !second member for the system real a(6,6) !matrix for the system @@ -1061,7 +1306,7 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,& enddo !We suppose that the radiation is spread isotropically within the -!room when it passes through the windows, so the flux [W/m^2] in every +!room when it passes through the windows, so the flux [W/m2] in every !wall is: surtotwal=0. @@ -1315,8 +1560,8 @@ subroutine algebra_long(emwal,emwin,sigma,twalint,twinint,& real zw !height of the wall real fprl_int !view factor real fnrm_int !view factor - real fnrm_intx !view factor - real fnrm_inty !view factor + real fnrm_intx !view factor + real fnrm_inty !view factor !Output !------ @@ -1329,7 +1574,7 @@ subroutine algebra_long(emwal,emwin,sigma,twalint,twinint,& real b_wind(6) real emwal_av !averadge emissivity of the wall real emwin_av !averadge emissivity of the window - real em_av !averadge emissivity + real em_av !averadge emissivity real twal_int(6) !twalint real twin(4) !twinint !------------------------------------------------------------------ @@ -1669,7 +1914,7 @@ subroutine phiequ(nhourday,hsesf,hsequip,hsequ) !Output !------ - real hsequ !sensible heat gain from equipment [W/m^2] + real hsequ !sensible heat gain from equipment [Wm\AF2] !--------------------------------------------------------------------- @@ -2299,7 +2544,52 @@ subroutine radfluxs(radflux,alb,rs,em,rl,sigma,twal) return end subroutine radfluxs - +!====6=8===============================================================72 +!====6=8===============================================================72 + subroutine radfluxspv(nz,n,alb,rs,swddif,em,rl,twal,tair,sigma,radflux,pv_frac_roof,tpv) +! + implicit none +! +! This routine calculates the radiative fluxes at the surfaces +! +! Integer and real kinds +! +! integer, parameter :: kind_im = selected_int_kind(6) ! 4 byte integer +! integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real +! +! Input Variables +! + integer,intent(in) :: nz !Maximum number of vertical levels in the urban grid + real,intent(in) :: alb !albedo of the surface + real,intent(in) :: rs !shortwave radiation [W m-2] + real,intent(in) :: swddif + real,intent(in) :: em !emissivity of the surface + real,intent(in) :: rl !longwave radiation [W m-2] + real,intent(in) :: twal !surface temperature [K] + real,intent(in) :: sigma !Stefan-Boltzmann constant [W/m2.K4] + real,intent(in) :: tpv !Stefan-Boltzmann constant [W/m2.K4] + real,intent(in),dimension(1:nz) :: tair !external temperature [K] + integer,intent(in) :: n !number of floors in the building + real, intent(in) :: pv_frac_roof ! + real :: empv + real :: hrad + real :: F12 +! Output variables +! + real,intent(inout) :: radflux !radiative flux at the surface [W m-2] +! +! Local variables + F12=1. + empv=0.95 + hrad=sigma/((1-empv)/empv+1/F12+(1-em)/em) + if ((n+1).gt.nz) then + write(*,*) 'Increase maximum number of vertical levels in the urban grid' + stop + endif + radflux=(1.-alb)*(1.-pv_frac_roof)*rs+em*(1.-pv_frac_roof)*rl+pv_frac_roof*hrad*(tpv**4-twal**4)- & + em*sigma*(1.-pv_frac_roof)*twal**4 + return + end subroutine radfluxspv !====6=8==============================================================72 !====6=8==============================================================72 ! diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F index 1ba95cd197..a0f2bdf645 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F @@ -1,13 +1,19 @@ MODULE module_sf_bep + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M) +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) !USE module_model_constants #endif USE module_sf_urban + USE module_bep_bem_helper, ONLY: nurbm ! SGClarke 09/11/2008 ! Access urban_param.tbl values through calling urban_param_init in module_physics_init @@ -16,9 +22,8 @@ MODULE module_sf_bep ! ----------------------------------------------------------------------- ! Dimension for the array used in the BEP module ! ----------------------------------------------------------------------- - - integer nurbm ! Maximum number of urban classes - parameter (nurbm=3) + integer nurbmax ! Maximum number of urban classes + parameter (nurbmax=11) integer ndm ! Maximum number of street directions parameter (ndm=2) @@ -63,7 +68,10 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat, & declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers,num_urban_hi, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, & + num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & @@ -106,16 +114,25 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & REAL, INTENT(IN) :: DECLIN_URB REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D - INTEGER, INTENT(IN ) :: num_urban_layers + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd INTEGER, INTENT(IN ) :: num_urban_hi - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d REAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lp_urb2d REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lb_urb2d @@ -164,19 +181,19 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real hb_u(nz_um) ! Bulding's heights real ss_urb(nz_um) ! Probability that a building has an height equal to z real pb_urb(nz_um) ! Probability that a building has an height greater or equal to z - integer nz_urb(nurbm) ! Number of layer in the urban grid - integer nzurban(nurbm) + integer nz_urb(nurbmax) ! Number of layer in the urban grid + integer nzurban(nurbmax) ! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] - real twini_u(nurbm) ! Initial temperature inside the building's wall [K] - real trini_u(nurbm) ! Initial temperature inside the building's roof [K] - real tgini_u(nurbm) ! Initial road temperature + real alag_u(nurbmax) ! Ground thermal diffusivity [m^2 s^-1] + real alaw_u(nurbmax) ! Wall thermal diffusivity [m^2 s^-1] + real alar_u(nurbmax) ! Roof thermal diffusivity [m^2 s^-1] + real csg_u(nurbmax) ! Specific heat of the ground material [J m^3 K^-1] + real csw_u(nurbmax) ! Specific heat of the wall material [J m^3 K^-1] + real csr_u(nurbmax) ! Specific heat of the roof material [J m^3 K^-1] + real twini_u(nurbmax) ! Initial temperature inside the building's wall [K] + real trini_u(nurbmax) ! Initial temperature inside the building's roof [K] + real tgini_u(nurbmax) ! Initial road temperature ! ! Building materials ! @@ -190,39 +207,39 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation ! ! Radiation parameters - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof + real albg_u(nurbmax) ! Albedo of the ground + real albw_u(nurbmax) ! Albedo of the wall + real albr_u(nurbmax) ! Albedo of the roof + real emg_u(nurbmax) ! Emissivity of ground + real emw_u(nurbmax) ! Emissivity of wall + real emr_u(nurbmax) ! Emissivity of roof ! fww_u,fwg_u,fgw_u,fsw_u,fsg_u are the view factors used to compute the long wave ! and the short wave radation. - real fww_u(nz_um,nz_um,ndm,nurbm) ! from wall to wall - real fwg_u(nz_um,ndm,nurbm) ! from wall to ground - real fgw_u(nz_um,ndm,nurbm) ! from ground to wall - real fsw_u(nz_um,ndm,nurbm) ! from sky to wall - real fws_u(nz_um,ndm,nurbm) ! from sky to wall - real fsg_u(ndm,nurbm) ! from sky to ground + real fww_u(nz_um,nz_um,ndm,nurbmax) ! from wall to wall + real fwg_u(nz_um,ndm,nurbmax) ! from wall to ground + real fgw_u(nz_um,ndm,nurbmax) ! from ground to wall + real fsw_u(nz_um,ndm,nurbmax) ! from sky to wall + real fws_u(nz_um,ndm,nurbmax) ! from sky to wall + real fsg_u(ndm,nurbmax) ! from sky to ground ! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + real z0g_u(nurbmax) ! The ground's roughness length + real z0r_u(nurbmax) ! The roof's roughness length ! Roughness parameters real z0(ndm,nz_um) ! Roughness lengths "profiles" ! Street parameters - integer nd_u(nurbm) ! Number of street direction for each urban class - real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction - real ws_u(ndm,nurbm) ! Street width - real bs_u(ndm,nurbm) ! Building width - real h_b(nz_um,nurbm) ! Bulding's heights - real d_b(nz_um,nurbm) ! Probability that a building has an height h_b - real ss_u(nz_um,nurbm) ! Probability that a building has an height equal to z - real pb_u(nz_um,nurbm) ! Probability that a building has an height greater or equal to z + integer nd_u(nurbmax) ! Number of street direction for each urban class + real strd_u(ndm,nurbmax) ! Street length (fix to greater value to the horizontal length of the cells) + real drst_u(ndm,nurbmax) ! Street direction + real ws_u(ndm,nurbmax) ! Street width + real bs_u(ndm,nurbmax) ! Building width + real h_b(nz_um,nurbmax) ! Bulding's heights + real d_b(nz_um,nurbmax) ! Probability that a building has an height h_b + real ss_u(nz_um,nurbmax) ! Probability that a building has an height equal to z + real pb_u(nz_um,nurbmax) ! Probability that a building has an height greater or equal to z ! ! Street parameters ! @@ -235,7 +252,7 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ! Grid parameters - integer nz_u(nurbm) ! Number of layer in the urban grid + integer nz_u(nurbmax) ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels @@ -304,8 +321,8 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & !------------------------------------------------------------------------ !prepare the arrays to collapse indexes - if(num_urban_layers.lt.nz_um*ndm*nwr_u)then - write(*,*)'num_urban_layers too small, please increase to at least ', nz_um*ndm*nwr_u + if(urban_map_zrd.lt.nz_um*ndm*nwr_u)then + write(*,*)'urban_map_zrd too small, please increase to at least ', nz_um*ndm*nwr_u stop endif iii=0 @@ -426,7 +443,7 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do iw=1,nwr_u ! tw1D(2*id-1,iz_u,iw)=tw1_u(ix,iy,ind_zwd(iz_u,iw,id)) ! tw1D(2*id,iz_u,iw)=tw2_u(ix,iy,ind_zwd(iz_u,iw,id)) - if(ind_zwd(iz_u,iw,id).gt.num_urban_layers)write(*,*)'ind_zwd too big w',ind_zwd(iz_u,iw,id) + if(ind_zwd(iz_u,iw,id).gt.urban_map_zwd)write(*,*)'ind_zwd too big w',ind_zwd(iz_u,iw,id) tw1D(2*id-1,iz_u,iw)=tw1_urb4d(ix,ind_zwd(iz_u,iw,id),iy) tw1D(2*id,iz_u,iw)=tw2_urb4d(ix,ind_zwd(iz_u,iw,id),iy) enddo @@ -441,7 +458,7 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do iz_u=1,nz_um do ir=1,nwr_u ! tr1D(id,iz_u,ir)=tr_u(ix,iy,ind_zwd(iz_u,ir,id)) - if(ind_zwd(iz_u,ir,id).gt.num_urban_layers)write(*,*)'ind_zwd too big r',ind_zwd(iz_u,ir,id) + if(ind_zwd(iz_u,ir,id).gt.urban_map_zwd)write(*,*)'ind_zwd too big r',ind_zwd(iz_u,ir,id) tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy) enddo enddo @@ -3065,7 +3082,7 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& do iu=1,icate if(ndm.lt.nd_u(iu))then write(*,*)'ndm too small in module_sf_bep, please increase to at least ', nd_u(iu) - write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!' + write(*,*)'remember also that urban_map_zrd should be equal or greater than nz_um*ndm*nwr-u!' stop endif do i=1,nd_u(iu) @@ -3077,7 +3094,7 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& do iu=1,ICATE if(nz_um.lt.numhgt_tbl(iu)+3)then write(*,*)'nz_um too small in module_sf_bep, please increase to at least ',numhgt_tbl(iu)+3 - write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!' + write(*,*)'remember also that urban_map_zrd should be equal or greater than nz_um*ndm*nwr-u!' stop endif do i=1,NUMHGT_TBL(iu) @@ -3486,3 +3503,39 @@ end subroutine icBEPHI_XY ! ===6=8===============================================================72 ! ===6=8===============================================================72 END MODULE module_sf_bep + + FUNCTION bep_nurbm () RESULT (bep_val_nurbm) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_nurbm + bep_val_nurbm = nurbm + END FUNCTION bep_nurbm + + FUNCTION bep_ndm () RESULT (bep_val_ndm) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_ndm + bep_val_ndm = ndm + END FUNCTION bep_ndm + + FUNCTION bep_nz_um () RESULT (bep_val_nz_um) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_nz_um + bep_val_nz_um = nz_um + END FUNCTION bep_nz_um + + FUNCTION bep_ng_u () RESULT (bep_val_ng_u) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_ng_u + bep_val_ng_u = ng_u + END FUNCTION bep_ng_u + + FUNCTION bep_nwr_u () RESULT (bep_val_nwr_u) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_nwr_u + bep_val_nwr_u = nwr_u + END FUNCTION bep_nwr_u + diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F index d9344a1427..03c86d9347 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F @@ -1,14 +1,19 @@ MODULE module_sf_bep_bem + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) -use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +use mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M ) -!USE module_model_constants +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif USE module_sf_urban USE module_sf_bem + USE module_bep_bem_helper, ONLY: nurbm ! SGClarke 09/11/2008 ! Access urban_param.tbl values through calling urban_param_init in module_physics_init @@ -18,8 +23,8 @@ MODULE module_sf_bep_bem ! Dimension for the array used in the BEP module ! ----------------------------------------------------------------------- - integer nurbm ! Maximum number of urban classes - parameter (nurbm=3) + integer nurbmax ! Maximum number of urban classes + parameter (nurbmax=11) integer ndm ! Maximum number of street directions parameter (ndm=2) @@ -29,6 +34,10 @@ MODULE module_sf_bep_bem integer ng_u ! Number of grid levels in the ground parameter (ng_u=10) + + integer ngr_u ! Number of grid levels in green roof + parameter (ngr_u=10) + integer nwr_u ! Number of grid levels in the walls or roofs parameter (nwr_u=10) @@ -44,6 +53,10 @@ MODULE module_sf_bep_bem integer nbui_max !maximum number of types of buildings in an urban class parameter (nbui_max=15) !must be less or equal than nz_um + + real h_water + parameter(h_water=0.0009722) !mm of irrigation per hour + !--------------------------------------------------------------------------------- !Parameters of the windows. The glasses of windows are considered without films - !Read the paper of J.Karlsson and A.Roos(2000):"modelling the angular behaviour - @@ -55,7 +68,6 @@ MODULE module_sf_bep_bem integer q_num !category number for the windows (q_num= 4, standard glasses) parameter(q_num=4) !Possible values 1,2,...,10 - ! The change of ng_u, nwr_u should be done in agreement with the block data ! in the routine "surf_temp" ! ----------------------------------------------------------------------- @@ -70,10 +82,12 @@ MODULE module_sf_bep_bem real rcp_u ! real sigma ! real p0 ! Reference pressure at the sea level - real cdrag ! Drag force constant real latent ! Latent heat of vaporization [J/kg] (used in BEM) + real dgmax ! Maximum ground water holding capacity (mm) + real drmax ! Maximum ground roof holding capacity (mm) + parameter(vk=0.40,g_u=9.81,pi=3.141592653,r=287.,cp_u=1004.) - parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,cdrag=0.4,latent=2.45e+06) + parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,latent=2.45e+06,dgmax=1.,drmax=1.) ! ----------------------------------------------------------------------- @@ -83,16 +97,26 @@ MODULE module_sf_bep_bem CONTAINS subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & - th_phy,rho,p_phy,swdown,glw, & + th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat, & declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers,num_urban_hi, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, & + urban_map_zgrd, num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, & - tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & - cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, & + tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & + cm_ac_urb3d, & + sfvent_urb3d,lfvent_urb3d, & sfwin1_urb3d,sfwin2_urb3d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + ep_pv_urb3d,t_pv_urb3d, & + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & + drain_urb4d,draingr_urb3d, & + sfrv_urb3d,lfrv_urb3d, & + dgr_urb3d,dg_urb3d, & + lfr_urb3d,lfg_urb3d,rainbl,swddir,swddif, & lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & a_u,a_v,a_t,a_e,b_u,b_v, & b_t,b_e,b_q,dlg,dl_u,sf,vl, & @@ -123,7 +147,9 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: V REAL, DIMENSION( ims:ime , jms:jme ) :: GLW REAL, DIMENSION( ims:ime , jms:jme ) :: swdown - REAL, DIMENSION( ims:ime, jms:jme ) :: UST + REAL, DIMENSION( ims:ime , jms:jme ) :: swddir + REAL, DIMENSION( ims:ime , jms:jme ) :: swddif + REAL, DIMENSION( ims:ime, jms:jme ) :: UST INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: UTYPE_URB2D REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: FRC_URB2D REAL, INTENT(IN ) :: GMT @@ -133,32 +159,59 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & REAL, INTENT(IN) :: DECLIN_URB REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D - INTEGER, INTENT(IN ) :: num_urban_layers - INTEGER, INTENT(IN ) :: num_urban_hi - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN) :: num_urban_hi + INTEGER , INTENT(IN) :: urban_map_zgrd + REAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ), INTENT(INOUT) :: trv_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ), INTENT(INOUT) :: qr_urb4d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: qgr_urb3d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tgr_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: drain_urb4d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: rainbl + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !New variables used for BEM REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: qv_phy - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_bd, jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + !End variables - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfrv_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: lfrv_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !G + REAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lp_urb2d REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lb_urb2d @@ -197,22 +250,22 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & !------------------------------------------------------------------------ real hi_urb(its:ite,1:nz_um,jts:jte) ! Height histograms of buildings real hi_urb1D(nz_um) ! Height histograms of buildings - real ss_urb(nz_um,nurbm) ! Probability that a building has an height equal to z + real ss_urb(nz_um,nurbmax) ! Probability that a building has an height equal to z real pb_urb(nz_um) ! Probability that a building has an height greater or equal to z real hb_u(nz_um) ! Bulding's heights - integer nz_urb(nurbm) ! Number of layer in the urban grid - integer nzurban(nurbm) + integer nz_urb(nurbmax) ! Number of layer in the urban grid + integer nzurban(nurbmax) ! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] - real twini_u(nurbm) ! Initial temperature inside the building's wall [K] - real trini_u(nurbm) ! Initial temperature inside the building's roof [K] - real tgini_u(nurbm) ! Initial road temperature + real alag_u(nurbmax) ! Ground thermal diffusivity [m^2 s^-1] + real alaw_u(nurbmax) ! Wall thermal diffusivity [m^2 s^-1] + real alar_u(nurbmax) ! Roof thermal diffusivity [m^2 s^-1] + real csg_u(nurbmax) ! Specific heat of the ground material [J m^3 K^-1] + real csw_u(nurbmax) ! Specific heat of the wall material [J m^3 K^-1] + real csr_u(nurbmax) ! Specific heat of the roof material [J m^3 K^-1] + real twini_u(nurbmax) ! Initial temperature inside the building's wall [K] + real trini_u(nurbmax) ! Initial temperature inside the building's roof [K] + real tgini_u(nurbmax) ! Initial road temperature ! ! Building materials @@ -235,7 +288,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ! !New street and radiation parameters -! + real bs(ndm) ! Building width for the current urban class real ws(ndm) ! Street widths of the current urban class @@ -243,71 +296,76 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real drst(ndm) ! street directions for the current urban class real ss(nz_um) ! Probability to have a building with height h real pb(nz_um) ! Probability to have a building with an height equal -! + real HFGR_D(nz_um) !New roughness and buildings parameters ! real z0(ndm,nz_um) ! Roughness lengths "profiles" - real bs_urb(ndm,nurbm) ! Building width - real ws_urb(ndm,nurbm) ! Street width + real bs_urb(ndm,nurbmax) ! Building width + real ws_urb(ndm,nurbmax) ! Street width ! ! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation ! ! Radiation paramters - - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real albwin_u(nurbm) ! Albedo of the windows - real emwind_u(nurbm) ! Emissivity of windows - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof + real albg_u(nurbmax) ! Albedo of the ground + real albw_u(nurbmax) ! Albedo of the wall + real albr_u(nurbmax) ! Albedo of the roof + real albwin_u(nurbmax) ! Albedo of the windows + real emwind_u(nurbmax) ! Emissivity of windows + real emg_u(nurbmax) ! Emissivity of ground + real emw_u(nurbmax) ! Emissivity of wall + real emr_u(nurbmax) ! Emissivity of roof + real gr_frac_roof_u(nurbmax) + real pv_frac_roof_u(nurbmax) + integer gr_flag_u + integer gr_type_u ! fww_u,fwg_u,fgw_u,fsw_u,fsg_u are the view factors used to compute the long wave ! and the short wave radiation. - real fww_u(nz_um,nz_um,ndm,nurbm) ! from wall to wall - real fwg_u(nz_um,ndm,nurbm) ! from wall to ground - real fgw_u(nz_um,ndm,nurbm) ! from ground to wall - real fsw_u(nz_um,ndm,nurbm) ! from sky to wall - real fws_u(nz_um,ndm,nurbm) ! from sky to wall - real fsg_u(ndm,nurbm) ! from sky to ground + real fww_u(nz_um,nz_um,ndm,nurbmax) ! from wall to wall + real fwg_u(nz_um,ndm,nurbmax) ! from wall to ground + real fgw_u(nz_um,ndm,nurbmax) ! from ground to wall + real fsw_u(nz_um,ndm,nurbmax) ! from sky to wall + real fws_u(nz_um,ndm,nurbmax) ! from sky to wall + real fsg_u(ndm,nurbmax) ! from sky to ground ! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + real z0g_u(nurbmax) ! The ground's roughness length + real z0r_u(nurbmax) ! The roof's roughness length ! Street parameters - integer nd_u(nurbm) ! Number of street direction for each urban class - real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction - real ws_u(ndm,nurbm) ! Street width - real bs_u(ndm,nurbm) ! Building width - real h_b(nz_um,nurbm) ! Bulding's heights - real d_b(nz_um,nurbm) ! Probability that a building has an height h_b - real ss_u(nz_um,nurbm) ! Probability that a building has an height equal to z - real pb_u(nz_um,nurbm) ! Probability that a building has an height greater or equal to z + integer nd_u(nurbmax) ! Number of street direction for each urban class + real strd_u(ndm,nurbmax) ! Street length (fix to greater value to the horizontal length of the cells) + real drst_u(ndm,nurbmax) ! Street direction + real ws_u(ndm,nurbmax) ! Street width + real bs_u(ndm,nurbmax) ! Building width + real h_b(nz_um,nurbmax) ! Bulding's heights + real d_b(nz_um,nurbmax) ! Probability that a building has an height h_b + real ss_u(nz_um,nurbmax)! Probability that a building has an height equal to z + real pb_u(nz_um,nurbmax)! Probability that a building has an height greater or equal to z ! Grid parameters - integer nz_u(nurbm) ! Number of layer in the urban grid + integer nz_u(nurbmax) ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels !FS - real cop_u(nurbm) - real pwin_u(nurbm) - real beta_u(nurbm) - integer sw_cond_u(nurbm) - real time_on_u(nurbm) - real time_off_u(nurbm) - real targtemp_u(nurbm) - real gaptemp_u(nurbm) - real targhum_u(nurbm) - real gaphum_u(nurbm) - real perflo_u(nurbm) - real hsesf_u(nurbm) + real cop_u(nurbmax) + real bldac_frc_u(nurbmax) + real cooled_frc_u(nurbmax) + real pwin_u(nurbmax) + real beta_u(nurbmax) + integer sw_cond_u(nurbmax) + real time_on_u(nurbmax) + real time_off_u(nurbmax) + real targtemp_u(nurbmax) + real gaptemp_u(nurbmax) + real targhum_u(nurbmax) + real gaphum_u(nurbmax) + real perflo_u(nurbmax) + real hsesf_u(nurbmax) real hsequip(24) - + real irho(24) ! 1D array used for the input and output of the routine "urban" real z1D(kms:kme) ! vertical coordinates @@ -322,11 +380,17 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real ah1D ! hour angle (it should come from the radiation routine) real rs1D ! solar radiation real rld1D ! downward flux of the longwave radiation + real swddir1D + real swddif1D ! short wave diffuse solar radiation _gl + real tw1D(2*ndm,nz_um,nwr_u,nbui_max) ! temperature in each layer of the wall real tg1D(ndm,ng_u) ! temperature in each layer of the ground real tr1D(ndm,nz_um,nwr_u) ! temperature in each layer of the roof + real trv1D(ndm,nz_um,ngr_u) ! temperature in each layer of the GREEN roof + real qr1D(ndm,nz_um,ngr_u) ! humidity in each layer of the GREEN roof + ! !New variable for BEM ! @@ -341,12 +405,18 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real sfvlev1D(nz_um,nz_um) ! sensible heat flux due to ventilation real sfwin1D(2*ndm,nz_um,nbui_max) ! sensible heat flux from windows real consumlev1D(nz_um,nz_um) ! consumption due to the air conditioning systems + real eppvlev1D(nz_um) ! electricity production of PV panels + real tair1D(nz_um) + real tpvlev1D(ndm,nz_um) real qv1D(kms:kme) ! specific humidity real meso_urb ! constant to link meso and urban scales [m-2] + real meso_urb_ac + real roof_frac ! Surface fraction occupied by roof real d_urb(nz_um) real sf_ac integer ibui,nbui integer nlev(nz_um) + ! !End new variables ! @@ -354,6 +424,17 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real sfw1D(2*ndm,nz_um,nbui_max) ! sensible heat flux from walls real sfg1D(ndm) ! sensible heat flux from ground (road) real sfr1D(ndm,nz_um) ! sensible heat flux from roofs + real sfrpv1D(ndm,nz_um) + + real tpv1D(nbui_max) + real sfr_indoor1D(nbui_max) + real sfrv1D(ndm,nz_um) ! sensible heat flux from roofs + real lfrv1D(ndm,nz_um) ! latent heat flux from roofs + real dg1D(ndm) ! water depth from ground + real dgr1D(ndm,nz_um) ! water depth from roofs + real lfg1D(ndm) ! latent heat flux from ground (road) + real lfr1D(ndm,nz_um) ! latent heat flux from roofs + real drain1D(ndm,nz_um) ! sensible heat flux from roofs real sf1D(kms:kme) ! surface of the urban grid cells real vl1D(kms:kme) ! volume of the urban grid cells real a_u1D(kms:kme) ! Implicit component of the momentum sources or sinks in the X-direction @@ -368,7 +449,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real b_q1D(kms:kme) ! Explicit component of the Humidity sources or sinks real dlg1D(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u1D(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper) - + real gfr1D(ndm,nz_um) real time_bep ! arrays used to collapse indexes integer ind_zwd(nbui_max,nz_um,nwr_u,ndm) @@ -376,27 +457,29 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & integer ind_zd(nbui_max,nz_um,ndm) integer ind_zdf(nz_um,ndm) integer ind_zrd(nz_um,nwr_u,ndm) + integer ind_grd(nz_um,ngr_u,ndm) ! integer ind_bd(nbui_max,nz_um) integer ind_wd(nbui_max,nz_um,ndm) integer ind_gbd(nbui_max,ngb_u,ndm) integer ind_fbd(nbui_max,nf_u,nz_um-1,ndm) -! + integer ix,iy,iz,iurb,id,iz_u,iw,ig,ir,ix1,iy1,k integer it, nint integer iii - logical first character(len=80) :: text data first/.true./ - save first,time_bep - + save first,time_bep + save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & nz_u,z_u,albwin_u,emwind_u,cop_u,pwin_u,beta_u,sw_cond_u, & + bldac_frc_u,cooled_frc_u, & time_on_u,time_off_u,targtemp_u,gaptemp_u,targhum_u,gaphum_u, & - perflo_u,hsesf_u,hsequip + perflo_u,gr_frac_roof_u, & + pv_frac_roof_u,hsesf_u,hsequip,irho,gr_flag_u,gr_type_u !------------------------------------------------------------------------ ! Calculation of the momentum, heat and turbulent kinetic fluxes @@ -408,37 +491,39 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ! 261-304 ! ! F. Salamanca and A. Martilli, 2009: 'A new Building Energy Model coupled -! with an Urban Canopy Parameterization for urban climate simulations-part II. +! with an Urban Canopy Parameterization for urban climate simulations - part II. ! Validation with one dimension off-line simulations'. Theor Appl Climatol ! DOI 10.1007/s00704-009-0143-8 !------------------------------------------------------------------------ ! !prepare the arrays to collapse indexes - if(num_urban_layers.lt.nbui_max*nz_um*ndm*max(nwr_u,ng_u))then - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um*ndm*max(nwr_u,ng_u) + +! + if(urban_map_zwd.lt.nbui_max*nz_um*ndm*max(nwr_u,ng_u))then + write(*,*)'urban_map_zwd too small, please increase to at least ', nbui_max*nz_um*ndm*max(nwr_u,ng_u) stop endif ! !New conditions for BEM ! - if(num_urban_layers.lt.nbui_max*nz_um)then !limit for indoor temperature and indoor humidity - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um + if(urban_map_bd.lt.nbui_max*nz_um)then !limit for indoor temperature and indoor humidity + write(*,*)'urban_map_bd too small, please increase to at least ', nbui_max*nz_um stop endif - if(num_urban_layers.lt.nbui_max*nz_um*ndm)then !limit for window temperature - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um*ndm + if(urban_map_wd.lt.nbui_max*nz_um*ndm)then !limit for window temperature + write(*,*)'urban_map_wd too small, please increase to at least ', nbui_max*nz_um*ndm stop endif - if(num_urban_layers.lt.nbui_max*ndm*ngb_u)then !limit for ground temperature below a building - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*ndm*ngb_u + if(urban_map_gbd.lt.nbui_max*ndm*ngb_u)then !limit for ground temperature below a building + write(*,*)'urban_map_gbd too small, please increase to at least ', nbui_max*ndm*ngb_u stop endif - if(num_urban_layers.lt.(nz_um-1)*nbui_max*ndm*nf_u)then !limit for floor temperature - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*ndm*nf_u*(nz_um-1),num_urban_layers + if(urban_map_fbd.lt.(nz_um-1)*nbui_max*ndm*nf_u)then !limit for floor temperature + write(*,*)'urban_map_fbd too small, please increase to at least ', nbui_max*ndm*nf_u*(nz_um-1) stop endif @@ -447,7 +532,6 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & stop endif -! !End of new conditions ! ! @@ -458,6 +542,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_zd=0 ind_zdf=0 ind_zrd=0 + ind_grd=0 ind_bd=0 ind_wd=0 ind_gbd=0 @@ -505,10 +590,20 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo enddo + + iii=0 + do iz_u=1,nz_um + do iw=1,ngr_u + do id=1,ndm + iii=iii+1 + ind_grd(iz_u,iw,id)=iii + enddo + enddo + enddo ! !New indexes for BEM -! + iii=0 do iz_u=1,nz_um do id=1,ndm @@ -524,8 +619,9 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_bd(ibui,iz_u)=iii enddo !iz_u enddo !ibui - - + + + iii=0 do ibui=1,nbui_max !type of building do iz_u=1,nz_um !vertical levels @@ -557,9 +653,10 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !iz_u enddo !iw enddo !ibui -! -!End of new indexes -! + + + !End of new indexes + if (num_urban_hi.ge.nz_um)then write(*,*)'nz_um too small, please increase to at least ', num_urban_hi+1 stop @@ -593,23 +690,26 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo + if (first) then ! True only on first call call init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,& emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b, & cop_u,pwin_u,beta_u,sw_cond_u,time_on_u,time_off_u,targtemp_u, & - gaptemp_u,targhum_u,gaphum_u,perflo_u,hsesf_u,hsequip) - + bldac_frc_u,cooled_frc_u, & + gaptemp_u,targhum_u,gaphum_u,perflo_u, & + gr_frac_roof_u,pv_frac_roof_u, & + hsesf_u,hsequip,irho,gr_flag_u,gr_type_u) + !Initialisation of the urban parameters and calculation of the view factor - - call icBEP(nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) - - first=.false. + call icBEP(nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) + + first=.false. endif ! first - - do ix=its,ite + +do ix=its,ite do iy=jts,jte if (FRC_URB2D(ix,iy).gt.0.) then ! Calling BEP only for existing urban classes. @@ -618,6 +718,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & hi_urb1D=0. do iz_u=1,nz_um hi_urb1D(iz_u)=hi_urb(ix,iz_u,iy) + enddo call icBEPHI_XY(iurb,hb_u,hi_urb1D,ss_urb,pb_urb, & @@ -657,13 +758,14 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & stop endif - do iz= kts,kte + + +do iz= kts,kte ua1D(iz)=u_phy(ix,iz,iy) va1D(iz)=v_phy(ix,iz,iy) pt1D(iz)=th_phy(ix,iz,iy) da1D(iz)=rho(ix,iz,iy) pr1D(iz)=p_phy(ix,iz,iy) -!! pt01D(iz)=th_phy(ix,iz,iy) pt01D(iz)=300. z1D(iz)=z(ix,iz,iy) qv1D(iz)=qv_phy(ix,iz,iy) @@ -679,12 +781,12 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo z1D(kte+1)=z(ix,kte+1,iy) + + do id=1,ndm do iz_u=1,nz_um do iw=1,nwr_u do ibui=1,nbui_max -!! tw1D(2*id-1,iz_u,iw)=tw1_u(ix,iy,ind_zwd(iz_u,iw,id)) -!! tw1D(2*id,iz_u,iw)=tw2_u(ix,iy,ind_zwd(iz_u,iw,id)) tw1D(2*id-1,iz_u,iw,ibui)=tw1_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy) tw1D(2*id,iz_u,iw,ibui)=tw2_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy) enddo @@ -693,20 +795,30 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo do id=1,ndm - do ig=1,ng_u -!! tg1D(id,ig)=tg_u(ix,iy,ind_gd(ig,id)) + do ig=1,ng_u tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy) - enddo - do iz_u=1,nz_um - do ir=1,nwr_u -!! tr1D(id,iz_u,ir)=tr_u(ix,iy,ind_zwd(iz_u,ir,id)) - tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy) - enddo - enddo - enddo -! + enddo + + do iz_u=1,nz_um + do ir=1,nwr_u + tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy) + enddo + do ir=1,ngr_u + if(gr_flag_u.eq.1)then + trv1D(id,iz_u,ir)=trv_urb4d(ix,ind_grd(iz_u,ir,id),iy) + qr1D(id,iz_u,ir)=qr_urb4d(ix,ind_grd(iz_u,ir,id),iy) + else + trv1D(id,iz_u,ir)=0. + qr1D(id,iz_u,ir)=0. + endif + enddo + enddo + enddo + + + !Initialize variables for BEM -! + tlev1D=0. !Indoor temperature qlev1D=0. !Indoor humidity @@ -717,6 +829,8 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & sflev1D=0. !Sensible heat flux from the a.c. lflev1D=0. !latent heat flux from the a.c. consumlev1D=0.!consumption of the a.c. + eppvlev1D=0. !electricity production of PV panels + tpvlev1D=0. sfvlev1D=0. !Sensible heat flux from natural ventilation lfvlev1D=0. !Latent heat flux from natural ventilation sfwin1D=0. !Sensible heat flux from windows @@ -729,6 +843,8 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !ibui enddo !iz_u + + do id=1,ndm !direction do iz_u=1,nz_um !vertical levels do ibui=1,nbui_max !type of building @@ -753,6 +869,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do iz_u=1,nz_um-1 !verticals levels do ibui=1,nbui_max !type of building tflev1D(id,iw,iz_u,ibui)=tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy) + enddo !ibui enddo ! iz_u enddo !iw @@ -760,42 +877,59 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ! !End initialization for BEM -! +! + + do id=1,ndm + do iz=1,nz_um + do ibui=1,nbui_max !type of building + !! sfw1D(2*id-1,iz)=sfw1(ix,iy,ind_zd(iz,id)) + !! sfw1D(2*id,iz)=sfw2(ix,iy,ind_zd(iz,id)) + sfw1D(2*id-1,iz,ibui)=sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy) + sfw1D(2*id,iz,ibui)=sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy) + enddo + enddo + enddo + + do id=1,ndm + sfg1D(id)=sfg_urb3d(ix,id,iy) + lfg1D(id)=lfg_urb3d(ix,id,iy) + dg1D(id)=dg_urb3d(ix,id,iy) + + enddo - do id=1,ndm - do iz=1,nz_um - do ibui=1,nbui_max !type of building -!! sfw1D(2*id-1,iz)=sfw1(ix,iy,ind_zd(iz,id)) -!! sfw1D(2*id,iz)=sfw2(ix,iy,ind_zd(iz,id)) - sfw1D(2*id-1,iz,ibui)=sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy) - sfw1D(2*id,iz,ibui)=sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy) - enddo - enddo - enddo - - do id=1,ndm -!! sfg1D(id)=sfg(ix,iy,id) - sfg1D(id)=sfg_urb3d(ix,id,iy) - enddo - do id=1,ndm do iz=1,nz_um -!! sfr1D(id,iz)=sfr(ix,iy,ind_zd(iz,id)) + tpvlev1D(id,iz)=t_pv_urb3d(ix,ind_zdf(iz,id),iy) sfr1D(id,iz)=sfr_urb3d(ix,ind_zdf(iz,id),iy) + lfr1D(id,iz)=lfr_urb3d(ix,ind_zdf(iz,id),iy) + dgr1D(id,iz)=dgr_urb3d(ix,ind_zdf(iz,id),iy) + if(gr_flag_u.eq.1)then + sfrv1D(id,iz)=sfrv_urb3d(ix,ind_zdf(iz,id),iy) + lfrv1D(id,iz)=lfrv_urb3d(ix,ind_zdf(iz,id),iy) + drain1D(id,iz)=drain_urb4d(ix,ind_zdf(iz,id),iy) + else + sfrv1D(id,iz)=0. + lfrv1D(id,iz)=0. + drain1D(id,iz)=0. + endif enddo enddo - + + + rs1D=swdown(ix,iy) rld1D=glw(ix,iy) - + swddir1D=swddir(ix,iy) !_gl + swddif1D=swddif(ix,iy) !_gl zr1D=acos(COSZ_URB2D(ix,iy)) deltar1D=DECLIN_URB ah1D=OMG_URB2D(ix,iy) + - call BEP1D(iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D, & + call BEP1D(itimestep,ix,iy,iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D, & zr1D,deltar1D,ah1D,rs1D,rld1D,alagb, & alag,alaw,alar,alaf,csgb,csg,csw,csr,csf, & - dzr,dzf,dzw,dzgb, & + dzr,dzf,dzw,dzgb,xlat(ix,iy),swddir1D,swddif1D, & albg_u(iurb),albw_u(iurb),albr_u(iurb), & albwin_u(iurb),emg_u(iurb),emw_u(iurb), & emr_u(iurb),emwind_u(iurb),fww_u,fwg_u, & @@ -804,17 +938,20 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & nzurban(iurb),z_u,cop_u,pwin_u,beta_u, & sw_cond_u,time_on_u,time_off_u,targtemp_u, & gaptemp_u,targhum_u,gaphum_u,perflo_u, & - hsesf_u,hsequip, & - tw1D,tg1D,tr1D,sfw1D,sfg1D,sfr1D, & + gr_frac_roof_u(iurb),pv_frac_roof_u(iurb), & + hsesf_u,hsequip,irho,gr_flag_u,gr_type_u, & + tw1D,tg1D,tr1D,trv1D,sfw1D,sfg1D,sfr1D, & + sfrv1D,lfrv1D, & + dgr1D,dg1D,lfr1D,lfg1D, & + drain1D,rainbl(ix,iy),qr1D, & a_u1D,a_v1D,a_t1D,a_e1D, & b_u1D,b_v1D,b_t1D,b_ac1D,b_e1D,b_q1D, & dlg1D,dl_u1D,sf1D,vl1D,rl_up(ix,iy), & rs_abs(ix,iy),emiss(ix,iy),grdflx_urb(ix,iy), & qv1D,tlev1D,qlev1D,sflev1D,lflev1D,consumlev1D, & - sfvlev1D,lfvlev1D,twlev1D,tglev1D,tflev1D,sfwin1D,& - ix,iy) - - do ibui=1,nbui_max !type of building + eppvlev1D,tpvlev1D,sfvlev1D,lfvlev1D,twlev1D,tglev1D,tflev1D,sfwin1D,tair1D,sfr_indoor1D,sfrpv1D,gfr1D) + + do ibui=1,nbui_max !type of building do iz=1,nz_um !vertical levels do id=1,ndm ! direction sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy)=sfw1D(2*id-1,iz,ibui) @@ -824,16 +961,26 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo do id=1,ndm - sfg_urb3d(ix,id,iy)=sfg1D(id) + sfg_urb3d(ix,id,iy)=sfg1D(id) + lfg_urb3d(ix,id,iy)=lfg1D(id) + dg_urb3d(ix,id,iy)=dg1D(id) enddo do id=1,ndm do iz=1,nz_um + t_pv_urb3d(ix,ind_zdf(iz,id),iy)=tpvlev1D(id,iz) sfr_urb3d(ix,ind_zdf(iz,id),iy)=sfr1D(id,iz) + dgr_urb3d(ix,ind_zdf(iz,id),iy)=dgr1D(id,iz) + lfr_urb3d(ix,ind_zdf(iz,id),iy)=lfr1D(id,iz) + if(gr_flag_u.eq.1)then + sfrv_urb3d(ix,ind_zdf(iz,id),iy)=sfrv1D(id,iz) + lfrv_urb3d(ix,ind_zdf(iz,id),iy)=lfrv1D(id,iz) + drain_urb4d(ix,ind_zdf(iz,id),iy)=drain1D(id,iz) + endif enddo enddo - do ibui=1,nbui_max + do ibui=1,nbui_max do iz_u=1,nz_um do iw=1,nwr_u do id=1,ndm @@ -843,17 +990,27 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo enddo - - do id=1,ndm + + + do id=1,ndm do ig=1,ng_u + tgb_urb4d(ix,ind_gd(ig,id),iy)=tg1D(id,ig) enddo do iz_u=1,nz_um do ir=1,nwr_u trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy)=tr1D(id,iz_u,ir) enddo + if(gr_flag_u.eq.1)then + do ir=1,ngr_u + trv_urb4d(ix,ind_grd(iz_u,ir,id),iy)=trv1D(id,iz_u,ir) + qr_urb4d(ix,ind_grd(iz_u,ir,id),iy)=qr1D(id,iz_u,ir) + enddo + endif enddo - enddo + enddo +! + ! !Outputs of BEM ! @@ -884,26 +1041,31 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !iw enddo !ibui - do ibui=1,nbui_max !type of building - do iw=1,nf_u !layer in the walls + do ibui=1,nbui_max !type of building + do iw=1,nf_u !layer in the walls do iz_u=1,nz_um-1 !verticals levels - do id=1,ndm !direction - tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy)=tflev1D(id,iw,iz_u,ibui) - enddo !id - enddo !iz_u + do id=1,ndm + tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy)=tflev1D(id,iw,iz_u,ibui) + enddo !ibui + enddo ! iz_u enddo !iw - enddo !ibui - + enddo !id + + + sf_ac_urb3d(ix,iy)=0. lf_ac_urb3d(ix,iy)=0. cm_ac_urb3d(ix,iy)=0. + ep_pv_urb3d(ix,iy)=0. sfvent_urb3d(ix,iy)=0. lfvent_urb3d(ix,iy)=0. - + draingr_urb3d(ix,iy)=0. + qgr_urb3d(ix,iy)=0. + tgr_urb3d(ix,iy)=0. meso_urb=(1./4.)*FRC_URB2D(ix,iy)/((bs_urb(1,iurb)+ws_urb(1,iurb))*bs_urb(2,iurb))+ & (1./4.)*FRC_URB2D(ix,iy)/((bs_urb(2,iurb)+ws_urb(2,iurb))*bs_urb(1,iurb)) - - + meso_urb_ac=meso_urb*bldac_frc_u(iurb)*cooled_frc_u(iurb) + roof_frac=FRC_URB2D(ix,iy)*bs_urb(1,iurb)/(bs_urb(1,iurb)+ws_urb(1,iurb)) ibui=0 nlev=0 nbui=0 @@ -917,30 +1079,41 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & endif end do !iz - do ibui=1,nbui !type of building - do iz_u=1,nlev(ibui) !vertical levels - sf_ac_urb3d(ix,iy)=sf_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*sflev1D(iz_u,ibui) - lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*lflev1D(iz_u,ibui) - cm_ac_urb3d(ix,iy)=cm_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*consumlev1D(iz_u,ibui) - sfvent_urb3d(ix,iy)=sfvent_urb3d(ix,iy)+meso_urb*d_urb(ibui)*sfvlev1D(iz_u,ibui) - lfvent_urb3d(ix,iy)=lfvent_urb3d(ix,iy)+meso_urb*d_urb(ibui)*lfvlev1D(iz_u,ibui) - enddo !iz_u - enddo !ibui + -! -!Add the latent heat exchanged throughout the ventilation in the lf_ac_urb3d output variable. -!it is only a rint variable -! -! lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+lfvent_urb3d(ix,iy) -! - lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)-lfvent_urb3d(ix,iy) + do ibui=1,nbui !type of building + ep_pv_urb3d(ix,iy)=ep_pv_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*eppvlev1D(ibui) + do iz_u=1,nlev(ibui) !vertical levels + sf_ac_urb3d(ix,iy)=sf_ac_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*sflev1D(iz_u,ibui) + lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*lflev1D(iz_u,ibui) + cm_ac_urb3d(ix,iy)=cm_ac_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*consumlev1D(iz_u,ibui) + !if(consumlev1D(iz_u,ibui).gt.0.)then + !print*,'IX',ix,'IY',iy,'IZ_U',iz_u,'IBUI',ibui,'CONSUM',consumlev1D(iz_u,ibui),'D_URB',d_urb(ibui),'MESO_URB',meso_urb_ac + !endif + sfvent_urb3d(ix,iy)=sfvent_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*sfvlev1D(iz_u,ibui) + lfvent_urb3d(ix,iy)=lfvent_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*lfvlev1D(iz_u,ibui) + enddo !iz_u + enddo !ibui + -! + + if(gr_flag_u.eq.1)then + do id=1,ndm + do iz=2,nz_um-1 + draingr_urb3d(ix,iy)=draingr_urb3d(ix,iy)+d_urb(iz-1)*roof_frac*drain1D(id,iz)*1000 + do ig=1,ngr_u + qgr_urb3d(ix,iy)=qgr_urb3d(ix,iy)+qr1D(id,iz,ig)/ndm/(nz_um-2)/ngr_u + tgr_urb3d(ix,iy)=tgr_urb3d(ix,iy)+trv1D(id,iz,ig)/ndm/(nz_um-2)/ngr_u + + enddo + enddo + enddo + endif !End outputs of bem ! - + sf_ac=0. sf(ix,kts:kte,iy)=0. vl(ix,kts:kte,iy)=0. @@ -975,80 +1148,48 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & sf(ix,kte+1,iy)=sf1D(kte+1) endif ! FRC_URB2D - + + enddo ! iy enddo ! ix time_bep=time_bep+dt - print*, 'ss_urb', ss_urb - print*, 'pb_urb', pb_urb - print*, 'nz_urb', nz_urb - print*, 'd_urb', d_urb - +! print*, 'ss_urb', ss_urb +! print*, 'pb_urb', pb_urb +! print*, 'nz_urb', nz_urb +! print*, 'd_urb', d_urb + + return end subroutine BEP_BEM - + + ! ===6=8===============================================================72 - subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & + subroutine BEP1D(itimestep,ix,iy,iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & zr,deltar,ah,rs,rld,alagb, & alag,alaw,alar,alaf,csgb,csg,csw,csr,csf, & - dzr,dzf,dzw,dzgb, & + dzr,dzf,dzw,dzgb,xlat,swddir,swddif, & albg,albw,albr,albwin,emg,emw,emr, & emwind,fww,fwg,fgw,fsw,fws,fsg,z0, & ndu,strd,drst,ws,bs_u,bs,ss,pb, & nzu,z_u,cop_u,pwin_u,beta_u,sw_cond_u, & time_on_u,time_off_u,targtemp_u, & gaptemp_u,targhum_u,gaphum_u,perflo_u, & - hsesf_u,hsequip, & - tw,tg,tr,sfw,sfg,sfr, & + gr_frac_roof,pv_frac_roof, & + hsesf_u,hsequip,irho,gr_flag,gr_type, & + tw,tg,tr,trv,sfw,sfg,sfr, & + sfrv,lfrv,dgr,dg,lfr,lfg,drain,rainbl,qr, & a_u,a_v,a_t,a_e, & b_u,b_v,b_t,b_ac,b_e,b_q, & dlg,dl_u,sf,vl,rl_up,rs_abs,emiss,grdflx_urb, & qv,tlev,qlev,sflev,lflev,consumlev, & - sfvlev,lfvlev,twlev,tglev,tflev,sfwin,ix,iy) - -! ---------------------------------------------------------------------- -! This routine computes the effects of buildings on momentum, heat and -! TKE (turbulent kinetic energy) sources or sinks and on the mixing length. -! It provides momentum, heat and TKE sources or sinks at different levels of a -! mesoscale grid defined by the altitude of its cell interfaces "z" and -! its number of levels "nz". -! The meteorological input parameters (wind, temperature, solar radiation) -! are specified on the "mesoscale grid". -! The inputs concerning the building and street charateristics are defined -! on a "urban grid". The "urban grid" is defined with its number of levels -! "nz_u" and its space step "dz_u". -! The input parameters are interpolated on the "urban grid". The sources or sinks -! are calculated on the "urban grid". Finally the sources or sinks are -! interpolated on the "mesoscale grid". - + eppvlev,tpvlev,sfvlev,lfvlev,twlev,tglev,tflev,sfwin,tmp_u,sfr_indoor,sfrpv,gfr) + ! print*,'SFR_AFT',sfr(id,iz) + -! Mesoscale grid Urban grid Mesoscale grid -! -! z(4) --- --- -! | | -! | | -! | Interpolation Interpolation | -! | Sources or sinks calculation | -! z(3) --- --- -! | ua ua_u --- uv_a a_u | -! | va va_u | uv_b b_u | -! | pt pt_u --- uh_b a_v | -! z(2) --- | etc... etc...--- -! | z_u(1) --- | -! | | | -! z(1) ------------------------------------------------------------ - -! -! Reference: -! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE -! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104: -! 261-304 - -! ---------------------------------------------------------------------- implicit none @@ -1059,7 +1200,7 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ! Data relative to the "mesoscale grid" !! integer nz ! Number of vertical levels - integer kms,kme,kts,kte + integer kms,kme,kts,kte,ix,iy,itimestep real z(kms:kme) ! Altitude above the ground of the cell interfaces. real ua(kms:kme) ! Wind speed in the x direction real va(kms:kme) ! Wind speed in the y direction @@ -1074,6 +1215,9 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real ah ! Hour angle real rs ! Solar radiation real rld ! Downward flux of the longwave radiation + real xlat ! Latitude + real swddir ! short wave direct solar radiation !_gl + real swddif ! short wave diffuse solar radiation !_gl ! Data relative to the "urban grid" @@ -1089,6 +1233,7 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real emw ! Emissivity of wall real emr ! Emissivity of roof + ! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long and ! short wave radation. ! The calculation of these factor is explained in the Appendix A of the BLM paper @@ -1120,7 +1265,14 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real perflo_u(nurbm) real hsesf_u(nurbm) real hsequip(24) - + real irho(24) + real gr_frac_roof + real pv_frac_roof + integer gr_flag + integer gr_type + real tpv(nbui_max) + real sfpv(nbui_max) + real sfr_indoor(nbui_max) ! ---------------------------------------------------------------------- ! INPUT-OUTPUT ! ---------------------------------------------------------------------- @@ -1130,15 +1282,27 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real tw(2*ndm,nz_um,nwr_u,nbui_max) ! Temperature in each layer of the wall [K] real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K] real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real trv(ndm,nz_um,ngr_u) ! Temperature in each layer of the green roof [K] real sfw(2*ndm,nz_um,nbui_max) ! Sensible heat flux from walls real sfg(ndm) ! Sensible heat flux from ground (road) real sfr(ndm,nz_um) ! Sensible heat flux from roofs + real sfrv(ndm,nz_um) ! Sensible heat flux from green roofs + real lfrv(ndm,nz_um) ! Latent heat flux from green roofs + real dg(ndm) ! water depth ground (road) + real dgr(ndm,nz_um) ! water depth roofs + real lfr(ndm,nz_um) ! Latent heat flux from roofs + real lfg(ndm) ! Latent heat flux from ground (road) + real drain(ndm,nz_um) ! Green roof drainage + real rainbl ! Rainfall real gfg(ndm) ! Heat flux transferred from the surface of the ground (road) towards the interior real gfr(ndm,nz_um) ! Heat flux transferred from the surface of the roof towards the interior real gfw(2*ndm,nz_um,nbui_max) ! Heat flux transfered from the surface of the walls towards the interior + real qr(ndm,nz_um,ngr_u) ! Green Roof soil moisture + ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- + ! Data relative to the "mesoscale grid" @@ -1159,14 +1323,11 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real b_q(kms:kme) ! Explicit component of the humidity sources or sinks real dlg(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper). - - ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- real dz(kms:kme) ! vertical space steps of the "mesoscale grid" - ! Data interpolated from the "mesoscale grid" to the "urban grid" real ua_u(nz_um) ! Wind speed in the x direction @@ -1192,11 +1353,14 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real drst(ndm) ! Street directions for the current urban class real ss(nz_um) ! Probability to have a building with height h real pb(nz_um) ! Probability to have a building with an height equal + real cdrag(nz_um) + real alp ! Solar radiation at each level of the "urban grid" - real rsg(ndm) ! Short wave radiation from the ground + real rsg(ndm) ! Short wave radiation from the ground real rsw(2*ndm,nz_um) ! Short wave radiation from the walls + real rsd(2*ndm,nz_um) ! Direct Short wave radiation received by the walls real rlg(ndm) ! Long wave radiation from the ground real rlw(2*ndm,nz_um) ! Long wave radiation from the walls @@ -1204,9 +1368,10 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real ptg(ndm) ! Ground potential temperatures real ptr(ndm,nz_um) ! Roof potential temperatures + real ptrv(ndm,nz_um) ! Roof potential temperatures real ptw(2*ndm,nz_um,nbui_max) ! Walls potential temperatures - + real tg_av(ndm) ! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on ! vertical surfaces (walls) ans horizontal surfaces (roofs and street) ! The fluxes can be computed as follow: Fluxes of X = A*X + B @@ -1221,7 +1386,9 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real thb_u(ndm,nz_um) ! Temperature Horizontal surfaces, B (explicit) term real tva_u(2*ndm,nz_um) ! Temperature Vertical surfaces, A (implicit) term real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term - real tvb_ac(2*ndm,nz_um) + + + real tvb_ac(2*ndm,nz_um) real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term real qhb_u(ndm,nz_um) ! Humidity Horizontal surfaces, B (explicit) term @@ -1233,8 +1400,8 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real grdflx_urb ! ground heat flux real dt_int ! internal time step integer nt_int ! number of internal time step - integer iz,id, it_int - integer iw,ix,iy + integer iz,id, it_int,it + integer iw !--------------------------------------- !New variables uses in BEM @@ -1248,7 +1415,7 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real dzgb(ngb_u) !Layer sizes in the ground below the buildings real csgb(ngb_u) !Specific heat of the ground material below the buildings - !of the current urban class at each ground levels[J m^3 K^-1] + real csf(nf_u) !Specific heat of the floors materials in the buildings !of the current urban class at each levels[J m^3 K^-1] real alar(nwr_u+1) ! Roof thermal diffusivity for the current urban class [W/m K] @@ -1257,6 +1424,12 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real alagb(ngb_u+1) ! Ground thermal diffusivity below the building at each wall layer [W/m K] real sfrb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real sfrbpv(ndm,nbui_max) ! Sensible heat flux from PV panels [W/m2] + real sfrpv(ndm,nz_um) ! Sensible heat flux from PV panels [W/m2] + real sfrvb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real lfrvb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real lfrb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real gfrb(ndm,nbui_max) ! Heat flux flowing inside the roofs [W/m2] real sfwb1D(2*ndm,nz_um) !Sensible heat flux from the walls [W/m2] real sfwin(2*ndm,nz_um,nbui_max)!Sensible heat flux from windows [W/m2] @@ -1275,14 +1448,18 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real tflev(ndm,nf_u,nz_um-1,nbui_max)!Floor temperature in BEM[K] real tflevb1D(nf_u,nz_um-1) !Floor temperature in BEM[K] real trb(ndm,nwr_u,nbui_max) !Roof temperature in BEM [K] - real trb1D(nwr_u) !Roof temperature in BEM [K] - + real trvb(ndm,ngr_u,nbui_max) !Roof temperature in BEM [K] + real trb1D(nwr_u) + real sflev(nz_um,nz_um) ! sensible heat flux due to the air conditioning systems [W] real lflev(nz_um,nz_um) ! latent heat flux due to the air conditioning systems [W] real consumlev(nz_um,nz_um) ! consumption due to the air conditioning systems [W] real sflev1D(nz_um) ! sensible heat flux due to the air conditioning systems [W] real lflev1D(nz_um) ! latent heat flux due to the air conditioning systems [W] real consumlev1D(nz_um) ! consumption due to the air conditioning systems [W] + real eppvlev(nz_um) ! Electricity production of PV panels [W] + real tpvlev(ndm,nz_um) + real tpvlevb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] real sfvlev(nz_um,nz_um) ! sensible heat flux due to ventilation [W] real lfvlev(nz_um,nz_um) ! latent heat flux due to ventilation [W] real sfvlev1D(nz_um) ! sensible heat flux due to ventilation [W] @@ -1293,26 +1470,48 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real twlev_av(2*ndm,nz_um) ! Averaged temperature of the windows real sfw_av(2*ndm,nz_um) ! Averaged sensible heat from walls real sfwind_av(2*ndm,nz_um) ! Averaged sensible heat from windows - + integer flag_pvp integer nbui !Total number of different type of buildings in an urban class integer nlev(nz_um) !Number of levels in each different type of buildings in an urban class integer ibui,ily real :: nhourday ! Number of hours from midnight, local time + real :: st4,gamma,fp,lmr,smr,prova + real hfgr(ndm,nz_um)!heat flux green roof + real hfgrb(ndm,nbui_max) + real irri_per_ts + real irri_now + real tr_av(ndm,nz_um) + real tr_avb(ndm,nbui_max) + real sfr_avb(ndm,nbui_max) ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- - + ! Fix some usefull parameters for the computation of the sources or sinks ! !initialize the variables inside the param routine -! + nhourday=ah/PI*180./15.+12. + if (nhourday >= 24) nhourday = nhourday - 24 + if (nhourday < 0) nhourday = nhourday + 24 + + + if(sum(irho).gt.0)then + irri_per_ts=h_water/sum(irho) + else + irri_per_ts=0. + endif + + if(irho(int(nhourday)+1).ne.0)then + irri_now=irri_per_ts + else + irri_now=0. + endif + do iz=kts,kte dz(iz)=z(iz+1)-z(iz) end do - ! Interpolation on the "urban grid" - call interpol(kms,kme,kts,kte,nzu,z,z_u,ua,ua_u) call interpol(kms,kme,kts,kte,nzu,z,z_u,va,va_u) call interpol(kms,kme,kts,kte,nzu,z,z_u,pt,pt_u) @@ -1320,38 +1519,87 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & call interpol(kms,kme,kts,kte,nzu,z,z_u,pr,pr_u) call interpol(kms,kme,kts,kte,nzu,z,z_u,da,da_u) call interpol(kms,kme,kts,kte,nzu,z,z_u,qv,qv_u) - ! Compute the modification of the radiation due to the buildings call averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av, & - sfw_av,sfwind_av,sfw,sfwin) + sfw_av,sfwind_av,sfw,sfwin) + + do id=1,ndu + tg_av(id)=tg(id,ng_u) + do iz=1,nz_um + + tr_av(id,iz)=((1-gr_frac_roof)*tr(id,iz,nwr_u)**4.+ & + gr_frac_roof*trv(id,iz,ngr_u)**4.)**(1./4.) + + enddo + enddo + + - call modif_rad(iurb,ndu,nzu,z_u,ws, & + + call modif_rad(iurb,ndu,nzu,z_u,ws, & drst,strd,ss,pb, & - tw_av,tg,twlev_av,albg,albw, & + tw_av,tg_av,twlev_av,albg,albw, & emw,emg,pwin_u(iurb),albwin, & emwind,fww,fwg,fgw,fsw,fsg, & - zr,deltar,ah, & - rs,rld,rsw,rsg,rlw,rlg) + zr,deltar,ah,xlat,swddir,swddif, & !_gl + rs,rld,rsw,rsd,rsg,rlw,rlg) + + + ! calculation of the urban albedo and the upward long wave radiation + call upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & - tg,emg,albg,rlg,rsg,sfg, & + tg_av,emg,albg,rlg,rsg,sfg,lfg, & tw_av,emw,albw,rlw,rsw,sfw_av, & - tr,emr,albr,emwind, & - albwin,twlev_av,pwin_u(iurb),sfwind_av,rld,rs,sfr, & - rs_abs,rl_up,emiss,grdflx_urb) - -! Compute the surface temperatures + tr_av,emr,albr,emwind, & + albwin,twlev_av,pwin_u(iurb),sfwind_av,rld,rs,sfr,sfrv,lfr,lfrv, & + rs_abs,rl_up,emiss,grdflx_urb,gr_frac_roof,tpvlev,pv_frac_roof) + + do id=1,ndu + if(dg(id).le.dgmax) then + dg(id)=dg(id)+(rainbl+(lfg(id)*dt)/latent) + endif + if (dg(id).lt.0) then + dg(id)=0 + endif + if (dg(id).gt.dgmax) then + dg(id)=dgmax + endif + do iz=2,nz_um + if(dgr(id,iz).le.drmax) then + dgr(id,iz)=dgr(id,iz)+(rainbl+(lfr(id,iz)*dt)/latent) + endif + if (dgr(id,iz).lt.0) then + dgr(id,iz)=0 + endif + if (dgr(id,iz).gt.drmax) then + dgr(id,iz)=drmax + endif + enddo + enddo !id + + + - call surf_temp(ndu,pr_u,dt, & + call surf_temp(ndu,pr_u,dt, & rld,rsg,rlg, & - tg,alag,csg,emg,albg,ptg,sfg,gfg) - -! Call the BEM (Building Energy Model) routine + tg,alag,csg,emg,albg,ptg,sfg,lfg,gfg) + if(gr_flag.eq.1)then + if(gr_frac_roof.gt.0.)then + hfgr=0. + call roof_temp_veg(ndu,pr_u,dt, & + rld,rs, & + trv,ptrv,sfrv,lfrv,gfr,qr,rainbl,drain,hfgr,tr,alar(5),dzr(5),csr(5),nzu,irri_now,gr_type,pv_frac_roof,tpvlev) + + endif + endif + + do iz=1,nz_um !Compute the outdoor temperature tmp_u(iz)=pt_u(iz)*(pr_u(iz)/p0)**(rcp_u) @@ -1360,8 +1608,13 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ibui=0 nlev=0 nbui=0 - + hfgrb=0. sfrb=0. !Sensible heat flux from roof + sfrbpv=0. !Sensible heat flux from PV panels + sfrpv=0. !Sensible heat flux from PV panels + lfrvb=0. + lfrb=0. + sfrvb=0. gfrb=0. !Heat flux flowing inside the roof sfwb1D=0. !Sensible heat flux from walls sfwinb1D=0. !Sensible heat flux from windows @@ -1371,19 +1624,21 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & twb1D=0. !Wall temperature twlevb1D=0. !Window temperature tglevb1D=0. !Ground temperature below a building - tflevb1D=0. !Floor temperature + tflevb1D=0. !Floor temperature + trvb=0. trb=0. !Roof temperature trb1D=0. !Roof temperature - + tr_avb=0. qlevb1D=0. !Indoor humidity tlevb1D=0. !indoor temperature sflev1D=0. !Sensible heat flux from the a.c. lflev1D=0. !Latent heat flux from the a.c. consumlev1D=0.!Consumption from the a.c. + tpvlevb=0. + eppvlev=0. sfvlev1D=0. !Sensible heat flux from the natural ventilation lfvlev1D=0. !Latent heat flux from natural ventilation - ptw=0. !Wall potential temperature ptwin=0. !Window potential temperature ptr=0. !Roof potential temperature @@ -1394,10 +1649,21 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & nlev(ibui)=iz-1 nbui=ibui do id=1,ndm + tr_avb(id,ibui)=tr_av(id,iz) + tpvlevb(id,ibui)=tpvlev(id,iz) + hfgrb(id,ibui)=hfgr(id,iz) sfrb(id,ibui)=sfr(id,iz) + sfrvb(id,ibui)=sfrv(id,iz) + lfrvb(id,ibui)=lfrv(id,iz) + lfrb(id,ibui)=lfr(id,iz) + sfr_avb(id,ibui)=(1-gr_frac_roof)*sfr(id,iz)+gr_frac_roof*(sfrv(id,iz)) do ily=1,nwr_u trb(id,ily,ibui)=tr(id,iz,ily) enddo + do ily=1,ngr_u + trvb(id,ily,ibui)=trv(id,iz,ily) + enddo + enddo endif end do !iz @@ -1406,13 +1672,8 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & !Loop over BEM ----------------------------------------------------------------- !-------------------------------------------------------------------------------- !-------------------------------------------------------------------------------- - nhourday=ah/PI*180./15.+12. - if (nhourday >= 24) nhourday = nhourday - 24 - if (nhourday < 0) nhourday = nhourday + 24 - do ibui=1,nbui - - + do ibui=1,nbui do iz=1,nz_um qlevb1D(iz)=qlev(iz,ibui) tlevb1D(iz)=tlev(iz,ibui) @@ -1428,9 +1689,9 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & enddo do ily=1,nf_u - do iz=1,nz_um-1 - tflevb1D(ily,iz)=tflev(id,ily,iz,ibui) - enddo + do iz=1,nz_um-1 + tflevb1D(ily,iz)=tflev(id,ily,iz,ibui) + enddo enddo do iz=1,nz_um @@ -1449,177 +1710,41 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & twlevb1D(2*id,iz)=twlev(2*id,iz,ibui) enddo enddo - - !print*,'nz_um',nz_um - !print*,'nlev(ibui)',nlev(ibui) - !print*,'nhourday',nhourday - !print*,'dt',dt - !print*, 'bs_u(1,iurb)',bs_u(1,iurb) - !print*, 'bs_u(2,iurb)',bs_u(2,iurb) - !print*, 'dz_u',dz_u - !print*, 'nwr_u',nwr_u - !print*, 'nf_u',nf_u - !print*, 'nwr_u', nwr_u - !print*, 'ngb_u',ngb_u - !print*, 'sfwb1D',sfwb1D - !print*, 'gfwb1D',gfwb1D - !print*, 'sfwinb1D',sfwinb1D - !print*, 'sfrb(1,ibui)',sfrb(1,ibui) - !print*, 'gfrb(1,ibui)',gfrb(1,ibui) - !print*, 'latent',latent - !print*, 'sigma',sigma - !print*, 'albw_u(iurb)',albw - !print*, 'albwin_u(iurb)',albwin - !print*, 'albr_u(iurb)',albr - !print*, 'emr_u(iurb)',emr - !print*, 'emw_u(iurb)',emw - !print*, 'emwind_u(iurb)',emwind - !print*, 'rsw',rsw - !print*, 'rlw',rlw - !print*, 'r',r - !print*, 'cp_u',cp_u - !print*, 'da_u',da_u - !print*, 'tmp_u',tmp_u - !print*, 'qv_u',qv_u - !print*, 'pr_u',pr_u - !print*, 'rs',rs - !print*, 'rld',rld - !print*, 'dzw',dzw - !print*, 'csw',csw - !print*, 'alaw',alaw - !print*, 'pwin_u',pwin_u - !print*, 'cop_u(iurb)',cop_u(iurb) - !print*, 'beta_u(iurb)',beta_u(iurb) - !print*, 'sw_cond_u(iurb)',sw_cond_u(iurb) - !print*, 'time_on_u(iurb)',time_on_u(iurb) - !print*, 'time_off_u(iurb)',time_off_u(iurb) - !print*, 'targtemp_u(iurb)',targtemp_u(iurb) - !print*, 'gaptemp_u(iurb)',gaptemp_u(iurb) - !print*, 'targhum_u(iurb)',targhum_u(iurb) - !print*, 'gaphum_u(iurb)',gaphum_u(iurb) - !print*, 'perflo_u(iurb)',perflo_u(iurb) - !print*, 'hsesf_u(iurb)',hsesf_u(iurb) - !print*, 'hsequip',hsequip - !print*, 'dzf',dzf - !print*, 'csf',csf - !print*, 'alaf',alaf - !print*, 'dzgb',dzgb - !print*, 'csgb',csgb - !print*, 'alagb',alagb - !print*, 'dzr',dzr - !print*, 'csr',csr - !print*, 'alar',alar - !print*, 'tlevb1D',tlevb1D - !print*, 'qlevb1D',qlevb1D - !print*, 'twb1D',twb1D - !print*, 'twlevb1D',twlevb1D - !print*, 'tflevb1D',tflevb1D - !print*, 'tglevb1D',tglevb1D - !print*, 'trb1D',trb1D - !print*, 'sflev1D',sflev1D - !print*, 'lflev1D',lflev1D - !print*, 'consumlev1D',consumlev1D - !print*, 'sfvlev1D',sfvlev1D - !print*, 'lfvlev1D',lfvlev1D - + !print*,'HFGR_BEFORE_CALLING_BEM',hfgr(nlev(ibui)) - - - call BEM(nz_um,nlev(ibui),nhourday,dt,bs_u(1,iurb), & bs_u(2,iurb),dz_u,nwr_u,nf_u,nwr_u,ngb_u,sfwb1D,gfwb1D, & - sfwinb1D,sfrb(1,ibui),gfrb(1,ibui), & + sfwinb1D,sfr_avb(1,ibui),lfrb(1,ibui),gfrb(1,ibui), & + sfrbpv(1,ibui), & latent,sigma,albw,albwin,albr, & - emr,emw,emwind,rsw,rlw,r,cp_u, & - da_u,tmp_u,qv_u,pr_u,rs,rld,dzw,csw,alaw,pwin_u(iurb), & + emr,emw,emwind,rsw,rlw,r,cp_u, & + da_u,tmp_u,qv_u,pr_u,rs,swddif,rld,dzw,csw,alaw,pwin_u(iurb), & cop_u(iurb),beta_u(iurb),sw_cond_u(iurb),time_on_u(iurb), & time_off_u(iurb),targtemp_u(iurb),gaptemp_u(iurb), & targhum_u(iurb),gaphum_u(iurb),perflo_u(iurb), & + gr_frac_roof,pv_frac_roof,gr_flag, & + ua_u,va_u, & hsesf_u(iurb),hsequip, & - dzf,csf,alaf,dzgb,csgb,alagb,dzr,csr, & - alar,tlevb1D,qlevb1D,twb1D,twlevb1D,tflevb1D,tglevb1D, & - trb1D,sflev1D,lflev1D,consumlev1D,sfvlev1D,lfvlev1D) - - !print*,'nz_um A',nz_um - !print*,'nlev(ibui) A',nlev(ibui) - !print*,'nhourday A',nhourday - !print*,'dt A',dt - !print*, 'bs_u(1,iurb) A',bs_u(1,iurb) - !print*, 'bs_u(2,iurb) A',bs_u(2,iurb) - !print*, 'dz_u A',dz_u - !print*, 'nwr_u A',nwr_u - !print*, 'nf_u A',nf_u - !print*, 'nwr_u A', nwr_u - !print*, 'ngb_u A',ngb_u - !print*, 'sfwb1D A',sfwb1D - !print*, 'gfwb1D A',gfwb1D - !print*, 'sfwinb1D A',sfwinb1D - !print*, 'sfrb(1,ibui) A',sfrb(1,ibui) - !print*, 'gfrb(1,ibui) A',gfrb(1,ibui) - !print*, 'latent A',latent - !print*, 'sigma A',sigma - !print*, 'albw_u(iurb) A',albw - !print*, 'albwin_u(iurb) A',albwin - !print*, 'albr_u(iurb) A',albr - !print*, 'emr_u(iurb) A',emr - !print*, 'emw_u(iurb) A',emw - !print*, 'emwind_u(iurb) A',emwind - !print*, 'rsw A',rsw - !print*, 'rlw A',rlw - !print*, 'r A',r - !print*, 'cp_u A',cp_u - !print*, 'da_u A',da_u - !print*, 'tmp_u A',tmp_u - !print*, 'qv_u A',qv_u - !print*, 'pr_u A',pr_u - !print*, 'rs A',rs - !print*, 'rld A',rld - !print*, 'dzw A',dzw - !print*, 'csw A',csw - !print*, 'alaw A',alaw - !print*, 'pwin_u A',pwin_u - !print*, 'cop_u(iurb) A',cop_u(iurb) - !print*, 'beta_u(iurb) A',beta_u(iurb) - !print*, 'sw_cond_u(iurb) A',sw_cond_u(iurb) - !print*, 'time_on_u(iurb) A',time_on_u(iurb) - !!print*, 'time_off_u(iurb) A',time_off_u(iurb) - !print*, 'targtemp_u(iurb) A',targtemp_u(iurb) - !print*, 'gaptemp_u(iurb) A ',gaptemp_u(iurb) - !print*, 'targhum_u(iurb) A ',targhum_u(iurb) - !print*, 'gaphum_u(iurb) A',gaphum_u(iurb) - !print*, 'perflo_u(iurb) A',perflo_u(iurb) - !print*, 'hsesf_u(iurb) A',hsesf_u(iurb) - !print*, 'hsequip A',hsequip - !print*, 'dzf A',dzf - !print*, 'csf A',csf - !print*, 'alaf A',alaf - !print*, 'dzgb A',dzgb - !print*, 'csgb A',csgb - !print*, 'alagb A',alagb - !print*, 'dzr A',dzr - !print*, 'csr A',csr - !print*, 'alar A',alar - !print*, 'tlevb1D A',tlevb1D - !print*, 'qlevb1D A',qlevb1D - !print*, 'twb1D A',twb1D - !print*, 'twlevb1D A',twlevb1D - !print*, 'tflevb1D A',tflevb1D - !print*, 'tglevb1D A',tglevb1D - !print*, 'trb1D A',trb1D - !print*, 'sflev1D A',sflev1D - !print*, 'lflev1D A',lflev1D - !print*, 'consumlev1D A',consumlev1D - !print*, 'sfvlev1D A',sfvlev1D - !print*, 'lfvlev1D A',lfvlev1D + dzf,csf,alaf,dzgb,csgb,alagb,dzr,csr, & + alar,tlevb1D,qlevb1D,twb1D,twlevb1D,tflevb1D,tglevb1D, & + trb1D,sflev1D,lflev1D,consumlev1D,eppvlev(ibui), & + tpvlevb(1,ibui), & + sfvlev1D,lfvlev1D,hfgrb(1,ibui),tr_avb(1,ibui), & + tpv(ibui),sfpv(ibui),sfr_indoor(ibui)) + - ! !Temporal modifications -! +! + tpvlevb(2,ibui)=tpvlevb(1,ibui) sfrb(2,ibui)=sfrb(1,ibui) + sfrvb(2,ibui)=sfrvb(1,ibui) + lfrvb(2,ibui)=lfrvb(1,ibui) + lfrb(2,ibui)=lfrb(1,ibui) + sfrbpv(2,ibui)=sfrbpv(1,ibui) gfrb(2,ibui)=gfrb(1,ibui) -! + hfgrb(2,ibui)=hfgrb(1,ibui) !End temporal modifications ! do iz=1,nz_um @@ -1646,18 +1771,12 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & enddo enddo -!! do iz=1,nz_um -!! sfwin(2*id-1,iz,ibui)=sfwinb1D(2*id-1,iz) -!! sfwin(2*id,iz,ibui)=sfwinb1D(2*id,iz) -!! enddo do iz=1,nz_um do ily=1,nwr_u tw(2*id-1,iz,ily,ibui)=twb1D(2*id-1,ily,iz) tw(2*id,iz,ily,ibui)=twb1D(2*id,ily,iz) enddo -!! sfw(2*id-1,iz,ibui)=sfwb1D(2*id-1,iz) -!! sfw(2*id,iz,ibui)=sfwb1D(2*id,iz) gfw(2*id-1,iz,ibui)=gfwb1D(2*id-1,iz) gfw(2*id,iz,ibui)=gfwb1D(2*id,iz) twlev(2*id-1,iz,ibui)=twlevb1D(2*id-1,iz) @@ -1666,7 +1785,7 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & enddo enddo !ibui - + !----------------------------------------------------------------------------- !End loop over BEM ----------------------------------------------------------- !----------------------------------------------------------------------------- @@ -1674,43 +1793,67 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ibui=0 - do iz=1,nz_um + do iz=1,nzu!nz_um if(ss(iz).gt.0) then ibui=ibui+1 do id=1,ndm gfr(id,iz)=gfrb(id,ibui) + tpvlev(id,iz)=tpvlevb(id,ibui) sfr(id,iz)=sfrb(id,ibui) + hfgr(id,iz)=hfgrb(id,ibui) + sfrpv(id,iz)=-sfrbpv(id,ibui) + lfr(id,iz)=lfrb(id,ibui) do ily=1,nwr_u tr(id,iz,ily)=trb(id,ily,ibui) enddo ptr(id,iz)=tr(id,iz,nwr_u)*(pr_u(iz)/p0)**(-rcp_u) enddo endif - enddo !iz + enddo !iz !Compute the potential temperature for the vertical surfaces of the buildings do id=1,ndm - do iz=1,nz_um + do iz=1,nzu!nz_um do ibui=1,nbui ptw(2*id-1,iz,ibui)=tw(2*id-1,iz,nwr_u,ibui)*(pr_u(iz)/p0)**(-rcp_u) ptw(2*id,iz,ibui)=tw(2*id,iz,nwr_u,ibui)*(pr_u(iz)/p0)**(-rcp_u) ptwin(2*id-1,iz,ibui)=twlev(2*id-1,iz,ibui)*(pr_u(iz)/p0)**(-rcp_u) ptwin(2*id,iz,ibui)=twlev(2*id,iz,ibui)*(pr_u(iz)/p0)**(-rcp_u) + enddo enddo enddo +!NEW CDRAG! + do iz=1,nz_um + alp=0. + do id=1,ndu + alp=alp+bs(id)/(ws(id)+bs(id))*pb(iz) + enddo + alp=alp/ndu + if(alp.lt.0.29)then + cdrag(iz)=3.32*alp**0.47 + else + cdrag(iz)=1.85 + endif + enddo + ! Compute the implicit and explicit components of the sources or sinks on the "urban grid" - - call buildings(iurb,ndu,nzu,z0,ua_u,va_u, & - pt_u,pt0_u,ptg,ptr,da_u,ptw,ptwin,pwin_u(iurb),drst, & + + call buildings(iurb,ndu,nzu,z0,cdrag,ua_u,va_u, & + pt_u,pt0_u,ptg,ptr,ptrv,da_u,qv_u,pr_u,tmp_u,ptw,ptwin,pwin_u(iurb),drst, & uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u,qvb_u,qhb_u, & - uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr, & - sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac) + uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr,sfrpv,sfrv,lfrv, & + dgr,dg,lfr,lfg, & + sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac,ix,iy,rsg,rs,qr,gr_frac_roof, & + pv_frac_roof,gr_flag,gr_type) + + + ! Calculation of the sensible heat fluxes for the ground, the wall and roof ! Sensible Heat Flux = density * Cp_U * ( A* potential temperature + B ) ! where A and B are the implicit and explicit components of the heat sources or sinks. @@ -1940,16 +2083,12 @@ subroutine param(iurb,nzu,nzurb,nzurban,ndu, & enddo do id=1,ndu if ((bs(id)<=1.).OR.(bs(id)>=150.)) then -! write(*,*) 'WARNING, WIDTH OF THE BUILDING WRONG',id,bs(id) -! write(*,*) 'WIDTH OF THE STREET',id,ws(id) bs(id)=bs_u(id,iurb) ws(id)=ws_u(id,iurb) bs_urb(id,iurb)=bs_u(id,iurb) ws_urb(id,iurb)=ws_u(id,iurb) endif if ((ws(id)<=1.).OR.(ws(id)>=150.)) then -! write(*,*) 'WARNING, WIDTH OF THE STREET WRONG',id,ws(id) -! write(*,*) 'WIDTH OF THE BUILDING',id,bs(id) ws(id)=ws_u(id,iurb) bs(id)=bs_u(id,iurb) bs_urb(id,iurb)=bs_u(id,iurb) @@ -2095,10 +2234,10 @@ end subroutine averaging_temp ! ===6=8===============================================================72 subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & - tw,tg,twlev,albg,albw,emw,emg,pwin,albwin, & + tw,tg_av,twlev,albg,albw,emw,emg,pwin,albwin, & emwin,fww,fwg,fgw,fsw,fsg, & - zr,deltar,ah, & - rs,rl,rsw,rsg,rlw,rlg) + zr,deltar,ah,xlat,swddir,swddif, & + rs,rl,rsw,rsd,rsg,rlw,rlg) ! ---------------------------------------------------------------------- ! This routine computes the modification of the short wave and @@ -2121,7 +2260,7 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & real ss(nz_um) ! probability to have a building with height h real pb(nz_um) ! probability to have a building with an height equal real tw(2*ndm,nz_um) ! Temperature in each layer of the wall [K] - real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real tg_av(ndm) ! Temperature in each layer of the ground [K] real albg ! Albedo of the ground for the current urban class real albw ! Albedo of the wall for the current urban class real emg ! Emissivity of ground for the current urban class @@ -2137,6 +2276,10 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & real deltar ! Declination of the sun real rs ! solar radiation real rl ! downward flux of the longwave radiation + real xlat ! latitudine + real swddir ! short wave direct solar radiation _gl + real swddif ! short wave diffuse solar radiation _gl + ! !New variables BEM ! @@ -2152,6 +2295,7 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & real rlw(2*ndm,nz_um) ! Long wave radiation at the walls real rsg(ndm) ! Short wave radiation at the ground real rsw(2*ndm,nz_um) ! Short wave radiation at the walls + real rsd(2*ndm,nz_um) ! Direct Short wave radiation at the walls ! ---------------------------------------------------------------------- ! LOCAL: @@ -2162,27 +2306,31 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & ! Calculation of the shadow effects call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & - rs,rsw,rsg) + swddir,rsw,rsg,xlat) + rsd=rsw ! Calculation of the reflection effects do id=1,nd call long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev, & - fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb) + fwg,fww,fgw,fsw,fsg,tg_av,tw,rlg,rlw,rl,pb) alb_av=pwin*albwin+(1.-pwin)*albw - call short_rad(iurb,nz_u,id,alb_av,albg,fwg,fww,fgw,rsg,rsw,pb) - + call short_rad_dd(iurb,nz_u,id,alb_av, & + albg,swddif,fwg,fww,fgw,fsw,fsg,rsg,rsw,pb) + + enddo return end subroutine modif_rad + ! ===6=8===============================================================72 ! ===6=8===============================================================72 subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & - tg,alag,csg,emg,albg,ptg,sfg,gfg) + tg,alag,csg,emg,albg,ptg,sfg,lfg,gfg) ! ---------------------------------------------------------------------- ! Computation of the surface temperatures for walls, ground and roofs @@ -2213,6 +2361,8 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & real sfg(ndm) ! Sensible heat flux from ground (road) + real lfg(ndm) ! Latent heat flux from ground (road) + real gfg(ndm) ! Heat flux transferred from the surface of the ground (road) toward the interior real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] @@ -2235,6 +2385,7 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/ + ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- @@ -2248,10 +2399,13 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & tg_tmp(ig)=tg(id,ig) end do ! +! print*,'alag','cs',alag(1),csg(1) + call soil_temp(ng_u,dzg_u,tg_tmp,ptg(id),alag,csg, & rsg(id),rlg(id),pr(1), & dt,emg,albg, & - rtg(id),sfg(id),gfg(id)) + rtg(id),sfg(id),lfg(id),gfg(id)) + do ig=1,ng_u tg(id,ig)=tg_tmp(ig) end do @@ -2260,16 +2414,198 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & return end subroutine surf_temp + + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + + subroutine roof_temp_veg(nd,pr,dt,rl,rsr, & + trv,ptrv,sfrv,lfrv,gfr,qr,rainbl,drain,hfgroof,tr,alar,dzr,csr,nzu,irri_now,gr_type,pv_frac_roof,tpvlev) + +! ---------------------------------------------------------------------- +! Computation of the surface temperatures for walls, ground and roofs +! ---------------------------------------------------------------------- + + implicit none + +! ---------------------------------------------------------------------- +! INPUT: +! ---------------------------------------------------------------------- + real rainbl + integer nd ! Number of street direction for the current urban class + + integer nzu ! Number of urban layers + real irho(24) ! Which hour of irrigation\ + + + real alar ! Roof thermal diffusivity for the current urban class [m^2 s^-1] + real pv_frac_roof + real csr + + real dzr ! Layer sizes in the roofs [m] + + real dt ! Time step + + real pr(nz_um) ! Air pressure + + real rl ! Downward flux of the longwave radiation + + real rsr ! Short wave radiation at the ground + + real tpvlev(ndm,nz_um) + + real sfrv(ndm,nz_um) ! Sensible heat flux from ground (road) + + real lfrv(ndm,nz_um) ! Latent heat flux from ground (road) + + real gfr(ndm,nz_um) ! Heat flux transferred from the surface of the ground (road) toward the interior + + real trv(ndm,nz_um,ngr_u) ! Temperature in each layer of the green roof [K] + + real qr(ndm,nz_um,ngr_u) ! Humidity in each layer of the green roof + + real tr(ndm,nz_um,nwr_u) !Roof temperature in BEM [K] + +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- + real ptrv(ndm,nz_um) ! Ground potential temperatures + + real hfgroof(ndm,nz_um) +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + integer id,ig,ir,iw,iz + + real alagr(ngr_u) ! Green Roof thermal diffusivity for the current urban class [m^2 s^-1] + + real rtr(ndm,nz_um) ! Total radiation at ground(road) surface (solar+incoming long+outgoing long) + + real tr_tmp(ngr_u) + + real qr_tmp(ngr_u) + real qr_tmp_old(ngr_u) + real dzgr_u(ngr_u) ! Layer sizes in the green roof +!MODIFICA + data dzgr_u /0.1,0.003,0.06,0.003,0.05,0.04,0.02,0.0125,0.005,0.0025/ + real cs(ngr_u) ! Specific heat of the ground material + real cw + parameter(cw=4.295e6) + real s(ngr_u) + real d(ngr_u) + real k(ngr_u) + real qr_m ! mean soil moisture between layers + real qrmax(ngr_u) + real smax(ngr_u) + real kmax(ngr_u) + real b(ngr_u) + real cd(ngr_u) + real csa(4) + real ka(4) + real qref + parameter(qref=0.37) + data qrmax /0.0,0.0,0.0,0.0,0.439,0.37,0.37,0.37,0.37,0.37/ + data smax /0,0,0,0,-0.01,-0.1,-0.1,-0.1,-0.1,-0.1/ + data kmax /0,0,0,0,3.32e-3,2.162e-3,2.162e-3,2.162e-3,2.162e-3,2.162e-3/ + data b /0,0,0,0,2.7,3.9,3.9,3.9,3.9,3.9/ + data cd /0,0,0,0,331500,1.342e6,1.342e6,1.342e6,1.342e6,1.342e6/ + data csa /7.5e4,2.1e6,4.48e4,2.1e6/ + data ka /0.035,0.7,0.024,0.7/ + real em_gr(1) + real alb_gr(1) + real irri_now + integer gr_type + real drain(ndm,nz_um) +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS + + if(gr_type.eq.1)then + em_gr=0.95 + alb_gr=0.3 + elseif(gr_type.eq.2)then + em_gr=0.83 + alb_gr=0.154 + endif + + + do iz=2,nzu + + do id=1,nd + + + + +! Calculation for the ground surfaces + + do ig=1,ngr_u + tr_tmp(ig)=trv(id,iz,ig) + qr(id,iz,ig) = max(qr(id,iz,ig),1e-6) !cenlin, 11/4/2020 + qr_tmp(ig)=qr(id,iz,ig) + qr_tmp_old(ig)=qr(id,iz,ig) + + if(ig.le.4) then + + cs(ig)=csa(ig) + alagr(ig)=ka(ig)/csa(ig) + + else + + + if (ig.gt.5) then + qr_m=(qr(id,iz,ig)*dzgr_u(ig-1)+qr(id,iz,ig-1)*dzgr_u(ig))/(dzgr_u(ig)+dzgr_u(ig-1)) + else + qr_m=qr(id,iz,ig) + endif + cs(ig)=(1-qr_m)*cd(ig)+qr_m*cw + s(ig)=smax(ig)*(qrmax(ig)/qr_m)**b(ig) + k(ig)=kmax(ig)*(qr_m/qrmax(ig))**(2*b(ig)+3) + d(ig)=-b(ig)*kmax(ig)*smax(ig)*((qr_m/qrmax(ig))**(b(ig)+3))/qr_m + if (log10(abs(s(ig))).le.5.1) then + alagr(ig)=exp(-(log10(abs(s(ig)))+2.7))*4.186e2/cs(ig) + endif + if (log10(abs(s(ig))).gt.5.1) then + alagr(ig)=0.00041*4.186e2/cs(ig) + endif + + endif + + end do + hfgroof(id,iz)=(alar/csr+alagr(1))*(tr_tmp(1)-tr(id,iz,5))/(dzr+dzgr_u(1)) + + call soil_temp_veg(hfgroof(id,iz),ngr_u,dzgr_u,tr_tmp,ptrv(id,iz),alagr,cs, & + rsr,rl,pr(iz), & + dt,em_gr(1),alb_gr(1), & + rtr(id,iz),sfrv(id,iz),lfrv(id,iz),gfr(id,iz),pv_frac_roof,tpvlev(id,iz)) + do ig=1,ngr_u + trv(id,iz,ig)=tr_tmp(ig) + end do + drain(id,iz)=kmax(5)*(qr(id,iz,5)/qrmax(5))**(2*b(5)+3) + call soil_moist(ngr_u,dzgr_u,qr_tmp,dt,lfrv(id,iz),d,k,rainbl,drain(id,iz),irri_now) + + do ig=1,ngr_u + ! qr(id,iz,ig)=min(qr_tmp(ig),qrmax(ig)) + qr(id,iz,ig)=max(min(qr_tmp(ig),qrmax(ig)),1e-6) !cenlin,11/4/2020 + end do + + end do !id + end do !iz + + return + end subroutine roof_temp_veg + ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & - ptg,ptr,da_u,ptw,ptwin,pwin, & + subroutine buildings(iurb,nd,nz,z0,cdrag,ua_u,va_u,pt_u,pt0_u, & + ptg,ptr,ptrv,da_u,qv_u,pr_u,tmp_u,ptw,ptwin,pwin, & drst,uva_u,vva_u,uvb_u,vvb_u, & tva_u,tvb_u,evb_u,qvb_u,qhb_u, & - uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr, & - sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac) + uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr,sfrpv,sfrv,lfrv, & + dgr,dg,lfr,lfg, & + sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac,ix,iy,rsg,rs,qr,gr_frac_roof, & + pv_frac_roof,gr_flag,gr_type) ! ---------------------------------------------------------------------- ! This routine computes the sources or sinks of the different quantities @@ -2284,23 +2620,34 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & ! INPUT: ! ---------------------------------------------------------------------- integer nd ! Number of street direction for the current urban class + integer ix,iy integer nz ! number of vertical space steps real ua_u(nz_um) ! Wind speed in the x direction on the urban grid real va_u(nz_um) ! Wind speed in the y direction on the urban grid real da_u(nz_um) ! air density on the urban grid + real qv_u(nz_um) ! specific humidity on the urban grid + real pr_u(nz_um) ! pressure on the urban grid + real tmp_u(nz_um) ! temperaure on the urban grid real drst(ndm) ! Street directions for the current urban class real dz real pt_u(nz_um) ! Potential temperature on the urban grid real pt0_u(nz_um) ! reference potential temperature on the urban grid real ptg(ndm) ! Ground potential temperatures real ptr(ndm,nz_um) ! Roof potential temperatures + real ptrv(ndm,nz_um) ! Green Roof potential temperatures real ptw(2*ndm,nz_um,nbui_max) ! Walls potential temperatures real ss(nz_um) ! probability to have a building with height h real pb(nz_um) + real cdrag(nz_um) real z0(ndm,nz_um) ! Roughness lengths "profiles" real dt ! time step integer iurb !Urban class - + real rsg(ndm) ! Solar Radiation + real rs ! Solar Radiation + real qr(ndm,nz_um,ngr_u) ! Ground Soil Moisture + real trv(ndm,nz_um,ngr_u) ! Ground Soil Moisture + real roof_frac + real road_frac ! !New variables (BEM) ! @@ -2315,6 +2662,10 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & real ptwin(2*ndm,nz_um,nbui_max) ! window potential temperature real pwin real tvb_ac(2*ndm,nz_um) + real gr_frac_roof + real pv_frac_roof + integer gr_flag,gr_type + ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- @@ -2334,11 +2685,22 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term + real uhb(2*ndm,nz_um) + real vhb(2*ndm,nz_um) + real ehb(2*ndm,nz_um) real sfw(2*ndm,nz_um,nbui_max) ! sensible heat flux from walls real sfwin(2*ndm,nz_um,nbui_max) ! sensible heat flux form windows real sfr(ndm,nz_um) ! sensible heat flux from roof + real sfrv(ndm,nz_um) ! sensible heat flux from roof + real lfrv(ndm,nz_um) ! Latent heat flux from roof + real dgr(ndm,nz_um) ! sensible heat flux from roof + real dg(ndm) + real lfr(ndm,nz_um) ! Latent heat flux from roof + real lfg(ndm) ! Latent heat flux from street + real sfrpv(ndm,nz_um) ! sensible heat flux from PV panels real sfg(ndm) ! sensible heat flux from street + ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- @@ -2349,9 +2711,22 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & real vvb_tmp real evb_tmp integer nlev(nz_um) - integer id,iz,ibui,nbui - -! ---------------------------------------------------------------------- + integer id,iz,ibui,nbui,il + real wfg !Ground water pool fraction + real wfr !Roof water pool fraction + real uhbv(2*ndm,nz_um) + real vhbv(2*ndm,nz_um) + real ehbv(2*ndm,nz_um) + real z0v !Vegetation roughness + parameter(z0v=0.01) + real resg + real rsveg + real f1,f2,f3,f4 + integer rsv(2) + real qr_tmp(ngr_u) + data rsv /0,1/ + real fh,ric,utot +!------------------------------------------------------------------ ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- dz=dz_u @@ -2373,9 +2748,17 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & evb_u=0. qvb_u=0. qhb_u=0. + + uhb=0. + vhb=0. + ehb=0. + uhbv=0. + vhbv=0. + ehbv=0. + do iz=1,nz_um - if(ss(iz).gt.0) then + if(ss(iz).gt.0)then ibui=ibui+1 d_urb(ibui)=ss(iz) nlev(ibui)=iz-1 @@ -2383,31 +2766,70 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & endif enddo - do id=1,nd - ! Calculation at the ground surfaces - - call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1), & - ptg(id),uhb_u(id,1), & - vhb_u(id,1),sfg(id),ehb_u(id,1),da_u(1)) - thb_u(id,1)=- sfg(id)/(da_u(1)*cp_u) - -! Calculation at the roof surfaces - + do id=1,nd + + call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1), & + ptg(id),qv_u(1),uhb(id,1), & + vhb(id,1),sfg(id),lfg(id),ehb(id,1),da_u(1),pr_u(1)) + if(dg(id).gt.0)then + wfg=dg(id)/dgmax + lfg(id)=-da_u(1)*latent*(-(wfg*lfg(id))/(da_u(1)*latent)) + else + qhb_u(id,1)=0. + lfg(id)=0. + endif + thb_u(id,1)=-(sfg(id))/(da_u(1)*cp_u) + vhb_u(id,1)=vhb(id,1) + uhb_u(id,1)=uhb(id,1) + ehb_u(id,1)=ehb(id,1) + qhb_u(id,1)=-lfg(id)/(da_u(1)*latent) do iz=2,nz if(ss(iz).gt.0)then - call flux_flat(dz,z0(id,iz),ua_u(iz), & - va_u(iz),pt_u(iz),pt0_u(iz), & - ptr(id,iz),uhb_u(id,iz), & - vhb_u(id,iz),sfr(id,iz),ehb_u(id,iz),da_u(iz)) - thb_u(id,iz)=- sfr(id,iz)/(da_u(iz)*cp_u) + + call flux_flat(dz,z0(id,iz),ua_u(iz),& + va_u(iz),pt_u(iz),pt0_u(iz), & + ptr(id,iz),qv_u(iz),uhb(id,iz), & + vhb(id,iz),sfr(id,iz),lfr(id,iz),ehb(id,iz),da_u(iz),pr_u(iz)) + if(dgr(id,iz).gt.0)then + wfr=dgr(id,iz)/drmax + lfr(id,iz)=-da_u(iz)*latent*(-(wfr*lfr(id,iz))/(da_u(iz)*latent)) + else + lfr(id,iz)=0. + endif + if(gr_flag.eq.1.and.gr_frac_roof.gt.0.)then + do il=1,ngr_u + qr_tmp(il)=qr(id,iz,il) + enddo + call flux_flat_roof(dz,z0v,ua_u(iz),va_u(iz),pt_u(iz),pt0_u(iz), & + ptrv(id,iz),uhbv(id,iz), & + vhbv(id,iz),sfrv(id,iz),lfrv(id,iz),ehbv(id,iz),da_u(iz),qv_u(iz),pr_u(iz),rs,qr_tmp,resg,rsveg,f1,f2,f3,f4,gr_type,pv_frac_roof) + sfr(id,iz)=sfr(id,iz)+pv_frac_roof*sfrpv(id,iz) + thb_u(id,iz)=-((1.-gr_frac_roof)*sfr(id,iz)+gr_frac_roof*sfrv(id,iz))/(da_u(iz)*cp_u) + vhb_u(id,iz)=(1.-gr_frac_roof)*vhb(id,iz)+gr_frac_roof*vhbv(id,iz) + uhb_u(id,iz)=(1.-gr_frac_roof)*uhb(id,iz)+gr_frac_roof*uhbv(id,iz) + ehb_u(id,iz)=(1.-gr_frac_roof)*ehb(id,iz)+gr_frac_roof*ehbv(id,iz) + qhb_u(id,iz)=-(gr_frac_roof*lfrv(id,iz)+(1.-gr_frac_roof)*lfr(id,iz))/(da_u(iz)*latent) + sfr(id,iz)=sfr(id,iz)-pv_frac_roof*sfrpv(id,iz) + else + sfr(id,iz)=sfr(id,iz)+pv_frac_roof*sfrpv(id,iz) + thb_u(id,iz)=-sfr(id,iz)/(da_u(iz)*cp_u) + vhb_u(id,iz)=vhb(id,iz) + uhb_u(id,iz)=uhb(id,iz) + ehb_u(id,iz)=ehb(id,iz) + qhb_u(id,iz)=-lfr(id,iz)/(da_u(iz)*latent) + sfr(id,iz)=sfr(id,iz)-pv_frac_roof*sfrpv(id,iz) + endif else uhb_u(id,iz) = 0.0 vhb_u(id,iz) = 0.0 thb_u(id,iz) = 0.0 ehb_u(id,iz) = 0.0 + qhb_u(id,iz) = 0.0 endif - end do + enddo + + ! Calculation at the wall surfaces @@ -2419,7 +2841,7 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & uva_tmp,vva_tmp, & uvb_tmp,vvb_tmp, & sfw(2*id-1,iz,ibui),sfwin(2*id-1,iz,ibui), & - evb_tmp,drst(id),dt) + evb_tmp,drst(id),dt,cdrag(iz)) if (pb(iz+1).gt.0.) then @@ -2444,7 +2866,7 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & uva_tmp,vva_tmp, & uvb_tmp,vvb_tmp, & sfw(2*id,iz,ibui),sfwin(2*id,iz,ibui), & - evb_tmp,drst(id),dt) + evb_tmp,drst(id),dt,cdrag(iz)) if (pb(iz+1).gt.0.) then @@ -2785,7 +3207,7 @@ end subroutine interp_length ! ===6=8===============================================================72 subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & - rs,rsw,rsg) + swddir,rsw,rsg,xlat) ! ---------------------------------------------------------------------- ! Modification of short wave radiation to take into account @@ -2802,13 +3224,14 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & real ah ! Hour angle (it should come from the radiation routine) real deltar ! Declination of the sun real drst(ndm) ! street directions for the current urban class - real rs ! solar radiation + real swddir ! solar radiation real ss(nz_um) ! probability to have a building with height h real pb(nz_um) ! Probability that a building has an height greater or equal to h real ws(ndm) ! Street width of the current urban class real z(nz_um) ! Height of the urban grid levels real zr ! zenith angle - + real xlat + real xlat_r ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- @@ -2825,23 +3248,29 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- - if(rs.eq.0.or.sin(zr).eq.1)then - do id=1,nd - rsg(id)=0. - do iz=1,nz_u + xlat_r=xlat*pi/180 + + if(swddir.eq.0.or.sin(zr).eq.1)then + do id=1,nd + rsg(id)=0. + do iz=1,nz_u rsw(2*id-1,iz)=0. rsw(2*id,iz)=0. enddo enddo - else + else !test - if(abs(sin(zr)).gt.1.e-10)then + + if(abs(sin(zr)).gt.1.e-10)then if(cos(deltar)*sin(ah)/sin(zr).ge.1)then bbb=pi/2. elseif(cos(deltar)*sin(ah)/sin(zr).le.-1)then bbb=-pi/2. else - bbb=asin(cos(deltar)*sin(ah)/sin(zr)) + bbb=asin(cos(deltar)*sin(ah)/sin(zr)) ! + if(sin(deltar).lt.(cos(zr)*sin(xlat_r)))then ! + bbb=pi-bbb ! + endif endif else if(cos(deltar)*sin(ah).ge.0)then @@ -2850,58 +3279,63 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & bbb=-pi/2. endif endif - - phix=zr + phix=zr do id=1,nd - + rsg(id)=0. - + aae=bbb-drst(id) aaw=bbb-drst(id)+pi - + do iz=1,nz_u rsw(2*id-1,iz)=0. - rsw(2*id,iz)=0. - if(pb(iz+1).gt.0.)then - do jz=1,nz_u + rsw(2*id,iz)=0. + if(pb(iz+1).gt.0.)then + do jz=1,nz_u if(abs(sin(aae)).gt.1.e-10)then - call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, & - ws(id),rd) - rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1) + call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, & + ws(id),rd) + rsw(2*id-1,iz)=rsw(2*id-1,iz)+swddir*rd*ss(jz+1)/pb(iz+1) endif - + if(abs(sin(aaw)).gt.1.e-10)then - call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, & + call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, & ws(id),rd) - rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1) + rsw(2*id,iz)=rsw(2*id,iz)+swddir*rd*ss(jz+1)/pb(iz+1) endif - enddo - endif + enddo + endif enddo if(abs(sin(aae)).gt.1.e-10)then wsd=abs(ws(id)/sin(aae)) - - do jz=1,nz_u + + do jz=1,nz_u rd=max(0.,wsd-z(jz+1)*tan(phix)) - rsg(id)=rsg(id)+rs*rd*ss(jz+1)/wsd + rsg(id)=rsg(id)+swddir*rd*ss(jz+1)/wsd enddo rtot=0. - + do iz=1,nz_u rtot=rtot+(rsw(2*id,iz)+rsw(2*id-1,iz))* & (z(iz+1)-z(iz)) enddo rtot=rtot+rsg(id)*ws(id) else - rsg(id)=rs + rsg(id)=swddir endif + + enddo endif return end subroutine shadow_mas + + + + ! ===6=8===============================================================72 ! ===6=8===============================================================72 @@ -2962,7 +3396,7 @@ end subroutine shade_wall ! ===6=8===============================================================72 subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& - fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb) + fwg,fww,fgw,fsw,fsg,tg_av,tw,rlg,rlw,rl,pb) ! ---------------------------------------------------------------------- ! This routine computes the effects of the reflections of long-wave @@ -2992,7 +3426,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& integer nz_u ! Number of layer in the urban grid real pb(nz_um) ! Probability to have a building with an height equal real rl ! Downward flux of the longwave radiation - real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real tg_av(ndm) ! Temperature in each layer of the ground [K] real tw(2*ndm,nz_um) ! Temperature in each layer of the wall [K] ! !New Variables for BEM @@ -3038,7 +3472,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& !! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)*pb(i+1) aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb) - bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4 + bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg_av(id)**4 do j=1,nz_u bbb(i)=bbb(i)+pb(j+1)*sigma*fww(j,i,id,iurb)* & (emw*(1.-pwin)*tw(2*id,j)**4+emwin*pwin*twlev(2*id,j)**4)+ & @@ -3065,7 +3499,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb) bbb(i)=fsw(i-nz_u,id,iurb)*rl+ & - emg*fgw(i-nz_u,id,iurb)*sigma*tg(id,ng_u)**4 + emg*fgw(i-nz_u,id,iurb)*sigma*tg_av(id)**4 do j=1,nz_u bbb(i)=bbb(i)+pb(j+1)*sigma*fww(j,i-nz_u,id,iurb)* & @@ -3117,8 +3551,9 @@ end subroutine long_rad ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine short_rad(iurb,nz_u,id,albw, & - albg,fwg,fww,fgw,rsg,rsw,pb) + + subroutine short_rad_dd(iurb,nz_u,id,albw, & + albg,rsdif,fwg,fww,fgw,fsw,fsg,rsg,rsw,pb) ! ---------------------------------------------------------------------- ! This routine computes the effects of the reflections of short-wave @@ -3138,9 +3573,12 @@ subroutine short_rad(iurb,nz_u,id,albw, & ! ---------------------------------------------------------------------- real albg ! Albedo of the ground for the current urban class real albw ! Albedo of the wall for the current urban class + real rsdif ! diffused short wave radiation real fgw(nz_um,ndm,nurbm) ! View factors from ground to wall real fwg(nz_um,ndm,nurbm) ! View factors from wall to ground real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall + real fsg(ndm,nurbm) ! View factors from sky to ground + real fsw(nz_um,ndm,nurbm) ! View factors from sky to wall integer id ! current street direction integer iurb ! current urban class integer nz_u ! Number of layer in the urban grid @@ -3166,67 +3604,69 @@ subroutine short_rad(iurb,nz_u,id,albw, & ! west wall - do i=1,nz_u + + do i=1,nz_u do j=1,nz_u aaa(i,j)=0. enddo - - aaa(i,i)=1. - + + aaa(i,i)=1. + do j=nz_u+1,2*nz_u aaa(i,j)=-albw*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1) enddo - + aaa(i,2*nz_u+1)=-albg*fgw(i,id,iurb) - bbb(i)=rsw(2*id-1,i) - + bbb(i)=rsw(2*id-1,i)+fsw(i,id,iurb)*rsdif + enddo - + ! east wall - - do i=1+nz_u,2*nz_u + do i=1+nz_u,2*nz_u do j=1,nz_u aaa(i,j)=-albw*fww(j,i-nz_u,id,iurb)*pb(j+1) enddo - + do j=1+nz_u,2*nz_u aaa(i,j)=0. enddo - + aaa(i,i)=1. aaa(i,2*nz_u+1)=-albg*fgw(i-nz_u,id,iurb) - bbb(i)=rsw(2*id,i-nz_u) - + bbb(i)=rsw(2*id,i-nz_u)+fsw(i-nz_u,id,iurb)*rsdif + enddo -! ground +! ground do j=1,nz_u aaa(2*nz_u+1,j)=-albw*fwg(j,id,iurb)*pb(j+1) enddo - + do j=nz_u+1,2*nz_u aaa(2*nz_u+1,j)=-albw*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1) enddo - + aaa(2*nz_u+1,2*nz_u+1)=1. - bbb(2*nz_u+1)=rsg(id) - + bbb(2*nz_u+1)=rsg(id)+fsg(id,iurb)*rsdif + call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1) do i=1,nz_u rsw(2*id-1,i)=bbb(i) enddo - + do i=nz_u+1,2*nz_u - rsw(2*id,i-nz_u)=bbb(i) + rsw(2*id,i-nz_u)=bbb(i) enddo - + rsg(id)=bbb(2*nz_u+1) + return - end subroutine short_rad - + end subroutine short_rad_dd + + ! ===6=8===============================================================72 ! ===6=8===============================================================72 @@ -3308,7 +3748,7 @@ subroutine gaussj(a,n,b,np) endif if(a(icol,icol).eq.0) FATAL_ERROR('singular matrix in gaussj') - + pivinv=1./a(icol,icol) a(icol,icol)=1 @@ -3334,12 +3774,13 @@ subroutine gaussj(a,n,b,np) return end subroutine gaussj - + + + ! ===6=8===============================================================72 ! ===6=8===============================================================72 - - subroutine soil_temp(nz,dz,temp,pt,ala,cs, & - rs,rl,press,dt,em,alb,rt,sf,gf) + + subroutine soil_moist(nz,dz,qv,dt,lf,d,k,rainbl,drain,irri_now) ! ---------------------------------------------------------------------- ! This routine solves the Fourier diffusion equation for heat in @@ -3351,31 +3792,26 @@ subroutine soil_temp(nz,dz,temp,pt,ala,cs, & implicit none - - + + ! ---------------------------------------------------------------------- ! INPUT: ! ---------------------------------------------------------------------- integer nz ! Number of layers - real ala(nz) ! Thermal diffusivity in each layers [m^2 s^-1] - real alb ! Albedo of the surface - real cs(nz) ! Specific heat of the material [J m^3 K^-1] real dt ! Time step - real em ! Emissivity of the surface - real press ! Pressure at ground level - real rl ! Downward flux of the longwave radiation - real rs ! Solar radiation - real sf ! Sensible heat flux at the surface - real temp(nz) ! Temperature in each layer [K] + real lf ! Latent heat flux at the surface + real qv(nz) ! Moisture in each layer [K] real dz(nz) ! Layer sizes [m] - - + real rainbl ! Rainfall [mm] + real d(nz) ! Soil water diffusivity + real k(nz) ! Hydraulic conductivity + real gr ! Dummy variable + real drain + real irri_now ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- - real gf ! Heat flux transferred from the surface toward the interior - real pt ! Potential temperature at the surface - real rt ! Total radiation at the surface (solar+incoming long+outgoing long) + ! ---------------------------------------------------------------------- ! LOCAL: @@ -3385,55 +3821,242 @@ subroutine soil_temp(nz,dz,temp,pt,ala,cs, & real alpha real c(nz) real cddz(nz+2) - real tsig - -! ---------------------------------------------------------------------- + real dw !water density Kg/m3 + parameter(dw=1000.) +!---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- - - tsig=temp(nz) - alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf -! Compute cddz=2*cd/dz - - cddz(1)=ala(1)/dz(1) + + alpha=rainbl/(dw*dt)+lf/latent/dw+irri_now/dw + cddz(1)=0. do iz=2,nz - cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1)) + cddz(iz)=2.*d(iz)/(dz(iz)+dz(iz-1)) enddo -! cddz(nz+1)=ala(nz+1)/dz(nz) - - a(1,1)=0. - a(1,2)=1. - a(1,3)=0. - c(1)=temp(1) - - do iz=2,nz-1 + do iz=1,4 + a(iz,1)=0. + a(iz,2)=1. + a(iz,3)=0. + c(iz)=qv(iz) + enddo + do iz=6,nz-1 a(iz,1)=-cddz(iz)*dt/dz(iz) - a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dz(iz) + a(iz,2)=1.+dt*(cddz(iz)+cddz(iz+1))/dz(iz) a(iz,3)=-cddz(iz+1)*dt/dz(iz) - c(iz)=temp(iz) - enddo - + c(iz)=qv(iz)+dt*(k(iz+1)-k(iz))/dz(iz) + enddo + a(5,1)=0. + a(5,2)=1.+dt*(cddz(5+1))/dz(5) + a(5,3)=-cddz(5+1)*dt/dz(5) + c(5)=qv(5)+dt*(k(5+1)-drain)/dz(5) + + a(nz,1)=-dt*cddz(nz)/dz(nz) a(nz,2)=1.+dt*cddz(nz)/dz(nz) a(nz,3)=0. - c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz) + c(nz)=qv(nz)+dt*alpha/dz(nz)-dt*k(nz-1)/dz(nz) + + call invert(nz,a,c,qv) + + return + end subroutine soil_moist + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine soil_temp_veg(heflro,nz,dz,temp,pt,ala,cs, & + rs,rl,press,dt,em,alb,rt,sf,lf,gf,pv_frac_roof,tpv) + +! ---------------------------------------------------------------------- +! This routine solves the Fourier diffusion equation for heat in +! the material (wall, roof, or ground). Resolution is done implicitely. +! Boundary conditions are: +! - fixed temperature at the interior +! - energy budget at the surface +! ---------------------------------------------------------------------- + + implicit none + + + +! ---------------------------------------------------------------------- +! INPUT: +! ---------------------------------------------------------------------- + integer nz ! Number of layers + real ala(nz) ! Thermal diffusivity in each layers [m^2 s^-1] + real alb ! Albedo of the surface + real cs(nz) ! Specific heat of the material [J m^3 K^-1] + real dt ! Time step + real em ! Emissivity of the surface + real press ! Pressure at ground level + real rl ! Downward flux of the longwave radiation + real rs ! Solar radiation + real sf ! Sensible heat flux at the surface + real lf ! Latent heat flux at the surface + real temp(nz) ! Temperature in each layer [K] + real dz(nz) ! Layer sizes [m] + real heflro ! Heat flux between roof and green roof + real rs_eff + real rl_eff + real tpv + real pv_frac_roof +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- + real gf ! Heat flux transferred from the surface toward the interior + real pt ! Potential temperature at the surface + real rt ! Total radiation at the surface (solar+incoming long+outgoing long) + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + integer iz + real a(nz,3) + real alpha + real c(nz) + real cddz(nz+2) + real tsig + +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS +! ---------------------------------------------------------------------- + if(pv_frac_roof.gt.0)then + rl_eff=(1-pv_frac_roof)*em*rl+em*sigma*tpv**4*pv_frac_roof + rs_eff=(1.-pv_frac_roof)*rs + else + rl_eff=em*rl + rs_eff=rs + endif + tsig=temp(nz) + alpha=(1.-alb)*rs_eff+rl_eff-em*sigma*(tsig**4)+sf+lf + cddz(1)=ala(1)/dz(1) + do iz=2,nz + cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1)) + enddo + + a(1,1)=0. + a(1,2)=1. + a(1,3)=0. + c(1)=temp(1)-heflro*dt/dz(1) + do iz=2,nz-1 + a(iz,1)=-cddz(iz)*dt/dz(iz) + a(iz,2)=1.+dt*(cddz(iz)+cddz(iz+1))/dz(iz) + a(iz,3)=-cddz(iz+1)*dt/dz(iz) + c(iz)=temp(iz) + enddo + a(nz,1)=-dt*cddz(nz)/dz(nz) + a(nz,2)=1.+dt*cddz(nz)/dz(nz) + a(nz,3)=0. + c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz) + + call invert(nz,a,c,temp) + + pt=temp(nz)*(press/1.e+5)**(-rcp_u) + + rt=(1.-alb)*rs_eff+rl_eff-em*sigma*(tsig**4.) + + gf=(1.-alb)*rs_eff+rl_eff-em*sigma*(tsig**4.)+sf + return + end subroutine soil_temp_veg + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine soil_temp(nz,dz,temp,pt,ala,cs, & + rs,rl,press,dt,em,alb,rt,sf,lf,gf) + +! ---------------------------------------------------------------------- +! This routine solves the Fourier diffusion equation for heat in +! the material (wall, roof, or ground). Resolution is done implicitely. +! Boundary conditions are: +! - fixed temperature at the interior +! - energy budget at the surface +! ---------------------------------------------------------------------- + + implicit none + + + +! ---------------------------------------------------------------------- +! INPUT: +! ---------------------------------------------------------------------- + integer nz ! Number of layers + real ala(nz) ! Thermal diffusivity in each layers [m^2 s^-1] + real alb ! Albedo of the surface + real cs(nz) ! Specific heat of the material [J m^3 K^-1] + real dt ! Time step + real em ! Emissivity of the surface + real press ! Pressure at ground level + real rl ! Downward flux of the longwave radiation + real rs ! Solar radiation + real sf ! Sensible heat flux at the surface + real lf ! Latent heat flux at the surface + real temp(nz) ! Temperature in each layer [K] + real dz(nz) ! Layer sizes [m] + +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- + real gf ! Heat flux transferred from the surface toward the interior + real pt ! Potential temperature at the surface + real rt ! Total radiation at the surface (solar+incoming long+outgoing long) + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + integer iz + real a(nz,3) + real alpha + real c(nz) + real cddz(nz+2) + real tsig + +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS +! ---------------------------------------------------------------------- + + tsig=temp(nz) + alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf+lf +! Compute cddz=2*cd/dz + cddz(1)=ala(1)/dz(1) + do iz=2,nz + cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1)) + enddo + + a(1,1)=0. + a(1,2)=1. + a(1,3)=0. + c(1)=temp(1) + do iz=2,nz-1 + a(iz,1)=-cddz(iz)*dt/dz(iz) + a(iz,2)=1.+dt*(cddz(iz)+cddz(iz+1))/dz(iz) + a(iz,3)=-cddz(iz+1)*dt/dz(iz) + c(iz)=temp(iz) + enddo + a(nz,1)=-dt*cddz(nz)/dz(nz) + a(nz,2)=1.+dt*cddz(nz)/dz(nz) + a(nz,3)=0. + c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz) call invert(nz,a,c,temp) - pt=temp(nz)*(press/1.e+5)**(-rcp_u) - rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4) + rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4.) -! gf=-cddz(nz)*(temp(nz)-temp(nz-1))*cs(nz) - gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf + gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4.)+sf return end subroutine soil_temp + ! ===6=8===============================================================72 ! ===6=8===============================================================72 + subroutine invert(n,a,c,x) ! ---------------------------------------------------------------------- @@ -3487,7 +4110,7 @@ end subroutine invert ! ===6=8===============================================================72 subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb, & - sfw,sfwin,evb,drst,dt) + sfw,sfwin,evb,drst,dt,cdrag) ! ---------------------------------------------------------------------- ! This routine computes the surface sources or sinks of momentum, tke, @@ -3505,7 +4128,7 @@ subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb, & real ua ! wind speed real va ! wind speed real dt !time step - + real cdrag ! OUTPUT: ! ------ ! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on @@ -3582,8 +4205,8 @@ end subroutine flux_wall ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & - uhb,vhb,sf,ehb,da) + subroutine flux_flat_ground(dz,z0,ua,va,pt,pt0,ptg, & + uhb,vhb,sf,ehb,da,qv,pr,rsg,qg,resg,rsveg,f1,f2,f3,f4,fh,ric,utot,gr_type) ! ---------------------------------------------------------------------- ! Calculation of the flux at the ground @@ -3600,7 +4223,11 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & real va ! wind speed real z0 ! Roughness length real da ! air density - + real qv ! specific humidity + real pr ! pressure + real rsg ! solar radiation + real qg(ng_u) ! Ground Soil Moisture + ! ---------------------------------------------------------------------- @@ -3617,12 +4244,13 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & real tvb ! Temperature Vertical surfaces, B (explicit) term real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term real sf - + real lf ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- - real aa + real aa,ah + real z0t real al real buu real c @@ -3632,22 +4260,58 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & real fm real ric real tstar + real qstar real ustar real utot real wstar real zz - + real qvsg,qvs,es,esa,fbqq real b,cm,ch,rr,tol parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001) + real f + real f1 + real f2 + real f3 + real f4 + real ta ! surface air temperature + real tmp ! ground temperature + real rsveg ! Stomatal resistance + real resg + real lai ! leaf area index + real sdlim ! radiation limit at which photosyntesis start W/m2 + parameter(sdlim=100.) + real rsmin ! Minimum stomatal resistance + real rsmax ! Maximun stomatal resistance + real qw + parameter(qw=0.06) + real qref + parameter(qref=0.37) + real hs + parameter(hs=36.35) + + real dzg_u(ng_u) ! Layer sizes in the ground + + data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/ + + real gx,dzg_tot + integer gr_type,iz ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- - - + z0t=z0/10. + if(gr_type.eq.1)then + rsmin=40. + rsmax=5000. + lai=2. + elseif(gr_type.eq.2)then + rsmin=150. + rsmax=5000. + lai=3. + endif ! computation of the ground temperature - utot=(ua**2+va**2)**.5 + utot=(ua**2.+va**2.)**.5 !!!! Louis formulation @@ -3669,24 +4333,59 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2)) aa=vk/log(zz/z0) + ah=vk/log(zz/z0t) ! determine the parameters fm and fh for stable, neutral and unstable conditions if(ric.gt.0)then - fm=1/(1+0.5*b*ric)**2 + fm=1/(1+0.5*b*ric)**2. fh=fm else c=b*cm*aa*aa*(zz/z0)**.5 fm=1-b*ric/(1+c*(-ric)**.5) + c=b*cm*aa*ah*(zz/z0t)**.5 c=c*ch/cm fh=1-b*ric/(1+c*(-ric)**.5) endif fbuw=-aa*aa*utot*utot*fm - fbpt=-aa*aa*utot*(pt-ptg)*fh/rr - + fbpt=-aa*ah*utot*(pt-ptg)*fh/rr + tmp=ptg*(pr/p0)**(rcp_u)-273.15 + es=6.11*(10.**(tmp*7.5/(237.7+tmp))) + qvsg=0.62197*es/(0.01*pr-0.378*es) + + + f=0.55*rsg/sdlim*2./lai + + f1=(f+rsmin/rsmax)/(1.+f) + + ta=pt*(pr/p0)**(rcp_u)-273.15 + esa=6.11*(10**(ta*7.5/(237.7+ta))) + qvs=0.62197*esa/(0.01*pr-0.378*esa) + + f2= 1./(1.+hs*(qvs-qv)) + f3=1.-0.0016*(25.-ta)**2. + f4=0. + dzg_tot=0. + do iz=1,ng_u + gx=(qg(iz)-qw)/(qref-qw) + if (gx.gt.1)gx=1. + if (gx.lt.0)gx=0. + f4=f4+gx*dzg_u(iz) + dzg_tot=dzg_tot+dzg_u(iz) + enddo + f4=f4/dzg_tot + + rsveg=min(rsmin/max(lai*f1*f2*f3*f4,1e-9),rsmax) + resg= rr/(aa*aa*utot*fh) + + + fbqq=-(qv-qvsg)/(resg+rsveg) + + ustar=(-fbuw)**.5 tstar=-fbpt/ustar + qstar=-fbqq/ustar al=(vk*g_u*tstar)/(pt*ustar*ustar) @@ -3695,20 +4394,337 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & uhb=-ustar*ustar*ua/utot vhb=-ustar*ustar*va/utot sf= ustar*tstar*da*cp_u + lf= ustar*qstar*da*latent ! thb= 0. ehb=buu !!!!!!!!!!!!!!! return - end subroutine flux_flat + end subroutine flux_flat_ground + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + subroutine flux_flat_roof(dz,z0,ua,va,pt,pt0,ptg, & + uhb,vhb,sf,lf,ehb,da,qv,pr,rsg,qr,resg,rsveg,f1,f2,f3,f4,gr_type,pv_frac_roof) + +! ---------------------------------------------------------------------- +! Calculation of the flux at the ground +! Formulation of Louis (Louis, 1979) +! ---------------------------------------------------------------------- + + implicit none + + real dz ! first vertical level + real pt ! potential temperature + real pt0 ! reference potential temperature + real ptg ! ground potential temperature + real ua ! wind speed + real va ! wind speed + real z0 ! Roughness length + real da ! air density + real qv ! specific humidity + real pr ! pressure + real rsg ! solar radiation + real qr(ngr_u) ! Ground Soil Moisture + real pv_frac_roof + real rs_eff + +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- +! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal +! surfaces (roofs and street) +! The fluxes can be computed as follow: Fluxes of X = B +! Example: Momentum fluxes on horizontal surfaces = uhb_u + real uhb ! U (wind component) Horizontal surfaces, B (explicit) term + real vhb ! V (wind component) Horizontal surfaces, B (explicit) term +! real thb ! Temperature Horizontal surfaces, B (explicit) term + real tva ! Temperature Vertical surfaces, A (implicit) term + real tvb ! Temperature Vertical surfaces, B (explicit) term + real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term + real sf + real lf + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + real aa,ah + real al + real buu + real c + real fbuw + real fbpt + real fh + real fm + real ric + real tstar + real qstar + real ustar + real utot + real wstar + real zz + real z0t + real qvsg,qvs,es,esa,fbqq + real b,cm,ch,rr,tol + parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001) + + real f + real f1 + real f2 + real f3 + real f4 + real ta ! surface air temperature + real tmp ! ground temperature + real rsveg ! Stomatal resistance + real resg + real lai ! leaft area index + real sdlim ! radiation limit at which photosyntesis start W/m2 + parameter(sdlim=100.) + real rsmin + real rsmax ! Maximun stomatal resistance + real qw ! Wilting point + parameter(qw=0.06) + real qref ! Field capacity + parameter(qref=0.37) + real hs + parameter(hs=36.35) + + real dzgr_u(ngr_u) ! Layer sizes in the ground + + data dzgr_u /0.1,0.003,0.06,0.003,0.05,0.04,0.02,0.0125,0.005,0.0025/ + + real gx,dzgr_tot + integer gr_type,iz +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS + +! ---------------------------------------------------------------------- + z0t=z0/10. + if(gr_type.eq.1)then + rsmin=40. + rsmax=5000. + lai=2. + elseif(gr_type.eq.2)then + rsmin=150. + rsmax=5000. + lai=3. + endif + rs_eff=(1-pv_frac_roof)*rsg +! computation of the ground temperature + + utot=(ua**2.+va**2.)**.5 + +!!!! Louis formulation +! +! compute the bulk Richardson Number + + zz=dz/2. + + + utot=max(utot,0.01) + + ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2)) + + aa=vk/log(zz/z0) + ah=vk/log(zz/z0t) + + if(ric.gt.0.)then + fm=1./(1.+0.5*b*ric)**2. + fh=fm + else + c=b*cm*aa*aa*(zz/z0)**.5 + fm=1.-b*ric/(1.+c*(-ric)**.5) + c=b*cm*aa*ah*(zz/z0t)**.5 + c=c*ch/cm + fh=1.-b*ric/(1+c*(-ric)**.5) + endif + + fbuw=-aa*aa*utot*utot*fm + fbpt=-aa*ah*utot*(pt-ptg)*fh/rr + tmp=ptg*(pr/p0)**(rcp_u)-273.15 + es=6.11*(10.**(tmp*7.5/(237.7+tmp))) + qvsg=0.62197*es/(0.01*pr-0.378*es) + + + f=0.55*rs_eff/sdlim*2./lai + + f1=(f+rsmin/rsmax)/(1.+f) + + ta=pt*(pr/p0)**(rcp_u)-273.15 + esa=6.11*(10**(ta*7.5/(237.7+ta))) + qvs=0.62197*esa/(0.01*pr-0.378*esa) + + f2= 1./(1.+hs*(qvs-qv)) + f3=1.-0.0016*(25.-ta)**2. + f4=0. + dzgr_tot=0. + do iz=5,ngr_u + gx=(qr(iz)-qw)/(qref-qw) + if (gx.gt.1)gx=1. + if (gx.lt.0)gx=0. + f4=f4+gx*dzgr_u(iz) + dzgr_tot=dzgr_tot+dzgr_u(iz) + enddo + f4=f4/dzgr_tot + + rsveg=min(rsmin/max(lai*f1*f2*f3*f4,1e-9),rsmax) + + + resg= rr/(aa*aa*utot*fh) + + + fbqq=-(qv-qvsg)/(resg+rsveg) + + ustar=(-fbuw)**.5 + tstar=-fbpt/ustar + qstar=-fbqq/ustar + + al=(vk*g_u*tstar)/(pt*ustar*ustar) + + buu=-g_u/pt0*ustar*tstar + + uhb=-ustar*ustar*ua/utot + vhb=-ustar*ustar*va/utot + sf= ustar*tstar*da*cp_u + lf= ustar*qstar*da*latent + + ehb=buu + end subroutine flux_flat_roof + +!!!!!!!=============================== + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg,qv, & + uhb,vhb,sf,lf,ehb,da,pr) + +! ---------------------------------------------------------------------- +! Calculation of the flux at the ground +! Formulation of Louis (Louis, 1979) +! ---------------------------------------------------------------------- + + implicit none + real pr + real dz ! first vertical level + real pt ! potential temperature + real pt0 ! reference potential temperature + real ptg ! ground potential temperature + real ua ! wind speed + real va ! wind speed + real z0 ! Roughness length + real da ! air density + real qv +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- +! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal +! surfaces (roofs and street) +! The fluxes can be computed as follow: Fluxes of X = B +! Example: Momentum fluxes on horizontal surfaces = uhb_u + real uhb ! U (wind component) Horizontal surfaces, B (explicit) term + real vhb ! V (wind component) Horizontal surfaces, B (explicit) term +! real thb ! Temperature Horizontal surfaces, B (explicit) term + real tva ! Temperature Vertical surfaces, A (implicit) term + real tvb ! Temperature Vertical surfaces, B (explicit) term + real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term + real sf + real lf + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + real aa + real al + real buu + real c + real fbuw + real fbpt + real fh + real fm + real ric + real tstar + real ustar + real qstar + real utot + real wstar + real zz + real qvsg,qvs,es,esa,fbqq,tmp,resg + real b,cm,ch,rr,tol + parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001) + +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS +! ---------------------------------------------------------------------- + + +! computation of the ground temperature + + utot=(ua**2+va**2)**.5 + + +!!!! Louis formulation +! +! compute the bulk Richardson Number + zz=dz/2. + + + utot=max(utot,0.01) + + ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2)) + + aa=vk/log(zz/z0) + + + + tmp=ptg*(pr/(1.e+5))**(rcp_u)-273.15 + es=6.11*(10**(tmp*7.5/(237.7+tmp))) + qvsg=0.62197*es/(0.01*pr-0.378*es) + + + +! determine the parameters fm and fh for stable, neutral and unstable conditions + + if(ric.gt.0.)then + fm=1./(1.+0.5*b*ric)**2 + fh=fm + else + c=b*cm*aa*aa*(zz/z0)**.5 + fm=1.-b*ric/(1.+c*(-ric)**.5) + c=c*ch/cm + fh=1.-b*ric/(1.+c*(-ric)**.5) + endif + + resg= rr/(aa*aa*utot*fh) + fbuw=-aa*aa*utot*utot*fm + fbpt=-aa*aa*utot*(pt-ptg)*fh/rr + fbqq=-(qv-qvsg)/(resg) + + ustar=(-fbuw)**.5 + tstar=-fbpt/ustar + qstar=-fbqq/ustar + al=(vk*g_u*tstar)/(pt*ustar*ustar) + + buu=-g_u/pt0*ustar*tstar + + uhb=-ustar*ustar*ua/utot + vhb=-ustar*ustar*va/utot + sf= ustar*tstar*da*cp_u + lf= ustar*qstar*da*latent + ehb=buu +!!!!!!!!!!!!!!! + + return + end subroutine flux_flat +!!!!!!!!!!!!!================!!!!!!!!!!!!!!!!!!! ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) + subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) - implicit none + implicit none ! Street parameters integer nd_u(nurbm) ! Number of street direction for each urban class @@ -3720,7 +4736,7 @@ subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to z real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to z - + ! Grid parameters integer nz_u(nurbm) ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels @@ -3741,19 +4757,20 @@ subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) ! !Initialize variables ! + ! nz_u=0 z_u=0. ss_u=0. pb_u=0. ! Computation of the urban levels height - + z_u(1)=0. - + do iz_u=1,nz_um-1 z_u(iz_u+1)=z_u(iz_u)+dz_u enddo - + ! Normalisation of the building density do iurb=1,nurbm @@ -3764,33 +4781,33 @@ subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) do ilu=1,nz_um d_b(ilu,iurb)=d_b(ilu,iurb)/dtot enddo - enddo + enddo -! Compute the view factors, pb and ss - - do iurb=1,nurbm +! Compute the view factors, pb and ss + + do iurb=1,nurbm hbmax=0. nz_u(iurb)=0 do ilu=1,nz_um if(h_b(ilu,iurb).gt.hbmax)hbmax=h_b(ilu,iurb) enddo - + do iz_u=1,nz_um-1 if(z_u(iz_u+1).gt.hbmax)go to 10 enddo - + 10 continue - nz_u(iurb)=iz_u+1 + nz_u(iurb)=iz_u+1 do id=1,nd_u(iurb) do iz_u=1,nz_u(iurb) ss_u(iz_u,iurb)=0. do ilu=1,nz_um - if(z_u(iz_u).le.h_b(ilu,iurb) & - .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then + if(z_u(iz_u).le.h_b(ilu,iurb) & + .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then ss_u(iz_u,iurb)=ss_u(iz_u,iurb)+d_b(ilu,iurb) - endif + endif enddo enddo @@ -3801,13 +4818,14 @@ subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) enddo end do - - - return + + + return end subroutine icBEP ! ===6=8===============================================================72 ! ===6=8===============================================================72 + subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws) @@ -3925,7 +4943,7 @@ subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws) enddo ! radiation from wall to sky - do iz=1,nz_u + do iz=1,nz_u call fnrms(fnrm,ws,dxy,hut-z(iz)) f12=fnrm call fnrms(fnrm,ws,dxy,hut-z(iz+1)) @@ -3973,6 +4991,7 @@ end subroutine view_factors ! ===6=8===============================================================72 ! ===6=8===============================================================72 + SUBROUTINE fprls (fprl,a,b,c) implicit none @@ -4034,16 +5053,19 @@ SUBROUTINE fnrms (fnrm,a,b,c) end subroutine fnrms ! ===6=8===============================================================72 - SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& + SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,& emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b, & cop_u,pwin_u,beta_u,sw_cond_u,time_on_u,time_off_u,targtemp_u, & - gaptemp_u, targhum_u,gaphum_u,perflo_u,hsesf_u,hsequip) + bldac_frc_u,cooled_frc_u, & + gaptemp_u, targhum_u,gaphum_u,perflo_u, & + gr_frac_roof_u,pv_frac_roof_u, & + hsesf_u,hsequip,irho,gr_flag_u,gr_type_u) + ! initialization routine, where the variables from the table are read implicit none - integer iurb ! urban class number ! Building parameters real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] @@ -4082,6 +5104,8 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& integer i,iu integer nurb ! number of urban classes used + real, intent(out) :: bldac_frc_u(nurbm) + real, intent(out) :: cooled_frc_u(nurbm) real, intent(out) :: cop_u(nurbm) real, intent(out) :: pwin_u(nurbm) real, intent(out) :: beta_u(nurbm) @@ -4093,9 +5117,12 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& real, intent(out) :: targhum_u(nurbm) real, intent(out) :: gaphum_u(nurbm) real, intent(out) :: perflo_u(nurbm) + real, intent(out) :: gr_frac_roof_u(nurbm) + real, intent(out) :: pv_frac_roof_u(nurbm) real, intent(out) :: hsesf_u(nurbm) real, intent(out) :: hsequip(24) - + real, intent(out) :: irho(24) + integer, intent(out) :: gr_flag_u,gr_type_u ! !Initialize some variables ! @@ -4129,6 +5156,9 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& z0g_u=Z0G_TBL nd_u=NUMDIR_TBL !FS + ! print*, 'g alla call', gr_frac_roof_u(iurb) + bldac_frc_u = bldac_frc_tbl + cooled_frc_u = cooled_frc_tbl cop_u = cop_tbl pwin_u = pwin_tbl beta_u = beta_tbl @@ -4140,9 +5170,13 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& targhum_u = targhum_tbl gaphum_u = gaphum_tbl perflo_u = perflo_tbl + gr_frac_roof_u =gr_frac_roof_tbl + gr_flag_u=gr_flag_tbl + pv_frac_roof_u = pv_frac_roof_tbl hsesf_u = hsesf_tbl hsequip = hsequip_tbl - + irho=irho_tbl + gr_type_u=gr_type_tbl do iu=1,icate if(ndm.lt.nd_u(iu))then write(*,*)'ndm too small in module_sf_bep_bem, please increase to at least ', nd_u(iu) @@ -4185,12 +5219,12 @@ end subroutine init_para !====6=8===============================================================72 !====6=8===============================================================72 - subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & - tg,emg_u,albg_u,rlg,rsg,sfg, & + subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & + tg_av,emg_u,albg_u,rlg,rsg,sfg,lfg, & tw,emw_u,albw_u,rlw,rsw,sfw, & - tr,emr_u,albr_u,emwind,albwind,twlev,pwin, & - sfwind,rld,rs, sfr, & - rs_abs,rl_up,emiss,grdflx_urb) + tr_av,emr_u,albr_u,emwind,albwind,twlev,pwin, & + sfwind,rld,rs, sfr,sfrv,lfr,lfrv, & + rs_abs,rl_up,emiss,grdflx_urb,gr_frac_roof,tpvlev,pv_frac_roof) ! ! IN this surboutine we compute the upward longwave flux, and the albedo ! needed for the radiation scheme @@ -4207,7 +5241,12 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & real rs ! Short wave radiation at the horizontal surface from the sun [W/m2] real sfw(2*ndm,nz_um) ! Sensible heat flux from walls [W/m2] real sfg(ndm) ! Sensible heat flux from ground (road) [W/m2] - real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/m2] + real lfg(ndm) + real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/m2] + real lfr(ndm,nz_um) + real lfrv(ndm,nz_um) + real sfrv(ndm,nz_um) + real gr_frac_roof real rld ! Long wave radiation from the sky [W/m2] real albg_u ! albedo of the ground/street real albw_u ! albedo of the walls @@ -4223,8 +5262,10 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & real emw_u ! emissivity of the wall real emr_u ! emissivity of the roof real tw(2*ndm,nz_um) ! Temperature in each layer of the wall [K] - real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K] - real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real tr_av(ndm,nz_um) ! Temperature in each layer of the roof [K] + real tpvlev(ndm,nz_um) + real pv_frac_roof + real tg_av(ndm) ! Temperature in each layer of the ground [K] integer id ! street direction integer ndu ! number of street directions ! @@ -4251,12 +5292,11 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & iwrong=1 do iz=1,nzu+1 do id=1,ndu - do iw=1,nwr_u - if(tr(id,iz,iw).lt.100.)then - write(*,*)'in upward_rad ',iz,id,iw,tr(id,iz,iw) + if(tr_av(id,iz).lt.100.)then + write(203,*) tr_av(id,iz) + write(*,*)'in upward_rad ',iz,id,iw,tr_av(id,iz) iwrong=0 - endif - enddo + endif enddo enddo if(iwrong.eq.0)stop @@ -4269,18 +5309,20 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & rl_emit=0. grdflx_urb=0. do id=1,ndu - rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/ndu + rl_emit=rl_emit-( emg_u*sigma*(tg_av(id)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/ndu rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/ndu rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/ndu - gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg(id,ng_u)**4.)+sfg(id) + gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg_av(id)**4.)+sfg(id)+lfg(id) grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/ndu - do iz=2,nzu - rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu - rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu - rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu - gfl=(1.-albr_u)*rs+emr_u*rld-emr_u*sigma*(tr(id,iz,nwr_u)**4.)+sfr(id,iz) - grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + do iz=2,nzu + rl_emit=rl_emit-(emr_u*sigma*(1.-pv_frac_roof)*tr_av(id,iz)**4.+0.79*sigma*pv_frac_roof*tpvlev(id,iz)**4+ & + (1-emr_u)*rld*(1.-pv_frac_roof)+(1-0.79)*pv_frac_roof*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + rs_abs=rs_abs+((1.-albr_u)*rs*(1.-pv_frac_roof)+(1.-0.11)*rs*pv_frac_roof)*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + gfl=(1.-albr_u)*rs*(1-pv_frac_roof)+emr_u*rld*(1-pv_frac_roof)+pv_frac_roof*emr_u*sigma*tpvlev(id,iz)**4 & + -emr_u*sigma*(tr_av(id,iz)**4.)+(1-gr_frac_roof)*sfr(id,iz)+(sfrv(id,iz)+lfrv(id,iz))*gr_frac_roof+(1.-gr_frac_roof)*lfr(id,iz) + grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu enddo do iz=1,nzu @@ -4591,9 +5633,78 @@ subroutine icBEPHI_XY(iurb,hb_u,hi_urb1D,ss_u,pb_u,nzu,z_u) pb_u(iz_u+1)=max(0.,pb_u(iz_u)-ss_u(iz_u,iurb)) enddo -20 continue - return - end subroutine icBEPHI_XY +20 continue + return + end subroutine icBEPHI_XY !====================================================================72 !====================================================================72 END MODULE module_sf_bep_bem + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + FUNCTION bep_bem_nurbm () RESULT (bep_bem_val_nurbm) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nurbm + bep_bem_val_nurbm = nurbm + END FUNCTION bep_bem_nurbm + + FUNCTION bep_bem_ndm () RESULT (bep_bem_val_ndm) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ndm + bep_bem_val_ndm = ndm + END FUNCTION bep_bem_ndm + + FUNCTION bep_bem_nz_um () RESULT (bep_bem_val_nz_um) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nz_um + bep_bem_val_nz_um = nz_um + END FUNCTION bep_bem_nz_um + + FUNCTION bep_bem_ng_u () RESULT (bep_bem_val_ng_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ng_u + bep_bem_val_ng_u = ng_u + END FUNCTION bep_bem_ng_u + + FUNCTION bep_bem_nwr_u () RESULT (bep_bem_val_nwr_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nwr_u + bep_bem_val_nwr_u = nwr_u + END FUNCTION bep_bem_nwr_u + + FUNCTION bep_bem_nf_u () RESULT (bep_bem_val_nf_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nf_u + bep_bem_val_nf_u = nf_u + END FUNCTION bep_bem_nf_u + + + FUNCTION bep_bem_ngb_u () RESULT (bep_bem_val_ngb_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ngb_u + bep_bem_val_ngb_u = ngb_u + END FUNCTION bep_bem_ngb_u + + FUNCTION bep_bem_nbui_max () RESULT (bep_bem_val_nbui_max) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nbui_max + bep_bem_val_nbui_max = nbui_max + END FUNCTION bep_bem_nbui_max + + + FUNCTION bep_bem_ngr_u () RESULT (bep_bem_val_ngr_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ngr_u + bep_bem_val_ngr_u = ngr_u + END FUNCTION bep_bem_ngr_u + diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F index 4075501d7e..9e3a048b79 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F @@ -1,12 +1,16 @@ +!================================================================================================================= MODULE module_sf_noah_seaice + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) use mpas_atmphys_constants,only: cp,R_D=>R_d,XLF,XLV,RHOWATER=>rho_w,STBOLT use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) #else use module_model_constants, only : CP, R_D, XLF, XLV, RHOWATER, STBOLT use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#define FATAL_ERROR(M) call wrf_error_fatal(M) #endif use module_sf_noahlsm, only : RD, SIGMA, CPH2O, CPICE, LSUBF, EMISSI_S, & & HSTEP diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F index b7c34ffb7e..68313b682e 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F @@ -1,12 +1,16 @@ +!================================================================================================================= module module_sf_noah_seaice_drv + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) use mpas_atmphys_utilities, only: physics_message,physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) -#define WRITE_MESSAGE(M) call physics_message( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M ) -#define WRITE_MESSAGE(M) call wrf_message( M ) +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif use module_sf_noah_seaice implicit none @@ -77,7 +81,8 @@ subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNE & RAINBL, & & SNOALB2D, & & XICE, & - & RIB + & RIB, & + & CHS LOGICAL, INTENT (IN) :: FRPCPN REAL , INTENT (IN) :: DT @@ -96,25 +101,29 @@ subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNE & TSK, & & SNOWC, & & SNOWH2D, & - & CHS, & - & CQS2 +! & CHS, & + & CQS2, & + ACSNOW, & + ACSNOM, & + SFCRUNOFF + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(INOUT) :: POTEVP, & + SNOPCX REAL, DIMENSION( ims:ime, jms:jme ) , & & INTENT (OUT) :: HFX, & & LH, & & QFX, & & ZNT, & - & POTEVP, & & GRDFLX, & & QSFC, & - & ACSNOW, & - & ACSNOM, & - & SNOPCX, & - & SFCRUNOFF, & - & NOAHRES, & & CHS2 - REAL, DIMENSION( ims:ime, jms:jme ) ,& + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT (OUT) :: NOAHRES + + REAL, DIMENSION( ims:ime, jms:jme ) , & & INTENT(INOUT) :: SNOWSI REAL, DIMENSION( ims:ime, jms:jme ) , & @@ -442,7 +451,6 @@ subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNE LH(I,J) = ETA HFX(I,J) = SHEAT QFX(I,J) = ETA_KINEMATIC - POTEVP(I,J) = POTEVP(I,J) + ETP*FDTW GRDFLX(I,J) = SSOIL ! Exchange Coefficients @@ -458,6 +466,11 @@ subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNE SNOWSI(I,J) = SNOWONSI ENDIF + ! Accumulated potential evaporation. + IF ( PRESENT(POTEVP) ) THEN + POTEVP(I,J) = POTEVP(I,J) + ETP*FDTW + ENDIF + ! Accumulated snow precipitation. IF ( FFROZP .GT. 0.5 ) THEN ACSNOW(I,J) = ACSNOW(I,J) + PRCP * DT @@ -467,7 +480,9 @@ subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNE ACSNOM(I,J) = ACSNOM(I,J) + SNOMLT * 1000. ! Accumulated snow-melt energy. - SNOPCX(I,J) = SNOPCX(I,J) - SNOMLT/FDTLIW + IF ( PRESENT(SNOPCX) ) THEN + SNOPCX(I,J) = SNOPCX(I,J) - SNOMLT/FDTLIW + ENDIF ! Surface runoff SFCRUNOFF(I,J) = SFCRUNOFF(I,J) + RUNOFF1 * DT * 1000.0 @@ -475,10 +490,12 @@ subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNE ! ! Residual of surface energy balance terms ! - NOAHRES(I,J) = ( SOLNET + LWDN ) & - & - SHEAT + SSOIL - ETA & - & - ( EMISSI * STBOLT * (T1**4) ) & - & - FLX1 - FLX2 - FLX3 + IF ( PRESENT(NOAHRES) ) THEN + NOAHRES(I,J) = ( SOLNET + LWDN ) & + - SHEAT + SSOIL - ETA & + - ( EMISSI * STBOLT * (T1**4) ) & + - FLX1 - FLX2 - FLX3 + ENDIF #if defined(wrfmodel) #if (NMM_CORE != 1) IF ( ( SF_URBAN_PHYSICS == NOAHUCMSCHEME ) .OR. & diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F index 24ec87ea97..ab29ea29b8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F @@ -1,5 +1,9 @@ +!================================================================================================================= MODULE module_sf_noahdrv +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. + !------------------------------- USE module_sf_noahlsm, only: SFLX, XLF, XLV, CP, R_D, RHOWATER, NATURAL, SHDTBL, LUTYPE, SLTYPE, STBOLT, & & KARMAN, LUCATS, NROTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, MAXALB, LAIMINTBL, & @@ -10,8 +14,7 @@ MODULE module_sf_noahdrv & SALP_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, CZIL_DATA, & & SMLOW_DATA, SMHIGH_DATA, LVCOEF_DATA, NSLOPE, & & FRH2O,ZTOPVTBL,ZBOTVTBL, & - & LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL - + & LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 USE module_sf_urban, only: urban, oasis, IRI_SCHEME USE module_sf_noahlsm_glacial_only, only: sflx_glacial USE module_sf_bep, only: bep @@ -37,7 +40,8 @@ MODULE module_sf_noahdrv ! Urban related variable are added to arguments - urban !---------------------------------------------------------------- SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & - HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, & + HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,SWDDIR,SWDDIF,& + GLW,SMSTAV,SMSTOT, & SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA, & ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK, & SNOWC,QSFC,RAINBL,MMINLU, & @@ -83,7 +87,17 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban julian, julyr, & !H urban FRC_URB2D,UTYPE_URB2D, & !O - num_urban_layers, & !I multi-layer urban + num_urban_ndm, & !I multi-layer urban + urban_map_zrd, & !I multi-layer urban + urban_map_zwd, & !I multi-layer urban + urban_map_gd, & !I multi-layer urban + urban_map_zd, & !I multi-layer urban + urban_map_zdf, & !I multi-layer urban + urban_map_bd, & !I multi-layer urban + urban_map_wd, & !I multi-layer urban + urban_map_gbd, & !I multi-layer urban + urban_map_fbd, & !I multi-layer urban + urban_map_zgrd, & !I multi-layer urban num_urban_hi, & !I multi-layer urban tsk_rural_bep, & !H multi-layer urban trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban @@ -94,6 +108,10 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban + ep_pv_urb3d,t_pv_urb3d, & !RMS + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS + drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS + lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !RMS lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban mh_urb2d,stdh_urb2d,lf_urb2d, & !SLUCM th_phy,rho,p_phy,ust, & !I multi-layer urban @@ -101,10 +119,14 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban - dl_u_bep,sf_bep,vl_bep,sfcheadrt,INFXSRT, soldrain & !O multi-layer urban + dl_u_bep,sf_bep,vl_bep & +#ifdef WRF_HYDRO + ,sfcheadrt,INFXSRT,soldrain & !O multi-layer urban +#endif ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas - ,RC2,XLAI2 & - ) + ,RC2,XLAI2 & + ,IRR_CHAN & + ) !---------------------------------------------------------------- IMPLICIT NONE @@ -254,12 +276,15 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & INTEGER, INTENT(IN ) :: julian, julyr !urban !added by Wei Yu for routing +#ifdef WRF_HYDRO REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain real :: etpnd1 +#endif !end added - +! new local vars for hydro + REAL :: etpnd1_hydro,sfcheadrt_hydro,infxsrt_hydro REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(IN ) :: TMN, & @@ -274,7 +299,9 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & GLW, & RAINBL, & EMBCK, & - SR + SR, & + SWDDIR, & + SWDDIF REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ALBBCK, & @@ -576,30 +603,55 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, OPTIONAL, INTENT(IN ) :: GMT INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG - INTEGER, INTENT(IN ) :: NUM_URBAN_LAYERS + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: urban_map_zgrd INTEGER, INTENT(IN ) :: NUM_URBAN_HI REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural_bep - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d @@ -658,6 +710,9 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: DZQ REAL :: HCPCT_FASDAS + REAL,OPTIONAL,INTENT(IN),DIMENSION( ims:ime, jms:jme ) :: IRR_CHAN + REAL :: IRRIGATION_CHANNEL + IRRIGATION_CHANNEL =0.0 HFX_PHY = 0.0 ! initialize QFX_PHY = 0.0 XQNORM = 0.0 @@ -775,6 +830,13 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! use mid-day albedo to determine net downward solar (no solar zenith angle correction) SOLNET=SOLDN*(1.-ALBEDO(I,J)) PRCP=RAINBL(i,j)/DT + IF(PRESENT(IRR_CHAN)) THEN + IF(IRR_CHAN(i,j).NE.0) THEN + IRRIGATION_CHANNEL=IRR_CHAN(i,j)/DT + ELSE + IRRIGATION_CHANNEL=0. + END IF + ENDIF VEGTYP=IVGTYP(I,J) SOILTYP=ISLTYP(I,J) SHDFAC=VEGFRA(I,J)/100. @@ -896,15 +958,20 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as ! the "NATURAL" category in the VEGPARM.TBL + IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN - IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN VEGTYP = NATURAL SHDFAC = SHDTBL(NATURAL) ALBEDOK =0.2 ! 0.2 ALBBRD =0.2 !0.2 EMISSI = 0.98 !for VEGTYP=5 + LWDN = GLW(I,J) * EMISSI + SOLNET = SOLDN * (1.0 - ALBEDOK) + IF ( FRC_URB2D(I,J) < 0.99 ) THEN if(sf_urban_physics.eq.1)then T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) @@ -916,10 +983,13 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ENDIF ELSE - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN VEGTYP = ISURBAN - ENDIF + ENDIF + ENDIF !===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== @@ -933,9 +1003,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & if (tloc.lt.0) tloc=tloc+24 if (tloc==0) tloc=24 CALL cal_mon_day(julian,julyr,jmonth,jday) - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN - AOASIS = oasis ! urban oasis effect + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + AOASIS = oasis ! urban oasis effect IF (IRIOPTION ==1) THEN IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN @@ -1018,6 +1090,15 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! ! END FASDAS ! +#ifdef WRF_HYDRO + etpnd1_hydro = 0. + sfcheadrt_hydro = sfcheadrt(i,j) + infxsrt_hydro = infxsrt(i,j) +#else + etpnd1_hydro = 0. + sfcheadrt_hydro = 0. + infxsrt_hydro = 0. +#endif CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C LOCAL, & !L LUTYPE, SLTYPE, & !CL @@ -1040,14 +1121,18 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & SNOTIME1, & RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & - sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O +! WRF_HYDRO vars + sfcheadrt_hydro, & !I + INFXSRT_hydro,ETPND1_hydro & !O + ,OPT_THCND,AOASIS & !O ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas - ) - + ,IRRIGATION_CHANNEL) #ifdef WRF_HYDRO soldrain(i,j) = RUNOFF2*DT*1000.0 + sfcheadrt(i,j) = sfcheadrt_hydro + infxsrt(i,j) = INFXSRT_hydro + etpnd1 = etpnd1_hydro #endif ELSEIF (ICE == -1) THEN @@ -1232,9 +1317,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & !-------------------------------------- ! Input variables lsm --> urban + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL ) THEN ! Call urban @@ -1251,7 +1338,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & SSGD_URB = 0.8*SOLDN ! [W/m/m] SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] LLG_URB = GLW(I,J) ! [W/m/m] - RAIN_URB = RAINBL(I,J) ! [mm] + RAIN_URB = RAINBL(I,J) / DT * 3600.0 ! [mm/hr] RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] ZA_URB = ZLVL ! [m] DELT_URB = DT ! [sec] @@ -1520,7 +1607,9 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & CALL BEP(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, & th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers,num_urban_hi, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & @@ -1553,13 +1642,20 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & CALL BEP_BEM(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, & th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers,num_urban_hi, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, urban_map_zgrd, num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, & tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, & sfwin1_urb3d,sfwin2_urb3d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + ep_pv_urb3d,t_pv_urb3d, & !RMS + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS + drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS + lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d, & !RMS + rainbl,swddir,swddif, & !RMS lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & a_u_bep,a_v_bep,a_t_bep, & a_e_bep,b_u_bep,b_v_bep, & @@ -1620,7 +1716,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j) ! using the emissivity and the total longwave upward radiation estimate the averaged skin temperature IF (FRC_URB2D(I,J).GT.0.) THEN - rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emissi)*glw(i,j) + rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j) rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j) emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j) ts_urb2d(i,j)=(max(0.,(-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb))**0.25 @@ -1666,19 +1762,9 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & G_URB2D(I,J) = 0. RN_URB2D(I,J) = 0. endif -! IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & -! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN -! print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j) -! print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j) -! print*,'lh,lh_rural',lh(i,j),lh_rural(i,j) -! print*,'qfx',qfx(i,j) -! print*,'ts_urb2d',ts_urb2d(i,j) -! print*,'ust',ust(i,j) -! endif enddo enddo - endif !Bep end !------------------------------------------------------ @@ -1698,9 +1784,11 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB, & num_soil_layers, restart, & allowed_to_read , & + irr_rand_field,irr_ph,irr_freq, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte & + ) INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1747,7 +1835,10 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & GRAV = 9.81, T0 = 273.15 INTEGER :: errflag CHARACTER(LEN=80) :: err_message - + INTEGER,DIMENSION(ims:ime, jms:jme ),INTENT(INOUT):: irr_rand_field + INTEGER , DIMENSION(jds:jde) :: my_seeds + INTEGER :: irr_ph,irr_freq + REAL,DIMENSION(ims:ime, jms:jme ) :: rand_tmp character*256 :: MMINSL MMINSL='STAS' ! @@ -1773,6 +1864,22 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & IF(.not.restart)THEN +#if ( EM_CORE==1 ) + IF (irr_ph.NE.0)THEN + DO i = its,ite + DO j=jts,jte + my_seeds(j) =sqrt(ide*(real(j-1)**2))+sqrt(real(jde*i)) +! PRINT*,'myseed', my_seeds(j),j,jts,jds + END DO + CALL RANDOM_SEED ( PUT = my_seeds ) + CALL RANDOM_NUMBER ( rand_tmp(i,:) ) + CALL RANDOM_SEED ( GET = my_seeds ) + CALL RANDOM_NUMBER ( rand_tmp(i,:) ) + irr_rand_field(i,:)=int(modulo(rand_tmp(i,:)*100,real(irr_freq))) + END DO + END IF +#endif + itf=min0(ite,ide-1) jtf=min0(jte,jde-1) @@ -2008,14 +2115,29 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN CALL wrf_message ("Expected low and high density residential, and high density industrial information in VEGPARM.TBL") CALL wrf_error_fatal ("This could be caused by using an older VEGPARM.TBL file with a newer WRF source code.") - ENDIF - READ (19,*)LOW_DENSITY_RESIDENTIAL + ENDIF + READ (19,*)LCZ_1 + READ (19,*) + READ (19,*)LCZ_2 + READ (19,*) + READ (19,*)LCZ_3 + READ (19,*) + READ (19,*)LCZ_4 + READ (19,*) + READ (19,*)LCZ_5 + READ (19,*) + READ (19,*)LCZ_6 READ (19,*) - READ (19,*)HIGH_DENSITY_RESIDENTIAL + READ (19,*)LCZ_7 READ (19,*) - READ (19,*)HIGH_INTENSITY_INDUSTRIAL + READ (19,*)LCZ_8 + READ (19,*) + READ (19,*)LCZ_9 + READ (19,*) + READ (19,*)LCZ_10 + READ (19,*) + READ (19,*)LCZ_11 ENDIF -! 2002 CONTINUE CLOSE (19) @@ -2051,9 +2173,17 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) CALL wrf_dm_bcast_integer ( BARE , 1 ) CALL wrf_dm_bcast_integer ( NATURAL , 1 ) - CALL wrf_dm_bcast_integer ( LOW_DENSITY_RESIDENTIAL , 1 ) - CALL wrf_dm_bcast_integer ( HIGH_DENSITY_RESIDENTIAL , 1 ) - CALL wrf_dm_bcast_integer ( HIGH_INTENSITY_INDUSTRIAL , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_1 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_2 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_3 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_4 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_5 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_6 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_7 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_8 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_9 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_10 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_11 , 1 ) ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL @@ -2276,8 +2406,19 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban FRC_URB2D,UTYPE_URB2D, & !O - num_urban_layers, & !I multi-layer urban + num_urban_ndm, & !I multi-layer urban + urban_map_zrd, & !I multi-layer urban + urban_map_zwd, & !I multi-layer urban + urban_map_gd, & !I multi-layer urban + urban_map_zd, & !I multi-layer urban + urban_map_zdf, & !I multi-layer urban + urban_map_bd, & !I multi-layer urban + urban_map_wd, & !I multi-layer urban + urban_map_gbd, & !I multi-layer urban + urban_map_fbd, & !I multi-layer urban + urban_map_zgrd, & !I multi-layer urban num_urban_hi, & !I multi-layer urban + use_wudapt_lcz, & !I wudapt tsk_rural_bep, & !H multi-layer urban trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban tlev_urb3d,qlev_urb3d, & !H multi-layer urban @@ -2287,6 +2428,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban + ep_pv_urb3d,t_pv_urb3d, & !RMS + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS + drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS + lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !RMS lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban mh_urb2d,stdh_urb2d,lf_urb2d, & !SLUCM th_phy,rho,p_phy,ust, & !I multi-layer urban @@ -2295,9 +2440,12 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban dl_u_bep,sf_bep,vl_bep & !O multi-layer urban +#ifdef WRF_HYDRO ,sfcheadrt,INFXSRT, soldrain & !hydro +#endif ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas ,RC2,XLAI2 & !O + ,IRR_CHAN & ) !---------------------------------------------------------------- @@ -2446,11 +2594,16 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & INTEGER, INTENT(IN ) :: julian,julyr !added by Wei Yu for routing +#ifdef WRF_HYDRO REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain real :: etpnd1 +#endif !end added +! new local vars for hydro + REAL :: etpnd1_hydro,sfcheadrt_hydro,infxsrt_hydro + REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(IN ) :: TMN, & XLAND, & @@ -2464,7 +2617,6 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & GLW, & RAINBL, & SR - REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ALBBCK, & Z0, & @@ -2767,30 +2919,55 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, OPTIONAL, INTENT(IN ) :: GMT INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG - INTEGER, INTENT(IN ) :: NUM_URBAN_LAYERS + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: urban_map_zgrd INTEGER, INTENT(IN ) :: NUM_URBAN_HI + INTEGER, INTENT(IN ) :: use_wudapt_lcz REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural_bep - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d @@ -2889,7 +3066,9 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: HFX_PHY, QFX_PHY REAL :: DZQ REAL :: HCPCT_FASDAS - + REAL,OPTIONAL,DIMENSION( ims:ime, jms:jme ) :: IRR_CHAN + REAL :: IRRIGATION_CHANNEL + IRRIGATION_CHANNEL=0.0 HFX_PHY = 0.0 ! initialize QFX_PHY = 0.0 XQNORM = 0.0 @@ -3088,6 +3267,13 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! use mid-day albedo to determine net downward solar (no solar zenith angle correction) SOLNET=SOLDN*(1.-ALBEDO(I,J)) PRCP=RAINBL(i,j)/DT + IF(PRESENT(IRR_CHAN)) THEN + IF(IRR_CHAN(i,j).NE.0) THEN + IRRIGATION_CHANNEL=IRR_CHAN(i,j)/DT + ELSE + IRRIGATION_CHANNEL=0. + END IF + ENDIF VEGTYP=IVGTYP(I,J) SOILTYP=ISLTYP(I,J) SHDFAC=VEGFRA(I,J)/100. @@ -3204,10 +3390,9 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as ! the "NATURAL" category in the VEGPARM.TBL - - ! IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - - + + ! IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN + ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN ! VEGTYP = NATURAL @@ -3238,9 +3423,11 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & Noah_call=.TRUE. If ( SF_URBAN_PHYSICS == 0 ) THEN ! ONLY NOAH - - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + Noah_call = .TRUE. VEGTYP = ISURBAN ENDIF @@ -3249,16 +3436,19 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & IF(SF_URBAN_PHYSICS == 1) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN - + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN Noah_call = .TRUE. VEGTYP = NATURAL SHDFAC = SHDTBL(NATURAL) ALBEDOK =0.2 ! 0.2 ALBBRD =0.2 ! 0.2 EMISSI = 0.98 ! for VEGTYP=5 - + LWDN = GLW(I,J) * EMISSI + SOLNET = SOLDN * (1.0 - ALBEDOK) + T1= TS_RUL2D_mosaic(I,mosaic_i,J) ENDIF @@ -3276,9 +3466,12 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & if (tloc==0) tloc=24 CALL cal_mon_day(julian,julyr,jmonth,jday) IF(SF_URBAN_PHYSICS == 1) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN - AOASIS = oasis ! urban oasis effect + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + AOASIS = oasis ! urban oasis effect IF (IRIOPTION ==1) THEN IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN @@ -3372,13 +3565,18 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & SNOTIME1, & RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & - sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O - ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars - ) +! WRF_HYDRO vars + sfcheadrt_hydro, & !I + INFXSRT_hydro,ETPND1_hydro & !O + ,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars + ,IRRIGATION_CHANNEL ) #ifdef WRF_HYDRO soldrain(i,j) = RUNOFF2*DT*1000.0 + sfcheadrt(i,j) = sfcheadrt_hydro + infxsrt(i,j) = INFXSRT_hydro + etpnd1 = etpnd1_hydro #endif ELSEIF (ICE == -1) THEN @@ -3519,22 +3717,50 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! URBAN CANOPY MODEL START - urban !-------------------------------------- ! Input variables lsm --> urban - - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL ) THEN - + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + ! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) ! this need to be changed in the mosaic danli - - IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=2 - IF(IVGTYP(I,J)==LOW_DENSITY_RESIDENTIAL) UTYPE_URB=1 - IF(IVGTYP(I,J)==HIGH_DENSITY_RESIDENTIAL) UTYPE_URB=2 - IF(IVGTYP(I,J)==HIGH_INTENSITY_INDUSTRIAL) UTYPE_URB=3 - - IF(UTYPE_URB==1) FRC_URB2D(I,J)=0.5 - IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.9 - IF(UTYPE_URB==3) FRC_URB2D(I,J)=0.95 - + IF (use_wudapt_lcz == 1) THEN + IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=5 + IF(IVGTYP(I,J)==LCZ_1) UTYPE_URB=1 + IF(IVGTYP(I,J)==LCZ_2) UTYPE_URB=2 + IF(IVGTYP(I,J)==LCZ_3) UTYPE_URB=3 + IF(IVGTYP(I,J)==LCZ_4) UTYPE_URB=4 + IF(IVGTYP(I,J)==LCZ_5) UTYPE_URB=5 + IF(IVGTYP(I,J)==LCZ_6) UTYPE_URB=6 + IF(IVGTYP(I,J)==LCZ_7) UTYPE_URB=7 + IF(IVGTYP(I,J)==LCZ_8) UTYPE_URB=8 + IF(IVGTYP(I,J)==LCZ_9) UTYPE_URB=9 + IF(IVGTYP(I,J)==LCZ_10) UTYPE_URB=10 + IF(IVGTYP(I,J)==LCZ_11) UTYPE_URB=11 + + + IF(UTYPE_URB==1) FRC_URB2D(I,J)=1. + IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.99 + IF(UTYPE_URB==3) FRC_URB2D(I,J)=1.00 + IF(UTYPE_URB==4) FRC_URB2D(I,J)=0.65 + IF(UTYPE_URB==5) FRC_URB2D(I,J)=0.7 + IF(UTYPE_URB==6) FRC_URB2D(I,J)=0.65 + IF(UTYPE_URB==7) FRC_URB2D(I,J)=0.3 + IF(UTYPE_URB==8) FRC_URB2D(I,J)=0.85 + IF(UTYPE_URB==9) FRC_URB2D(I,J)=0.3 + IF(UTYPE_URB==10) FRC_URB2D(I,J)=0.55 + IF(UTYPE_URB==11) FRC_URB2D(I,J)=1. + ELSE + IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=2 + IF(IVGTYP(I,J)==LCZ_1) UTYPE_URB=1 ! LOW_DENSITY_RESIDENTIAL + IF(IVGTYP(I,J)==LCZ_2) UTYPE_URB=2 ! HIGH_DENSITY_RESIDENTIAL + IF(IVGTYP(I,J)==LCZ_3) UTYPE_URB=3 ! HIGH_INTENSITY_INDUSTRIAL + + IF(UTYPE_URB==1) FRC_URB2D(I,J)=0.5 + IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.9 + IF(UTYPE_URB==3) FRC_URB2D(I,J)=0.95 + END IF + TA_URB = SFCTMP ! [K] QA_URB = Q2K ! [kg/kg] UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.) @@ -3545,7 +3771,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & SSGD_URB = 0.8*SOLDN ! [W/m/m] SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] LLG_URB = GLW(I,J) ! [W/m/m] - RAIN_URB = RAINBL(I,J) ! [mm] + RAIN_URB = RAINBL(I,J) / DT * 3600.0 ! [mm/hr] RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] ZA_URB = ZLVL ! [m] DELT_URB = DT ! [sec] @@ -4126,18 +4352,24 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & SNOWHK= 5.*SNEQV endif ! - + !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as ! the "NATURAL" category in the VEGPARM.TBL - - IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN + + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + VEGTYP = NATURAL SHDFAC = SHDTBL(NATURAL) ALBEDOK =0.2 ! 0.2 ALBBRD =0.2 !0.2 EMISSI = 0.98 !for VEGTYP=5 + LWDN = GLW(I,J) * EMISSI + SOLNET = SOLDN * (1.0 - ALBEDOK) + IF ( FRC_URB2D(I,J) < 0.99 ) THEN if(sf_urban_physics.eq.1)then T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) @@ -4149,8 +4381,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ENDIF ELSE - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN VEGTYP = ISURBAN ENDIF ENDIF @@ -4167,9 +4401,12 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & if (tloc==0) tloc=24 CALL cal_mon_day(julian,julyr,jmonth,jday) IF(SF_URBAN_PHYSICS == 1) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN - AOASIS = oasis ! urban oasis effect + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + AOASIS = oasis ! urban oasis effect IF (IRIOPTION ==1) THEN IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN @@ -4257,13 +4494,18 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & SNOTIME1, & RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & - sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O - ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars - ) +! WRF_HYDRO vars + sfcheadrt_hydro, & !I + INFXSRT_hydro,ETPND1_hydro & !O + ,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars + ,IRRIGATION_CHANNEL ) #ifdef WRF_HYDRO soldrain(i,j) = RUNOFF2*DT*1000.0 + sfcheadrt(i,j) = sfcheadrt_hydro + infxsrt(i,j) = INFXSRT_hydro + etpnd1 = etpnd1_hydro #endif ELSEIF (ICE == -1) THEN @@ -4403,10 +4645,11 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! URBAN CANOPY MODEL START - urban !-------------------------------------- ! Input variables lsm --> urban - - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & - IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN - + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + ! Call urban ! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) @@ -4421,7 +4664,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & SSGD_URB = 0.8*SOLDN ! [W/m/m] SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] LLG_URB = GLW(I,J) ! [W/m/m] - RAIN_URB = RAINBL(I,J) ! [mm] + RAIN_URB = RAINBL(I,J) / DT * 3600.0 ! [mm/hr] RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] ZA_URB = ZLVL ! [m] DELT_URB = DT ! [sec] diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index 5350a8e2c4..003c94eff8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -1,12 +1,16 @@ +!================================================================================================================= MODULE module_sf_noahlsm + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) use mpas_atmphys_constants,only: CP=>cp,R_D=>R_d,XLF=>xlf,XLV=>xlv,RHOWATER=>rho_w,STBOLT=>stbolt,KARMAN=>karman use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) #else USE module_model_constants, only : CP, R_D, XLF, XLV, RHOWATER, STBOLT, KARMAN use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#define FATAL_ERROR(M) call wrf_error_fatal(M) #endif !ckay=KIRAN ALAPATY @ US EPA -- November 01, 2015 @@ -29,7 +33,7 @@ MODULE module_sf_noahlsm ! VEGETATION PARAMETERS INTEGER :: LUCATS , BARE INTEGER :: NATURAL - INTEGER :: LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL + INTEGER :: LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 integer, PARAMETER :: NLUS=50 CHARACTER(LEN=256) LUTYPE INTEGER, DIMENSION(1:NLUS) :: NROTBL @@ -96,7 +100,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C SFHEAD1RT, & !I INFXS1RT,ETPND1,OPT_THCND,AOASIS & !P ,XSDA_QFX,HFX_PHY,QFX_PHY,XQNORM & !fasdas - ,fasdas,HCPCT_FASDAS ) !fasdas + ,fasdas,HCPCT_FASDAS,IRRIGATION_CHANNEL ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007 @@ -322,7 +326,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C REAL, INTENT(IN) :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN, & Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB, & - SOLDN,SOLNET,TBOT,TH2,ZLVL, & + SOLDN,SOLNET,TBOT,TH2,ZLVL, & FFROZP,AOASIS REAL, INTENT(OUT) :: EMBRD REAL, INTENT(OUT) :: ALBEDO @@ -385,6 +389,9 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ! END FASDAS ! +! IRRIGATION + REAL, OPTIONAL, INTENT(INOUT) :: IRRIGATION_CHANNEL + ! ---------------------------------------------------------------------- ! INITIALIZATION ! ---------------------------------------------------------------------- @@ -769,7 +776,8 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C QUARTZ,FXEXP,CSOIL, & BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & - ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS ) !fasdas + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS,IRRIGATION_CHANNEL ) !fasdas + ETA_KINEMATIC = ETA ELSE CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & @@ -1908,7 +1916,8 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & QUARTZ,FXEXP,CSOIL, & BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & - ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS ) !fasdas + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS & + ,IRRIGATION_CHANNEL ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE NOPAC @@ -1949,6 +1958,7 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & REAL , DIMENSION(1:NSOIL) :: EFT(NSOIL), wetty(1:NSOIL) REAL :: EFDIR, EFC, EALL_now REAL, INTENT( OUT) :: HCPCT_FASDAS + REAL, INTENT(IN),OPTIONAL :: IRRIGATION_CHANNEL ! ! END FASDAS ! @@ -2044,7 +2054,7 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & SHDFAC,CMCMAX, & RUNOFF1,RUNOFF2,RUNOFF3, & EDIR1,EC1,ET1, & - DRIP, SFHEAD1RT,INFXS1RT) + DRIP, SFHEAD1RT,INFXS1RT,IRRIGATION_CHANNEL) ! ---------------------------------------------------------------------- ! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1. @@ -2107,7 +2117,7 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & SHDFAC,CMCMAX, & RUNOFF1,RUNOFF2,RUNOFF3, & EDIR1,EC1,ET1, & - DRIP, SFHEAD1RT,INFXS1RT) + DRIP, SFHEAD1RT,INFXS1RT,IRRIGATION_CHANNEL) ! ---------------------------------------------------------------------- ! CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'. @@ -2666,7 +2676,8 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & & SHDFAC,CMCMAX, & & RUNOFF1,RUNOFF2,RUNOFF3, & & EDIR,EC,ET, & - & DRIP, SFHEAD1RT,INFXS1RT) + & DRIP, SFHEAD1RT,INFXS1RT, & + IRRIGATION_CHANNEL ) ! ---------------------------------------------------------------------- ! SUBROUTINE SMFLX @@ -2689,11 +2700,11 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET,ZSOIL REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SMC, SH2O REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, & - SICE, SH2OA, SH2OFG + SICE, SH2OA, SH2OFG, SH2OIN REAL :: DUMMY, EXCESS,FRZFACT,PCPDRP,RHSCT,TRHSCT REAL :: FAC2 REAL :: FLIMIT - + REAL, INTENT(IN),OPTIONAL :: IRRIGATION_CHANNEL REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT ! ---------------------------------------------------------------------- @@ -2720,7 +2731,9 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! ---------------------------------------------------------------------- IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX PCPDRP = (1. - SHDFAC) * PRCP1+ DRIP / DT - + IF(PRESENT(IRRIGATION_CHANNEL)) THEN + IF (IRRIGATION_CHANNEL.NE.0.)PCPDRP =PCPDRP+ 0.001*IRRIGATION_CHANNEL !conversion of units + END IF ! ---------------------------------------------------------------------- ! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP ! @@ -2784,7 +2797,8 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & SFHEAD1RT,INFXS1RT) - CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + SH2OIN=SH2O + CALL SSTEP (SH2O,SH2OIN,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) ELSE @@ -2792,7 +2806,8 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & SFHEAD1RT,INFXS1RT) - CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + SH2OIN=SH2O + CALL SSTEP (SH2O,SH2OIN,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) ! RUNOF = RUNOFF diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F index 194968854d..1d39e80beb 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F @@ -1,12 +1,16 @@ +!================================================================================================================= MODULE module_sf_noahlsm_glacial_only + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) use mpas_atmphys_constants use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) #else use module_model_constants use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#define FATAL_ERROR(M) call wrf_error_fatal(M) #endif USE module_sf_noahlsm, ONLY : RD, SIGMA, CPH2O, CPICE, LSUBF, EMISSI_S, ROSR12 diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 4db5b42e97..2b3ba578f0 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -138,14 +138,12 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & XLAND, & TSK -! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: REGIME, & HFX, & QFX, & LH, & MOL,RMOL -!m the following 5 are change to memory size ! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & @@ -326,13 +324,12 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, DIMENSION( ims:ime ) , & INTENT(INOUT) :: & - QGH + QSFC,QGH REAL, DIMENSION( ims:ime ) , & INTENT(OUT) :: U10,V10, & - TH2,T2,Q2,QSFC,LH + TH2,T2,Q2,LH - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV REAL, DIMENSION( its:ite ), INTENT(IN ) :: DX diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F new file mode 100644 index 0000000000..ce6e71bff8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F @@ -0,0 +1,276 @@ +!================================================================================================================= + module module_sf_sfclayrev + use mpas_log + use ccpp_kinds,only: kind_phys + + use sf_sfclayrev,only: sf_sfclayrev_run, & + sf_sfclayrev_timestep_init + + + implicit none + private + public:: sfclayrev + + + contains + + +!================================================================================================================= + subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & + cp,g,rovcp,r,xlv,psfc,chs,chs2,cqs2,cpm, & + znt,ust,pblh,mavail,zol,mol,regime,psim,psih, & + fm,fh, & + xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & + u10,v10,th2,t2,q2, & + gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,eomeg,stbolt, & + p1000mb, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & + shalwater_z0,water_depth,shalwater_depth, & + scm_force_flux,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + integer,intent(in):: isfflx + integer,intent(in):: shalwater_z0 + integer,intent(in),optional:: isftcflx, iz0tlnd + integer,intent(in),optional:: scm_force_flux + + real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 + real(kind=kind_phys),intent(in):: ep1,ep2,karman,eomeg,stbolt + real(kind=kind_phys),intent(in):: P1000mb + real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv + real(kind=kind_phys),intent(in):: shalwater_depth + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, & + mavail, & + pblh, & + psfc, & + tsk, & + xland, & + water_depth + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + qv3d, & + p3d, & + t3d, & + u3d, & + v3d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + lh, & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme),optional:: & + ck, & + cka, & + cd, & + cda + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: & + regime, & + hfx, & + qfx, & + qsfc, & + mol, & + rmol, & + gz1oz0, & + wspd, & + br, & + psim, & + psih, & + fm, & + fh, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + flhc, & + flqc, & + qgh + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + ustm + +!--- local variables and arrays: + integer:: i,j,k + real(kind=kind_phys),dimension(its:ite):: dz1d,u1d,v1d,qv1d,p1d,t1d + + real(kind=kind_phys),dimension(its:ite):: & + dx_hv,mavail_hv,pblh_hv,psfc_hv,tsk_hv,xland_hv,water_depth_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + dz_hv,u_hv,v_hv,qv_hv,p_hv,t_hv + + real(kind=kind_phys),dimension(its:ite):: & + lh_hv,u10_hv,v10_hv,th2_hv,t2_hv,q2_hv + real(kind=kind_phys),dimension(its:ite):: & + ck_hv,cka_hv,cd_hv,cda_hv + + real(kind=kind_phys),dimension(its:ite):: & + regime_hv,hfx_hv,qfx_hv,qsfc_hv,mol_hv,rmol_hv,gz1oz0_hv,wspd_hv, & + br_hv,psim_hv,psih_hv,fm_hv,fh_hv,znt_hv,zol_hv,ust_hv,cpm_hv, & + chs2_hv,cqs2_hv,chs_hv,flhc_hv,flqc_hv,qgh_hv + real(kind=kind_phys),dimension(its:ite):: & + ustm_hv + +!----------------------------------------------------------------------------------------------------------------- + + do j = jts,jte + + do i = its,ite + !input arguments: + dx_hv(i) = dx(i,j) + mavail_hv(i) = mavail(i,j) + pblh_hv(i) = pblh(i,j) + psfc_hv(i) = psfc(i,j) + tsk_hv(i) = tsk(i,j) + xland_hv(i) = xland(i,j) + water_depth_hv(i) = water_depth(i,j) + + do k = kts,kte + dz_hv(i,k) = dz8w(i,k,j) + u_hv(i,k) = u3d(i,k,j) + v_hv(i,k) = v3d(i,k,j) + qv_hv(i,k) = qv3d(i,k,j) + p_hv(i,k) = p3d(i,k,j) + t_hv(i,k) = t3d(i,k,j) + enddo + + !inout arguments: + regime_hv(i) = regime(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + qsfc_hv(i) = qsfc(i,j) + mol_hv(i) = mol(i,j) + rmol_hv(i) = rmol(i,j) + gz1oz0_hv(i) = gz1oz0(i,j) + wspd_hv(i) = wspd(i,j) + br_hv(i) = br(i,j) + psim_hv(i) = psim(i,j) + psih_hv(i) = psih(i,j) + fm_hv(i) = fm(i,j) + fh_hv(i) = fh(i,j) + znt_hv(i) = znt(i,j) + zol_hv(i) = zol(i,j) + ust_hv(i) = ust(i,j) + cpm_hv(i) = cpm(i,j) + chs2_hv(i) = chs2(i,j) + cqs2_hv(i) = cqs2(i,j) + chs_hv(i) = chs(i,j) + flhc_hv(i) = flhc(i,j) + flqc_hv(i) = flqc(i,j) + qgh_hv(i) = qgh(i,j) + enddo + + if(present(ustm)) then + do i = its,ite + ustm_hv(i) = ustm(i,j) + enddo + endif + + call sf_sfclayrev_timestep_init(dz2d=dz_hv,u2d=u_hv,v2d=v_hv,qv2d=qv_hv,p2d=p_hv,t2d=t_hv, & + dz1d=dz1d,u1d=u1d,v1d=v1d,qv1d=qv1d,p1d=p1d,t1d=t1d, & + its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg) + + call sf_sfclayrev_run(ux=u1d,vx=v1d,t1d=t1d,qv1d=qv1d,p1d=p1d,dz8w1d=dz1d, & + cp=cp,g=g,rovcp=rovcp,r=r,xlv=xlv,psfcpa=psfc_hv,chs=chs_hv, & + chs2=chs2_hv,cqs2=cqs2_hv,cpm=cpm_hv,pblh=pblh_hv, & + rmol=rmol_hv,znt=znt_hv,ust=ust_hv,mavail=mavail_hv, & + zol=zol_hv,mol=mol_hv,regime=regime_hv,psim=psim_hv, & + psih=psih_hv,fm=fm_hv,fh=fh_hv,xland=xland_hv, & + hfx=hfx_hv,qfx=qfx_hv,tsk=tsk_hv,u10=u10_hv, & + v10=v10_hv,th2=th2_hv,t2=t2_hv,q2=q2_hv,flhc=flhc_hv, & + flqc=flqc_hv,qgh=qgh_hv,qsfc=qsfc_hv,lh=lh_hv, & + gz1oz0=gz1oz0_hv,wspd=wspd_hv,br=br_hv,isfflx=isfflx,dx=dx_hv, & + svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0,ep1=ep1,ep2=ep2,karman=karman, & + eomeg=eomeg,stbolt=stbolt,p1000mb=p1000mb, & + shalwater_z0=shalwater_z0,water_depth=water_depth_hv, & + shalwater_depth=shalwater_depth, & + its=its,ite=ite,errmsg=errmsg,errflg=errflg & +#if ( ( EM_CORE == 1 ) || ( defined(mpas) ) ) + ,isftcflx=isftcflx,iz0tlnd=iz0tlnd,scm_force_flux=scm_force_flux, & + ustm=ustm_hv,ck=ck_hv,cka=cka_hv,cd=cd_hv,cda=cda_hv & +#endif + ) + + do i = its,ite + !output arguments: + lh(i,j) = lh_hv(i) + u10(i,j) = u10_hv(i) + v10(i,j) = v10_hv(i) + th2(i,j) = th2_hv(i) + t2(i,j) = t2_hv(i) + q2(i,j) = q2_hv(i) + + !inout arguments: + regime(i,j) = regime_hv(i) + hfx(i,j) = hfx_hv(i) + qfx(i,j) = qfx_hv(i) + qsfc(i,j) = qsfc_hv(i) + mol(i,j) = mol_hv(i) + rmol(i,j) = rmol_hv(i) + gz1oz0(i,j) = gz1oz0_hv(i) + wspd(i,j) = wspd_hv(i) + br(i,j) = br_hv(i) + psim(i,j) = psim_hv(i) + psih(i,j) = psih_hv(i) + fm(i,j) = fm_hv(i) + fh(i,j) = fh_hv(i) + znt(i,j) = znt_hv(i) + zol(i,j) = zol_hv(i) + ust(i,j) = ust_hv(i) + cpm(i,j) = cpm_hv(i) + chs2(i,j) = chs2_hv(i) + cqs2(i,j) = cqs2_hv(i) + chs(i,j) = chs_hv(i) + flhc(i,j) = flhc_hv(i) + flqc(i,j) = flqc_hv(i) + qgh(i,j) = qgh_hv(i) + enddo + + !optional output arguments: + if(present(ck) .and. present(cka) .and. present(cd) .and. present(cda)) then + do i = its,ite + ck(i,j) = ck_hv(i) + cka(i,j) = cka_hv(i) + cd(i,j) = cd_hv(i) + cda(i,j) = cda_hv(i) + enddo + endif + + !optional inout arguments: + if(present(ustm)) then + do i = its,ite + ustm(i,j) = ustm_hv(i) + enddo + endif + + enddo + + end subroutine sfclayrev + +!================================================================================================================= + end module module_sf_sfclayrev +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F index 62a8a976df..82d7ef5b02 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F @@ -1,12 +1,15 @@ MODULE module_sf_urban + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) use mpas_atmphys_utilities, only: physics_message,physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) -#define WRITE_MESSAGE(M) call physics_message( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else use module_wrf_error -#define FATAL_ERROR(M) call wrf_error_fatal( M ) -#define WRITE_MESSAGE(M) call wrf_message( M ) +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif !=============================================================================== @@ -35,6 +38,8 @@ MODULE module_sf_urban REAL, ALLOCATABLE, DIMENSION(:) :: FRC_URB_TBL REAL, ALLOCATABLE, DIMENSION(:) :: COP_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: BLDAC_FRC_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: COOLED_FRC_TBL REAL, ALLOCATABLE, DIMENSION(:) :: PWIN_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETA_TBL INTEGER, ALLOCATABLE, DIMENSION(:) :: SW_COND_TBL @@ -45,6 +50,11 @@ MODULE module_sf_urban REAL, ALLOCATABLE, DIMENSION(:) :: TARGHUM_TBL REAL, ALLOCATABLE, DIMENSION(:) :: GAPHUM_TBL REAL, ALLOCATABLE, DIMENSION(:) :: PERFLO_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: PV_FRAC_ROOF_TBL !GRZ + REAL, ALLOCATABLE, DIMENSION(:) :: GR_FRAC_ROOF_TBL !GRZ + INTEGER :: GR_FLAG_TBL !GRZ + INTEGER :: GR_TYPE_TBL !GRZ + REAL, DIMENSION(1:24) :: IRHO_TBL REAL, ALLOCATABLE, DIMENSION(:) :: HSESF_TBL REAL, ALLOCATABLE, DIMENSION(:) :: CAPR_TBL, CAPB_TBL, CAPG_TBL @@ -679,7 +689,7 @@ SUBROUTINE urban(LSOLAR, & ! L SIGMA_ZED = stdh_urb !Calculate Wind Direction and Assign Appropriae lf_urb - !WDR = (180.0/PI)*ATAN2(U10,V10) + WDR = (180.0/PI)*ATAN2(U10,V10) IF(WDR.ge.0.0.and.WDR.lt.22.5)THEN lambda_f = lf_urb(1) @@ -691,7 +701,7 @@ SUBROUTINE urban(LSOLAR, & ! L lambda_f = lf_urb(1) ELSEIF(WDR.gt.22.5.and.WDR.le.67.5)THEN lambda_f = lf_urb(2) - ELSEIF(WDR.ge.-67.5.and.WDR.lt.-22.5)THEN + ELSEIF(WDR.ge.-157.5.and.WDR.lt.-112.5)THEN lambda_f = lf_urb(2) ELSEIF(WDR.gt.67.5.and.WDR.le.112.5)THEN lambda_f = lf_urb(3) @@ -699,7 +709,7 @@ SUBROUTINE urban(LSOLAR, & ! L lambda_f = lf_urb(3) ELSEIF(WDR.gt.112.5.and.WDR.le.157.5)THEN lambda_f = lf_urb(4) - ELSEIF(WDR.ge.-157.5.and.WDR.lt.-112.5)THEN + ELSEIF(WDR.ge.-67.5.and.WDR.lt.-22.5)THEN lambda_f = lf_urb(4) ELSE lambda_f = lf_urb(1) @@ -1160,7 +1170,7 @@ SUBROUTINE urban(LSOLAR, & ! L END DO ! Update temperature in soil layer CALL SHFLX (SSOILR,TGRL,SMR,SMCMAX,NGR,TGRP,DELT,YY,ZZ1,ZSOILR, & - TRLEND,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) + TRLEND,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) FLXTHGR=HGR/RHO/CP/100. FLXHUMGR=ELEGR/RHO/EL/100. ELSE @@ -1940,7 +1950,7 @@ END SUBROUTINE read_param ! !=============================================================================== SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & - sf_urban_physics) + sf_urban_physics,use_wudapt_lcz) ! num_roof_layers,num_wall_layers,num_road_layers) IMPLICIT NONE @@ -1954,6 +1964,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZB REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZG INTEGER, INTENT(IN) :: SF_URBAN_PHYSICS + INTEGER, INTENT(IN) :: USE_WUDAPT_LCZ !AndreaLCZ INTEGER :: LC, K INTEGER :: IOSTATUS, ALLOCATE_STATUS @@ -1989,8 +2000,10 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & num_road_layers = num_soil_layers - ICATE=0 + ICATE=0 + + if(USE_WUDAPT_LCZ.eq.0)then !AndreaLCZ OPEN (UNIT=11, & FILE='URBPARM.TBL', & ACCESS='SEQUENTIAL', & @@ -1999,9 +2012,24 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & POSITION='REWIND', & IOSTAT=IOSTATUS) - IF (IOSTATUS > 0) THEN - FATAL_ERROR('ERROR OPEN URBPARM.TBL') - ENDIF + IF (IOSTATUS > 0) THEN + FATAL_ERROR('Error opening URBPARM.TBL. Make sure URBPARM.TBL (found in run/) is linked to the running directory.') + ENDIF + + else + OPEN (UNIT=11, & + FILE='URBPARM_LCZ.TBL', & + ACCESS='SEQUENTIAL', & + STATUS='OLD', & + ACTION='READ', & + POSITION='REWIND', & + IOSTAT=IOSTATUS) + + IF (IOSTATUS > 0) THEN + FATAL_ERROR('Error opening URBPARM_LCZ.TBL. Make sure URBPARM_LCZ.TBL (found in run/) is linked to the running directory.') + ENDIF + endif + READLOOP : do read(11,'(A512)', iostat=iostatus) string @@ -2109,6 +2137,10 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if(allocate_status /= 0) FATAL_ERROR('Error allocating HPERCENT_BIN_TBL in urban_param_init') ALLOCATE( COP_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating COP_TBL in urban_param_init') + ALLOCATE( BLDAC_FRC_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating BLDAC_FRC_TBL in urban_param_init') + ALLOCATE( COOLED_FRC_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating COOLED_FRC_TBL in urban_param_init') ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating PWIN_TBL in urban_param_init') ALLOCATE( BETA_TBL(ICATE), stat=allocate_status ) @@ -2131,6 +2163,11 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if(allocate_status /= 0) FATAL_ERROR('Error allocating PERFLO_TBL in urban_param_init') ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating HSESF_TBL in urban_param_init') + ALLOCATE( PV_FRAC_ROOF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating PV_FRAC_ROOF_TBL in urban_param_init') + ALLOCATE( GR_FRAC_ROOF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating GR_FRAC_ROOF_TBL in urban_param_init') + endif numdir_tbl = 0 street_direction_tbl = -1.E36 @@ -2295,6 +2332,10 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) Z0R_tbl(1:icate) else if ( name == "COP") then read(string(indx+1:),*) cop_tbl(1:icate) + else if ( name == "BLDAC_FRC") then + read(string(indx+1:),*) bldac_frc_tbl(1:icate) + else if ( name == "COOLED_FRC") then + read(string(indx+1:),*) cooled_frc_tbl(1:icate) else if ( name == "PWIN") then read(string(indx+1:),*) pwin_tbl(1:icate) else if ( name == "BETA") then @@ -2319,6 +2360,17 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) hsequip_tbl(1:24) else if (name == "HSEQUIP_SCALE_FACTOR") then read(string(indx+1:),*) hsesf_tbl(1:icate) + else if (name == "IRHO") then + read(string(indx+1:),*) IRHO_TBL(1:24) + else if ( name == "PV_FRAC_ROOF") then + read(string(indx+1:),*) pv_frac_roof_tbl(1:icate) + else if ( name == "GR_FRAC_ROOF") then + read(string(indx+1:),*) gr_frac_roof_tbl(1:icate) + else if (name == "GR_FLAG") then + read(string(indx+1:),*) gr_flag_tbl + else if (name == "GR_TYPE") then + read(string(indx+1:),*) gr_type_tbl + !end BEP else FATAL_ERROR('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') @@ -2410,18 +2462,25 @@ END SUBROUTINE urban_param_init !=========================================================================== SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, & ! in ims,ime,jms,jme,kms,kme,num_soil_layers, & ! in -! num_roof_layers,num_wall_layers,num_road_layers, & ! in -! num_roof_layers,num_wall_layers,num_road_layers, & !urban - LOW_DENSITY_RESIDENTIAL, & - HIGH_DENSITY_RESIDENTIAL, & - HIGH_INTENSITY_INDUSTRIAL, & + LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5, & + LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11, & restart,sf_urban_physics, & !in XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & ! inout TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & ! inout TRL_URB3D,TBL_URB3D,TGL_URB3D, & ! inout SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, & ! inout TS_URB2D, & ! inout - num_urban_layers, & ! in + num_urban_ndm, & ! in + urban_map_zrd, & ! in + urban_map_zwd, & ! in + urban_map_gd, & ! in + urban_map_zd, & ! in + urban_map_zdf, & ! in + urban_map_bd, & ! in + urban_map_wd, & ! in + urban_map_gbd, & ! in + urban_map_fbd, & ! in + urban_map_zgrd, & ! in num_urban_hi, & ! in TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D, & ! inout TLEV_URB3D,QLEV_URB3D, & ! inout @@ -2431,6 +2490,11 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SFVENT_URB3D,LFVENT_URB3D, & ! inout SFWIN1_URB3D,SFWIN2_URB3D, & ! inout SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D, & ! inout + EP_PV_URB3D,T_PV_URB3D, & !GRZ + TRV_URB4D,QR_URB4D,QGR_URB3D,TGR_URB3D, & !GRZ + DRAIN_URB4D,DRAINGR_URB3D,SFRV_URB3D, & !GRZ + LFRV_URB3D,DGR_URB3D,DG_URB3D,LFR_URB3D,LFG_URB3D,&!GRZ + SMOIS_URB, & LP_URB2D,HI_URB2D,LB_URB2D, & ! inout HGT_URB2D,MH_URB2D,STDH_URB2D, & ! inout LF_URB2D, & ! inout @@ -2441,13 +2505,23 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, A_E_BEP,B_U_BEP,B_V_BEP, & ! inout multi-layer urban B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP, & ! inout multi-layer urban DL_U_BEP,SF_BEP,VL_BEP, & ! inout multi-layer urban - FRC_URB2D, UTYPE_URB2D) ! inout + FRC_URB2D, UTYPE_URB2D,USE_WUDAPT_LCZ) ! inout IMPLICIT NONE - INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics - INTEGER, INTENT(IN) :: LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL + INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics,use_wudapt_lcz + INTEGER, INTENT(IN) :: LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme,num_soil_layers - INTEGER, INTENT(IN) :: num_urban_layers !multi-layer urban + INTEGER, INTENT(IN) :: num_urban_ndm + INTEGER, INTENT(IN) :: urban_map_zrd + INTEGER, INTENT(IN) :: urban_map_zwd + INTEGER, INTENT(IN) :: urban_map_gd + INTEGER, INTENT(IN) :: urban_map_zd + INTEGER, INTENT(IN) :: urban_map_zdf + INTEGER, INTENT(IN) :: urban_map_bd + INTEGER, INTENT(IN) :: urban_map_wd + INTEGER, INTENT(IN) :: urban_map_gbd + INTEGER, INTENT(IN) :: urban_map_fbd + INTEGER, INTENT(IN) :: urban_map_zgrd INTEGER, INTENT(IN) :: num_urban_hi !multi-layer urban ! INTEGER, INTENT(IN) :: num_roof_layers, num_wall_layers, num_road_layers @@ -2492,28 +2566,43 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D ! multi-layer UCM variables - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TRB_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zrd, jms:jme), INTENT(INOUT) :: TRB_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_zwd, jms:jme), INTENT(INOUT) :: TW1_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_zwd, jms:jme), INTENT(INOUT) :: TW2_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_gd , jms:jme), INTENT(INOUT) :: TGB_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_bd , jms:jme), INTENT(INOUT) :: TLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_bd , jms:jme), INTENT(INOUT) :: QLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_wd , jms:jme), INTENT(INOUT) :: TW1LEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_wd , jms:jme), INTENT(INOUT) :: TW2LEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_gbd, jms:jme), INTENT(INOUT) :: TGLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_fbd, jms:jme), INTENT(INOUT) :: TFLEV_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW2_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFG_URB3D - REAL, DIMENSION( ims:ime,1:num_urban_hi, jms:jme), INTENT(INOUT) :: HI_URB2D + REAL, DIMENSION( ims:ime, 1:urban_map_wd, jms:jme), INTENT(INOUT) :: SFWIN1_URB3D + REAL, DIMENSION( ims:ime, 1:urban_map_wd, jms:jme), INTENT(INOUT) :: SFWIN2_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zd , jms:jme), INTENT(INOUT) :: SFW1_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zd , jms:jme), INTENT(INOUT) :: SFW2_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zdf, jms:jme), INTENT(INOUT) :: SFR_URB3D + REAL, DIMENSION(ims:ime, 1:num_urban_ndm, jms:jme), INTENT(INOUT) :: SFG_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: EP_PV_URB3D!GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf,jms:jme ), INTENT(INOUT) :: T_PV_URB3D!GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme),INTENT(INOUT) :: TRV_URB4D ! GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme),INTENT(INOUT) :: QR_URB4D ! GRZ + REAL, DIMENSION( ims:ime,jms:jme), INTENT(INOUT) :: QGR_URB3D ! GRZ + REAL, DIMENSION( ims:ime,jms:jme), INTENT(INOUT) :: TGR_URB3D ! GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme),INTENT(INOUT) :: DRAIN_URB4D !GRZ + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRAINGR_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme),INTENT(INOUT) :: SFRV_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme),INTENT(INOUT) :: LFRV_URB3D ! GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: DGR_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: DG_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: LFR_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: LFG_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(IN) ::SMOIS_URB + REAL, DIMENSION( ims:ime,1:num_urban_hi , jms:jme), INTENT(INOUT) :: HI_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LP_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LB_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: HGT_URB2D @@ -2561,117 +2650,43 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, !m !FS FRC_URB2D(I,J)=0. UTYPE_URB2D(I,J)=0 - SWITCH_URB=0 + SWITCH_URB=1 IF( IVGTYP(I,J) == ISURBAN) THEN - UTYPE_URB2D(I,J) = 2 ! for default. high-intensity - UTYPE_URB = UTYPE_URB2D(I,J) ! for default. high-intensity - IF (HGT_URB2D(I,J)>0.) THEN - CONTINUE + IF(use_wudapt_lcz==0) THEN + UTYPE_URB2D(I,J) = 2 ! for default. high-intensity ELSE - WRITE(mesg,*) 'USING DEFAULT URBAN MORPHOLOGY' - WRITE_MESSAGE(mesg) - LP_URB2D(I,J)=0. - LB_URB2D(I,J)=0. - HGT_URB2D(I,J)=0. - IF ( sf_urban_physics == 1 ) THEN - MH_URB2D(I,J)=0. - STDH_URB2D(I,J)=0. - DO K=1,4 - LF_URB2D(I,K,J)=0. - ENDDO - ELSE IF ( ( sf_urban_physics == 2 ) .or. ( sf_urban_physics == 3 ) ) THEN - DO K=1,num_urban_hi - HI_URB2D(I,K,J)=0. - ENDDO - ENDIF + UTYPE_URB2D(I,J) = 5 ! for default. high-intensity ENDIF - IF (FRC_URB2D(I,J)>0.and.FRC_URB2D(I,J)<=1.) THEN - CONTINUE - ELSE - WRITE(mesg,*) 'WARNING, FRC_URB2D = 0 BUT IVGTYP IS URBAN' - WRITE_MESSAGE(mesg) - WRITE(mesg,*) 'WARNING, THE URBAN FRACTION WILL BE READ FROM URBPARM.TBL' - WRITE_MESSAGE(mesg) - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) - ENDIF - SWITCH_URB=1 - ENDIF - - IF( IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL) THEN - UTYPE_URB2D(I,J) = 1 ! low-intensity residential - UTYPE_URB = UTYPE_URB2D(I,J) ! low-intensity residential - IF (HGT_URB2D(I,J)>0.) THEN - CONTINUE - ELSE - WRITE(mesg,*) 'USING DEFAULT URBAN MORPHOLOGY' - WRITE_MESSAGE(mesg) - LP_URB2D(I,J)=0. - LB_URB2D(I,J)=0. - HGT_URB2D(I,J)=0. - IF ( sf_urban_physics == 1 ) THEN - MH_URB2D(I,J)=0. - STDH_URB2D(I,J)=0. - DO K=1,4 - LF_URB2D(I,K,J)=0. - ENDDO - ELSE IF ( ( sf_urban_physics == 2 ) .or. ( sf_urban_physics == 3 ) ) THEN - DO K=1,num_urban_hi - HI_URB2D(I,K,J)=0. - ENDDO - ENDIF - ENDIF - IF (FRC_URB2D(I,J)>0.and.FRC_URB2D(I,J)<=1.) THEN - CONTINUE - ELSE - WRITE(mesg,*) 'WARNING, FRC_URB2D = 0 BUT IVGTYP IS URBAN' - WRITE_MESSAGE(mesg) - WRITE(mesg,*) 'WARNING, THE URBAN FRACTION WILL BE READ FROM URBPARM.TBL' - WRITE_MESSAGE(mesg) - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) - ENDIF - SWITCH_URB=1 - ENDIF - - IF( IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL) THEN - UTYPE_URB2D(I,J) = 2 ! high-intensity - UTYPE_URB = UTYPE_URB2D(I,J) ! high-intensity - IF (HGT_URB2D(I,J)>0.) THEN - CONTINUE - ELSE - WRITE(mesg,*) 'USING DEFAULT URBAN MORPHOLOGY' - WRITE_MESSAGE(mesg) - LP_URB2D(I,J)=0. - LB_URB2D(I,J)=0. - HGT_URB2D(I,J)=0. - IF ( sf_urban_physics == 1 ) THEN - MH_URB2D(I,J)=0. - STDH_URB2D(I,J)=0. - DO K=1,4 - LF_URB2D(I,K,J)=0. - ENDDO - ELSE IF ( ( sf_urban_physics == 2 ) .or. ( sf_urban_physics == 3 ) ) THEN - DO K=1,num_urban_hi - HI_URB2D(I,K,J)=0. - ENDDO - ENDIF - ENDIF - IF (FRC_URB2D(I,J)>0.and.FRC_URB2D(I,J)<=1.) THEN - CONTINUE - ELSE - WRITE(mesg,*) 'WARNING, FRC_URB2D = 0 BUT IVGTYP IS URBAN' - WRITE_MESSAGE(mesg) - WRITE(mesg,*) 'WARNING, THE URBAN FRACTION WILL BE READ FROM URBPARM.TBL' - WRITE_MESSAGE(mesg) - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) - ENDIF - SWITCH_URB=1 + ELSE IF( IVGTYP(I,J) == LCZ_1) THEN + UTYPE_URB2D(I,J) = 1 + ELSE IF( IVGTYP(I,J) == LCZ_2) THEN + UTYPE_URB2D(I,J) = 2 + ELSE IF( IVGTYP(I,J) == LCZ_3) THEN + UTYPE_URB2D(I,J) = 3 + ELSE IF( IVGTYP(I,J) == LCZ_4) THEN + UTYPE_URB2D(I,J) = 4 + ELSE IF( IVGTYP(I,J) == LCZ_5) THEN + UTYPE_URB2D(I,J) = 5 + ELSE IF( IVGTYP(I,J) == LCZ_6) THEN + UTYPE_URB2D(I,J) = 6 + ELSE IF( IVGTYP(I,J) == LCZ_7) THEN + UTYPE_URB2D(I,J) = 7 + ELSE IF( IVGTYP(I,J) == LCZ_8) THEN + UTYPE_URB2D(I,J) = 8 + ELSE IF( IVGTYP(I,J) == LCZ_9) THEN + UTYPE_URB2D(I,J) = 9 + ELSE IF( IVGTYP(I,J) == LCZ_10) THEN + UTYPE_URB2D(I,J) = 10 + ELSE IF( IVGTYP(I,J) == LCZ_11) THEN + UTYPE_URB2D(I,J) = 11 + ELSE + SWITCH_URB=0 ENDIF - IF( IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN - UTYPE_URB2D(I,J) = 3 ! Commercial/Industrial/Transportation - UTYPE_URB = UTYPE_URB2D(I,J) ! Commercial/Industrial/Transportation - IF (HGT_URB2D(I,J)>0.) THEN + IF (SWITCH_URB == 1) THEN + UTYPE_URB = UTYPE_URB2D(I,J) ! for default. high-intensity + IF (HGT_URB2D(I,J)>0.) THEN CONTINUE ELSE WRITE(mesg,*) 'USING DEFAULT URBAN MORPHOLOGY' @@ -2700,11 +2715,6 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, WRITE_MESSAGE(mesg) FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) ENDIF - SWITCH_URB=1 - ENDIF - - IF (SWITCH_URB==1) THEN - CONTINUE ELSE FRC_URB2D(I,J)=0. LP_URB2D(I,J)=0. @@ -2796,31 +2806,21 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, END DO ! multi-layer urban -! IF( sf_urban_physics .EQ. 2)THEN IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN - DO k=1,num_urban_layers -! TRB_URB4D(I,k,J)=TSURFACE0_URB(I,J) -! TW1_URB4D(I,k,J)=TSURFACE0_URB(I,J) -! TW2_URB4D(I,k,J)=TSURFACE0_URB(I,J) -! TGB_URB4D(I,k,J)=TSURFACE0_URB(I,J) -!MT TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J) -!MT TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J) -!MT TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J) IF (UTYPE_URB2D(I,J) > 0) THEN - TRB_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) - TW1_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) - TW2_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + TRB_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + TW1_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + TW2_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) ELSE - TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J) - TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J) - TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J) + TRB_URB4D(I,:,J)=tlayer0_urb(I,1,J) + TW1_URB4D(I,:,J)=tlayer0_urb(I,1,J) + TW2_URB4D(I,:,J)=tlayer0_urb(I,1,J) ENDIF - TGB_URB4D(I,K,J)=tlayer0_urb(I,1,J) - SFW1_URB3D(I,K,J)=0. - SFW2_URB3D(I,K,J)=0. - SFR_URB3D(I,K,J)=0. - SFG_URB3D(I,K,J)=0. - ENDDO + TGB_URB4D(I,:,J)=tlayer0_urb(I,1,J) + SFW1_URB3D(I,:,J)=0. + SFW2_URB3D(I,:,J)=0. + SFR_URB3D(I,:,J)=0. + SFG_URB3D(I,:,J)=0. ENDIF @@ -2830,22 +2830,40 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, CM_AC_URB3D(I,J)=0. SFVENT_URB3D(I,J)=0. LFVENT_URB3D(I,J)=0. + EP_PV_URB3D(I,J)=0. + T_PV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TGR_URB3D(I,J)=tlayer0_urb(I,1,J) + QR_URB4D(I,:,J)=SMOIS_URB(I,1,J) + DRAIN_URB4D(I,:,J)=0. !GRZ + SFRV_URB3D(I,:,J)=0. !GRZ + LFRV_URB3D(I,:,J)=0. !GRZ + DGR_URB3D(I,:,J)=0. !GRZ + DG_URB3D(I,:,J)=0. + LFR_URB3D(I,:,J)=0. + LFG_URB3D(I,:,J)=0. + QGR_URB3D(I,J)=SMOIS_URB(I,1,J) !GRZ + TGR_URB3D(I,J)=0. + DRAINGR_URB3D(I,J)=0. !GRZ + + IF (UTYPE_URB2D(I,J) > 0) THEN + TRV_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + ELSE + TRV_URB4D(I,:,J)=tlayer0_urb(I,1,J) !GRZ + ENDIF - DO K=1,num_urban_layers - TLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TW1LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TW2LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TGLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TFLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - QLEV_URB3D(I,K,J)=0.01 - SFWIN1_URB3D(I,K,J)=0. - SFWIN2_URB3D(I,K,J)=0. + TLEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TW1LEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TW2LEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TGLEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TFLEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + QLEV_URB3D(I,:,J)=0.01 + SFWIN1_URB3D(I,:,J)=0. + SFWIN2_URB3D(I,:,J)=0. !rm LF_AC_URB3D(I,J)=0. !rm SF_AC_URB3D(I,J)=0. !rm CM_AC_URB3D(I,J)=0. !rm SFVENT_URB3D(I,J)=0. !rm LFVENT_URB3D(I,J)=0. - ENDDO endif @@ -2873,6 +2891,8 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, IF (CHECK.EQ.0)THEN IF(IVGTYP(I,J).EQ.1)THEN + write(mesg,*) 'Sample of Urban settings' + WRITE_MESSAGE(mesg) write(mesg,*) 'TSURFACE0_URB',TSURFACE0_URB(I,J) WRITE_MESSAGE(mesg) write(mesg,*) 'TDEEP0_URB', TDEEP0_URB(I,J) diff --git a/src/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 03034c7418..39765f9ee9 100644 --- a/src/core_atmosphere/utils/Makefile +++ b/src/core_atmosphere/utils/Makefile @@ -1,10 +1,14 @@ .SUFFIXES: .F .o -all: build_tables - mv build_tables ../../.. +ifdef PHYSICS + UTILS = build_tables +endif + +all: $(UTILS) build_tables: build_tables.o atmphys_build_tables_thompson.o $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) -L../../external/esmf_time_f90 -lesmf_time + mv build_tables ../../.. build_tables.o: \ @@ -23,7 +27,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/utils/atmphys_build_tables_thompson.F b/src/core_atmosphere/utils/atmphys_build_tables_thompson.F index 83ac7b9014..981dee90ea 100644 --- a/src/core_atmosphere/utils/atmphys_build_tables_thompson.F +++ b/src/core_atmosphere/utils/atmphys_build_tables_thompson.F @@ -25,85 +25,91 @@ module atmphys_build_tables_thompson subroutine build_tables_thompson !================================================================================================================= + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + !local variables: logical, parameter:: l_mp_tables = .false. integer:: istatus + integer:: mp_unit !----------------------------------------------------------------------------------------------------------------- !--- partial initialization before building the look-up tables: call thompson_init(l_mp_tables) + call mpas_new_unit(mp_unit, unformatted = .true.) + !--- building look-up table for rain collecting graupel: write(0,*) write(0,*) '--- building MP_THOMPSON_QRacrQG_DATA.DBL' - open(unit=11,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_QRacrQG_DATA.DBL') return end if call qr_acr_qg - write(11) tcg_racg - write(11) tmr_racg - write(11) tcr_gacr - write(11) tmg_gacr - write(11) tnr_racg - write(11) tnr_gacr - close(unit=11) + write(mp_unit) tcg_racg + write(mp_unit) tmr_racg + write(mp_unit) tcr_gacr + write(mp_unit) tmg_gacr + write(mp_unit) tnr_racg + write(mp_unit) tnr_gacr + close(unit=mp_unit) !--- building look-up table for rain collecting snow: write(0,*) write(0,*) '--- building MP_THOMPSON_QRacrQS_DATA.DBL' - open(unit=11,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_QRacrQS_DATA.DBL') return end if call qr_acr_qs - write(11)tcs_racs1 - write(11)tmr_racs1 - write(11)tcs_racs2 - write(11)tmr_racs2 - write(11)tcr_sacr1 - write(11)tms_sacr1 - write(11)tcr_sacr2 - write(11)tms_sacr2 - write(11)tnr_racs1 - write(11)tnr_racs2 - write(11)tnr_sacr1 - write(11)tnr_sacr2 - close(unit=11) + write(mp_unit)tcs_racs1 + write(mp_unit)tmr_racs1 + write(mp_unit)tcs_racs2 + write(mp_unit)tmr_racs2 + write(mp_unit)tcr_sacr1 + write(mp_unit)tms_sacr1 + write(mp_unit)tcr_sacr2 + write(mp_unit)tms_sacr2 + write(mp_unit)tnr_racs1 + write(mp_unit)tnr_racs2 + write(mp_unit)tnr_sacr1 + write(mp_unit)tnr_sacr2 + close(unit=mp_unit) !--- building look-up table for freezing of cloud droplets: write(0,*) write(0,*) '--- building MP_THOMPSON_freezeH2O_DATA.DBL' - open(unit=11,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_freezeH2O_DATA.DBL') return end if call freezeH2O - write(11) tpi_qrfz - write(11) tni_qrfz - write(11) tpg_qrfz - write(11) tnr_qrfz - write(11) tpi_qcfz - write(11) tni_qcfz - close(unit=11) + write(mp_unit) tpi_qrfz + write(mp_unit) tni_qrfz + write(mp_unit) tpg_qrfz + write(mp_unit) tnr_qrfz + write(mp_unit) tpi_qcfz + write(mp_unit) tni_qcfz + close(unit=mp_unit) !--- building look-up table for autoconversion of cloud ice to snow: write(0,*) write(0,*) '--- building MP_THOMPSON_QIautQS_DATA.DBL' - open(unit=11,file='MP_THOMPSON_QIautQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_QIautQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_QIautQS_DATA.DBL') return end if call qi_aut_qs - write(11) tpi_ide - write(11) tps_iaus - write(11) tni_iaus - close(unit=11) + write(mp_unit) tpi_ide + write(mp_unit) tps_iaus + write(mp_unit) tni_iaus + close(unit=mp_unit) + call mpas_release_unit(mp_unit) write(0,*) write(0,*) 'Finished building all tables.' diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index e8f71becfc..9494a5b7c2 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -19,7 +19,11 @@ OBJS = \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ mpas_atmphys_initialize_real.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_stack.o \ + mpas_kd_tree.o \ + mpas_parse_geoindex.o \ + mpas_geotile_manager.o all: core_hyd @@ -66,17 +70,29 @@ mpas_init_atm_read_met.o: read_geogrid.o: +mpas_kd_tree.o: + mpas_init_atm_llxy.o: mpas_init_atm_core_interface.o: mpas_init_atm_core.o mpas_init_atm_core.o: mpas_advection.o mpas_init_atm_cases.o +mpas_stack.o: + +mpas_parse_geoindex.o: + +mpas_geotile_manager.o: mpas_parse_geoindex.o + mpas_init_atm_static.o: \ mpas_atm_advection.o \ mpas_init_atm_hinterp.o \ mpas_init_atm_llxy.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_stack.o \ + mpas_kd_tree.o \ + mpas_parse_geoindex.o \ + mpas_geotile_manager.o mpas_init_atm_surface.o: \ mpas_init_atm_hinterp.o \ diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index 8215399415..7ac677d7d0 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -60,7 +60,8 @@ 6 = mountain wave, \newline 7 = real-data initial conditions from, e.g., GFS, \newline 8 = surface field (SST, sea-ice) update file for use with real-data simulations \newline - 9 = lateral boundary conditions update file for use with real-data simulations" + 9 = lateral boundary conditions update file for use with real-data simulations \newline + 13 = CAM-MPAS 3-d grid with specified topography and zeta levels" possible_values="1 -- 9"/> + + @@ -229,7 +235,7 @@ - @@ -272,7 +278,12 @@ units="-" description="Whether to switch sea-ice threshold from 0.5 to 0.02" possible_values="true or false"/> + + + @@ -327,6 +338,7 @@ + @@ -377,6 +389,7 @@ + @@ -409,14 +422,14 @@ - + + - @@ -475,6 +488,7 @@ + @@ -507,14 +521,14 @@ - + + - @@ -722,6 +736,9 @@ + + @@ -736,6 +753,9 @@ + + @@ -774,84 +794,110 @@ + description="standard deviation of subgrid-scale orography" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="orographic convexity" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for southerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for south-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for north-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for southerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for south-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for north-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="terrain influence in vertical coordinate, $h_s(x,y,\zeta)$ in Klemp (MWR 2011)" + packages="vertical_stage_out;met_stage_out"/> + description="Geometric height of layer interfaces" + packages="vertical_stage_out;met_stage_out"/> + description="Reciprocal dzw" + packages="vertical_stage_out;met_stage_out"/> + description="d(zeta) at w levels" + packages="vertical_stage_out;met_stage_out"/> + description="Reciprocal dzu" + packages="vertical_stage_out;met_stage_out"/> + description="Weight for linear interpolation to w(k) point for u(k) level variable" + packages="vertical_stage_out;met_stage_out"/> + description="Weight for linear interpolation to w(k) point for u(k-1) level variable" + packages="vertical_stage_out;met_stage_out"/> + description="dz/dx on horizontal coordinate surfaces at u levels" + packages="vertical_stage_out;met_stage_out"/> + description="d(zeta)/dz, vertical metric term" + packages="vertical_stage_out;met_stage_out"/> + description="Coefficients for contribution from u to omega diagnosis, edge-oriented" + packages="vertical_stage_out;met_stage_out"/> + description="Coefficients for 3rd-order correction to contribution from u to omega diagnosis, edge-oriented" + packages="vertical_stage_out;met_stage_out"/> + description="w-damping coefficient" + packages="vertical_stage_out;met_stage_out"/> + description="u reference profile" + packages="met_stage_out"/> + description="v reference profile" + packages="met_stage_out"/> + description="theta reference profile" + packages="met_stage_out"/> + description="qv reference profile" + packages="met_stage_out"/> + + + + @@ -889,18 +941,22 @@ description="Model valid time"/> + description="Horizontal normal velocity at edges" + packages="met_stage_out"/> + description="Vertical velocity at vertical cell faces" + packages="met_stage_out"/> + description="Dry air density divided by d(zeta)/dz" + packages="met_stage_out"/> + description="Moist potential temperature: theta*(1+q_v*R_v/R_d)" + packages="met_stage_out"/> - + @@ -913,7 +969,8 @@ + description="Initial depth of ocean mix layer" + packages="met_stage_out"/> @@ -950,204 +1007,268 @@ + description="First guess zonal wind component" + packages="first_guess_field"/> + description="First guess merdian wind component" + packages="first_guess_field"/> + description="First guess temperature" + packages="first_guess_field"/> + description="First guess pressure" + packages="first_guess_field"/> + description="First guess geopotential height" + packages="first_guess_field"/> + description="First guess relative humidity with respect to liquid water" + packages="first_guess_field"/> + description="First guess specific humidity" + packages="first_guess_field"/> + description="First guess soil height" + packages="first_guess_field"/> + description="First guess surface pressure" + packages="first_guess_field"/> + description="First guess mean sea level pressure" + packages="first_guess_field"/> + description="First guess depth of soil layer bottom" + packages="first_guess_field"/> + description="First guess soil layer thickness" + packages="first_guess_field"/> + description="First guess depth of centers of soil levels" + packages="first_guess_field"/> + description="First guess soil temperature" + packages="first_guess_field"/> + description="First guess soil moisture" + packages="first_guess_field"/> + description="depth of soil layer bottom" + packages="met_stage_out"/> + description="soil layer thickness" + packages="met_stage_out"/> + description="depth of centers of soil layers" + packages="met_stage_out"/> + description="soil equivalent liquid water " + packages="met_stage_out"/> + description="soil moisture" + packages="met_stage_out"/> + description="soil layer temperature" + packages="met_stage_out"/> + description="soil moisture threshold below which transpiration begins to stress" + packages="met_stage_out"/> + description="deep soil temperature" + packages="met_stage_out"/> + description="ground or water surface temperature" + packages="met_stage_out"/> + description="sea-surface temperature" + packages="met_stage_out;sfc_update"/> + description="snow water equivalent" + packages="met_stage_out"/> + description="flag for snow on ground (=0 no snow; =1,otherwise" + packages="met_stage_out"/> + description="physical snow depth" + packages="met_stage_out"/> + description="fractional area coverage of sea-ice" + packages="met_stage_out;sfc_update"/> + description="sea-ice flag (0=no seaice; =1 otherwise)" + packages="met_stage_out"/> + description="geopotential height vertically interpolated from first guess" + packages="met_stage_out"/> + description="vegetation fraction" + packages="met_stage_out"/> + description="background surface albedo" + packages="met_stage_out"/> + description="land-ocean mask (1=land including sea-ice ; 2=ocean)" + packages="met_stage_out"/> + description="10-meter zonal wind" + packages="met_stage_out"/> + description="10-meter meridional wind" + packages="met_stage_out"/> + description="2-meter specific humidity" + packages="met_stage_out"/> + description="2-meter relative humidity" + packages="met_stage_out"/> + description="2-meter temperature" + packages="met_stage_out"/> + description="Perturbation pressure" + packages="met_stage_out"/> + description="Dry air density" + packages="met_stage_out"/> + description="Potential temperature" + packages="met_stage_out"/> + description="Horizontal tangential velocity at edges" + packages="met_stage_out"/> + description="Relative humidity" + packages="met_stage_out"/> + description="Specific humidity" + packages="met_stage_out"/> + description="Cartesian x-component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Cartesian y-component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Cartesian z-component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Zonal component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Meridional component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Exner function" + packages="met_stage_out"/> + description="Base-state Exner function" + packages="met_stage_out"/> + description="reference state rho*theta/zz" + packages="met_stage_out"/> + description="Pressure" + packages="met_stage_out"/> + description="Base state pressure" + packages="met_stage_out"/> + description="Base state dry air density" + packages="met_stage_out"/> + description="Base state potential temperature" + packages="met_stage_out"/> + description="rho_d/rho_m at w points" + packages="met_stage_out"/> + description="Diagnosed surface pressure" + packages="met_stage_out"/> + description="horizontal momentum at cell edge (rho*u/zz)" + packages="met_stage_out"/> + description="rho*omega/zz carried at w points" + packages="met_stage_out"/> + description="rho*theta_m/zz perturbation from the reference state value" + packages="met_stage_out"/> + description="rho/zz perturbation from the reference state value, advanced over acoustic steps" + packages="met_stage_out"/> + description="precipitable water" + packages="met_stage_out"/> diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 1602d09cfa..f4d44c984e 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -757,6 +757,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere ! local variables real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b + real (kind=RKIND), dimension(:,:), pointer :: cell_gradient_coef_x, cell_gradient_coef_y integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell @@ -777,11 +778,13 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv logical :: do_the_cell - real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, area_cellt + real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) + call mpas_pool_get_array(mesh, 'cell_gradient_coef_x', cell_gradient_coef_x) + call mpas_pool_get_array(mesh, 'cell_gradient_coef_y', cell_gradient_coef_y) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) @@ -797,6 +800,9 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_a(:,:) = 0. defc_b(:,:) = 0. + cell_gradient_coef_x(:,:) = 0. + cell_gradient_coef_y(:,:) = 0. + pii = 2.*asin(1.0) do iCell = 1, nCells @@ -817,15 +823,17 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere if (.not. do_the_cell) cycle + ! compute poynomial fit for this cell if all needed neighbors exist -! compute poynomial fit for this cell if all needed neighbors exist if (on_a_sphere) then + ! xc holds the center point and the vertex points of the cell, + ! normalized to a sphere or radius 1. + xc(1) = xCell(iCell)/sphere_radius yc(1) = yCell(iCell)/sphere_radius zc(1) = zCell(iCell)/sphere_radius - do i=2,n iv = verticesOnCell(i-1,iCell) xc(i) = xVertex(iv)/sphere_radius @@ -842,14 +850,22 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere if (zc(1) == 1.0) then theta_abs(iCell) = pii/2. else + ! theta_abs is the angle to the first vertex from the center, normalized so that + ! an eastward pointing vector has a angle of 0. theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & xc(2), yc(2), zc(2), & 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) end if + ! here we are constructing the tangent-plane cell. + ! thetat is the angle in the (x,y) tangent-plane coordinate from + ! the cell center to each vertex, normalized so that an + ! eastward pointing vector has a angle of 0. -! angles from cell center to neighbor centers (thetav) + ! dl_sphere is the spherical distance from the cell center + ! to the sphere vertex points for the cell. + thetat(1) = theta_abs(iCell) do i=1,n-1 ip2 = i+2 @@ -858,22 +874,13 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere thetav(i) = sphere_angle( xc(1), yc(1), zc(1), & xc(i+1), yc(i+1), zc(i+1), & xc(ip2), yc(ip2), zc(ip2) ) - dl_sphere(i) = sphere_radius*arc_length( xc(1), yc(1), zc(1), & - xc(i+1), yc(i+1), zc(i+1) ) + xc(i+1), yc(i+1), zc(i+1) ) + if(i.gt.1) thetat(i) = thetat(i-1)+thetav(i-1) end do - length_scale = 1. - do i=1,n-1 - dl_sphere(i) = dl_sphere(i)/length_scale - end do + ! xp and yp are the tangent-plane vertex points with the cell center at (0,0) - thetat(1) = 0. ! this defines the x direction, cell center 1 -> -! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line - do i=2,n-1 - thetat(i) = thetat(i-1) + thetav(i-1) - end do - do i=1,n-1 xp(i) = cos(thetat(i)) * dl_sphere(i) yp(i) = sin(thetat(i)) * dl_sphere(i) @@ -894,28 +901,21 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end if -! thetat(1) = 0. - thetat(1) = theta_abs(iCell) - do i=2,n-1 - ip1 = i+1 - if (ip1 == n) ip1 = 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 + ! (1) compute cell area on the tangent plane used in the integrals + ! (2) compute angle of cell edge normal vector. here we are repurposing thetat area_cell = 0. - area_cellt = 0. do i=1,n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 - dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) + dx = xp(ip1)-xp(i) + dy = yp(ip1)-yp(i) area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i)) - area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl + thetat(i) = atan2(dy,dx)-pii/2. end do + ! coefficients - see documentation for the formulas. + do i=1,n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 @@ -925,6 +925,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere sint_cost = sin(thetat(i))*cos(thetat(i)) defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell defc_b(i,iCell) = dl*2.*sint_cost/area_cell + cell_gradient_coef_x(i,iCell) = dl*cos(thetat(i))/area_cell + cell_gradient_coef_y(i,iCell) = dl*sin(thetat(i))/area_cell if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then defc_a(i,iCell) = - defc_a(i,iCell) defc_b(i,iCell) = - defc_b(i,iCell) @@ -936,4 +938,4 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end subroutine atm_initialize_deformation_weights -end module atm_advection + end module atm_advection diff --git a/src/core_init_atmosphere/mpas_geotile_manager.F b/src/core_init_atmosphere/mpas_geotile_manager.F new file mode 100644 index 0000000000..64e89212f7 --- /dev/null +++ b/src/core_init_atmosphere/mpas_geotile_manager.F @@ -0,0 +1,1158 @@ +module mpas_geotile_manager + + use iso_c_binding, only : c_float, c_char + + use mpas_constants, only : pii + use mpas_kind_types, only : RKIND, StrKIND + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_POOL_SILENT + use mpas_pool_routines, only : mpas_pool_type, mpas_pool_destroy_pool, mpas_pool_create_pool + use mpas_pool_routines, only : mpas_pool_add_config, mpas_pool_get_config + use mpas_pool_routines, only : mpas_pool_get_error_level, mpas_pool_set_error_level + use mpas_stack + + implicit none + + public :: mpas_geotile_mgr_type + public :: mpas_geotile_type + public :: mpas_latlon_to_xyz + + private + + type mpas_geotile_mgr_type + type (mpas_pool_type), pointer :: pool + type (tile_hash), dimension(:,:), pointer :: hash + type (mpas_stack_type), pointer :: stack + + character (len=StrKIND) :: directory ! Path to the dataset directory + character (len=StrKIND) :: index ! Path the index file of the dataset directory + + integer :: nTileX ! Number of tiles in the X direction + integer :: nTileY ! Number of tiles in the Y direction + integer :: pixel_nx ! Total number of pixels in the x direction + integer :: pixel_ny ! Total number of pixels in the y direction + contains + ! Public Procedures + procedure, public :: init => mpas_geotile_mgr_init + procedure, public :: finalize => mpas_geotile_mgr_finalize + procedure, public :: get_tile => mpas_geotile_mgr_get_tile + procedure, public :: latlon_to_pixel => mpas_geotile_mgr_latlon_to_pixel + procedure, public :: tile_to_latlon => mpas_geotile_mgr_tile_to_latlon + procedure, public :: push_neighbors => mpas_geotile_mgr_push_neighbors + + ! Stack Procedures + procedure, public :: push_tile => mpas_geotile_mgr_push_tile + procedure, public :: pop_tile => mpas_geotile_mgr_pop_tile + procedure, public :: is_stack_empty => mpas_geotile_mgr_stack_is_empty + + ! Private Procedures + procedure, private :: search_tile => mpas_geotile_mgr_search_tile + procedure, private :: add_tile => mpas_geotile_mgr_add_tile + procedure, private :: gen_filename => mpas_geotile_mgr_gen_tile_name + procedure, private :: hash_to_ll => mpas_geotile_mgr_hash_to_latlon + end type mpas_geotile_mgr_type + + + type, extends(mpas_stack_payload_type) :: mpas_geotile_type + real (c_float), dimension(:,:,:), pointer :: tile + + character (len=StrKIND) :: fname ! Path to the file that contains the data for this tile + integer :: hash_x ! The x offset of this tile in the hash table + integer :: hash_y ! The y offset of this tile in the hash table + + integer :: x, y ! The tiles range, in pixels + logical :: is_processed = .false. + end type mpas_geotile_type + + + type tile_hash + type(mpas_geotile_type), pointer :: ptr => null() + end type tile_hash + + + contains + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_init => init + ! + !> \brief Initialize a mpas_geotile_mgr class + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Initialize a geotile manager class by parsing the index file located + !> within path and allocated needed data structures for static interpolation. + !> Init should be called before calling any other mpas_geotile_mgr_type + !> procedures. If path is not a directory or no index file is found in path, + !> 1 will be returned. Upon success 0 will be returned. + !> + !> This function will also allocate the following variables in the pool attribute + !> of this geotile manager instance if they are not found within the index file: + !> * tile_bdr = 0 + !> * signed = 0 ! No + !> * scalefactor = 1.0_RKIND + !> * endian = "big" + !> * iswater = 16 + !> * islake = -1 + !> * isice = 24 + !> * isurban = 1 + !> * isoilwater = 14 + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_init(mgr, path) result(ierr) + + use mpas_parse_geoindex, only : mpas_parse_index + + implicit none + + ! Input variables + class (mpas_geotile_mgr_type) :: mgr + character (len=*), intent(in) :: path + + ! Local variables + character (len=StrKIND), pointer :: fieldType + character (len=StrKIND), pointer :: endian + integer, pointer :: tile_nx ! Number of pixels in the x-direction for a single tile + integer, pointer :: tile_ny ! Number of pixels in the y-direction for a single tile + integer, pointer :: tile_nz ! Number of pixels in the z-direction for a single tile + integer, pointer :: tile_z_start, tile_z_end + integer, pointer :: signed + integer, pointer :: tile_bdr + integer, pointer :: iswater, islake, isice, isurban, isoilwater + integer, pointer :: category_min, category_max + integer :: err_level + real (kind=RKIND), pointer :: dx ! Grid spacing in the x-direction + real (kind=RKIND), pointer :: dy ! Grid spacing in the y-direction + real (kind=RKIND), pointer :: scalefactor + logical :: res + + ! Return variable + integer :: ierr + + ierr = 0 + + mgr % directory = path + + ! Check to see if the index file exists in the directory + inquire(file=trim(mgr % directory)//"index", exist=res) + if (.not. res) then + call mpas_log_write("Could not find an 'index' file in geotile directory: "//trim(path), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + mgr % index = trim(mgr % directory)//"index" + + ! Create the pool for this geotile and call mpas_parse_index + call mpas_pool_create_pool(mgr % pool) + ierr = mpas_parse_index(mgr % index, mgr % pool) + if (ierr /= 0) then + call mpas_log_write("Error parsing geotile index file: "//trim(mgr % index), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + signed => null() + endian => null() + scalefactor => null() + tile_bdr => null() + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + call mpas_pool_get_config(mgr % pool, 'signed', signed) + call mpas_pool_get_config(mgr % pool, 'endian', endian) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + + ! + ! tile_bdr, signed, endian, and scale_factor all have default values, so if they + ! are not present in the index file then set them as the default values, as + ! reported in section 3-53 of the WRF-ARW User's Guide + ! + if (.not. associated(endian)) then + call mpas_pool_add_config(mgr % pool, 'endian', "big") + endif + + if (.not. associated(scalefactor)) then + call mpas_pool_add_config(mgr % pool, 'scale_factor', 1.0_RKIND) + endif + + if (.not. associated(signed)) then + call mpas_pool_add_config(mgr % pool, 'signed', 0) + endif + + if (.not. associated(tile_bdr)) then + call mpas_pool_add_config(mgr % pool, 'tile_bdr', 0) + endif + + ! + ! If this is a categorical field, then check to see if it has category_max and category_min, + ! and then set the defaults of iswater, islake, isice, isurban and isoilwater + ! + call mpas_pool_get_config(mgr % pool, 'type', fieldType) + if (fieldType == 'categorical') then + category_max => null() + category_min => null() + + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + + if (.not. associated(category_max)) then + call mpas_log_write("The index file of this categorical dataset did not contain a category_max parameter", & + messageType=MPAS_LOG_ERR) + call mpas_pool_set_error_level(err_level) ! Reset pool error level + ierr = 1 + return + endif + + if (.not. associated(category_min)) then + call mpas_log_write("The index file of this categorical dataset did not contain a category_min parameter", & + messageType=MPAS_LOG_ERR) + call mpas_pool_set_error_level(err_level) ! Reset pool error level + ierr = 1 + return + endif + + iswater => null() + islake => null() + isice => null() + isurban => null() + isoilwater => null() + + call mpas_pool_get_config(mgr % pool, 'iswater', iswater) + call mpas_pool_get_config(mgr % pool, 'islake', islake) + call mpas_pool_get_config(mgr % pool, 'isice', isice) + call mpas_pool_get_config(mgr % pool, 'isurban', isurban) + call mpas_pool_get_config(mgr % pool, 'isoilwater', isoilwater) + + if (.not. associated(iswater)) then + call mpas_pool_add_config(mgr % pool, 'iswater', 16) + endif + + if (.not. associated(islake)) then + call mpas_pool_add_config(mgr % pool, 'islake', -1) + endif + + if (.not. associated(isice)) then + call mpas_pool_add_config(mgr % pool, 'isice', 24) + endif + + if (.not. associated(isurban)) then + call mpas_pool_add_config(mgr % pool, 'isurban', 1) + endif + + if (.not. associated(isoilwater)) then + call mpas_pool_add_config(mgr % pool, 'isoilwater', 14) + endif + endif + + ! + ! Some datasets describe their z dimension as either tile_z or tile_z_start + ! and tile_z_end. mpas_parse_index will return either one or the other. However, + ! we will need a tile_z value to pass to read_geogrid and we should allocated + ! each z coordinate of a tile in Fortran to be between tile_z_start and tile_z_end. + ! + ! Currently, no static dataset that MPAS uses describes its z coordinate with a lowerbound + ! other than 1. + ! + tile_nz => null() + tile_z_start => null() + tile_z_end => null() + + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + + if (associated(tile_nz)) then + ! Here we are assuming that if tile_z is specified then tile_z_start and tile_z_end + ! are not. This is safe currently as no dataset that MPAS uses specifies both. + call mpas_pool_add_config(mgr % pool, 'tile_z_start', 1) + call mpas_pool_add_config(mgr % pool, 'tile_z_end', tile_nz) + else + call mpas_pool_add_config(mgr % pool, 'tile_z', tile_z_end - tile_z_start + 1) + end if + + + ! Reset the pool's error level + call mpas_pool_set_error_level(err_level) + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + ! Calculate the total number of pixels in x dir + ! NOTE: This calculation assumes that a dataset is a global dataset and may + ! not work correctly for non-global datasets + mgr % pixel_nx = nint(360.0_RKIND / abs(dx)) + mgr % pixel_ny = nint(180.0_RKIND / abs(dy)) + + ! Calculate the number of tiles in the x, y directions + ! NOTE: This calculation assumes that a dataset is a global dataset and may + ! not work correctly for non-global datasets + mgr % nTileX = mgr % pixel_nx / tile_nx + mgr % nTileY = mgr % pixel_ny / tile_ny + + ! Allocate hash table + allocate(mgr % hash(0: mgr % nTileX, 0: mgr % nTileY)) + + ! Mark the stack as empty + mgr % stack => null() + + end function mpas_geotile_mgr_init + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_finalize => finalize + ! + !> \brief Free all memory used by the mpas_geotile_mgr_type + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Deallocated all memory used by this geotile_mgr_type and destroy the + !> associated pool. After calling this function, none of the methods + !> should be used, unless the class is reinitialized by recalling + !> mpas_geotile_mgr_init. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_finalize(mgr) result(ierr) + + implicit none + + ! Input variable + class (mpas_geotile_mgr_type) :: mgr + + ! Return variable + integer :: ierr + + ! Local variable + integer :: i + integer :: j + + ierr = 0 + + ! Loop through the hash table and deallocate any loaded tiles + ! Then deallocate the hash table + do i = 0, mgr % nTileX + do j = 0, mgr % nTileY + if (associated(mgr % hash(i, j) % ptr)) then + if (associated(mgr % hash(i, j) % ptr % tile)) then + deallocate(mgr % hash(i, j) % ptr % tile) + endif + deallocate(mgr % hash(i, j) % ptr) + endif + enddo + enddo + deallocate(mgr % hash) + + if (associated(mgr % hash)) then + call mpas_log_write("Problem deallocating the geotile hash table", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_pool_destroy_pool(mgr % pool) + if (associated(mgr % pool)) then + call mpas_log_write("Problem deallocating the geotile pool", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_stack_free(mgr % stack) + if (associated(mgr % stack)) then + call mpas_log_write("Problem deallocating the stack", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + end function mpas_geotile_mgr_finalize + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_get_tile => get_tile + ! + !> \brief Return an array containing the values of a datatile + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Retrieve the datatile that contains the coordinate lat, lon of the dataset + !> that this mpas_geotile_manager instance was initalized with. Both lat, + !> lon should be in radians and lon should be in the range of -1/2 * pi to + !> 1/2 * pi. lat values that are greater than 2.0 * pi or less than -2.0 * pi + !> will be normalized to be between -pi and pi. Upon success 0 will be returned + !> and tile will point to the mpas_geotile_type that holds the datatile which + !> contains the coordinate lat, lon. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_get_tile(mgr, lat, lon, tile) result(ierr) + implicit none + + ! Input variables + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + type (mpas_geotile_type), pointer :: tile + + ! Return variable + integer :: ierr + + ierr = 0 + tile => null() + + ! Normalize longitude to be between -pi and pi + call normalize_lon(lon) + + if (.not. mgr % search_tile(lat, lon, tile)) then + ierr = mgr % add_tile(lat, lon, tile) + endif + + end function mpas_geotile_mgr_get_tile + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_search_tile => search_tile + ! + !> \brief Search to see if a tile has already been loaded + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Private function that searches to see if the datatile that contains + !> the coordinate lat, lon has already been loaded. If the datatile has been + !> loaded, .true. will be returned and tile will point to the mpas_geotile_type + !> that contains the datatile. If the datatile has not been loaded, .false. + !> will be returned and tile will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_search_tile(mgr, lat, lon, tile) result(loaded) + + implicit none + + ! Input variables + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + type (mpas_geotile_type), pointer :: tile + + ! Return variable + logical :: loaded + + ! Local variables + integer, pointer :: tile_nx + integer, pointer :: tile_ny + character (len=StrKIND) :: fname + integer :: x, y + integer :: start_x + integer :: start_y + integer :: ierr + + loaded = .false. + tile => null() + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + + ! + ! Using gen_filename, get the tiles start x and y pixel values of the tile + ! + ierr = mgr % gen_filename(lat, lon, fname, start_x, start_y) + if (ierr /= 0) then + call mpas_log_write("Error generating filename", messageType=MPAS_LOG_ERR) + return + endif + + ! + ! Access the tile in the hash table (-1 here as the hash table is from + ! 0:tile_nx, and 0:tile_ny). + ! + x = (start_x - 1) / tile_nx + if (x < 0 .or. x > size(mgr % hash, 1)) then + return + endif + + y = (start_y - 1) / tile_ny + if (y < 0 .or. y > size(mgr % hash, 2)) then + return + endif + + tile => mgr % hash(x,y) % ptr + if (associated(tile)) then + loaded = .true. + endif + + end function mpas_geotile_mgr_search_tile + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_add_tile => add_tile + ! + !> \brief Read in a datatile file and store a reference to it + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Read the datatile that contains the coordinate lat, lon. Open success, + !> 0 will be returned and tile will point to the mpas_geotile_type which + !> contains the coordiate lat, lon. Upon success a reference to that + !> mpas_geotile_type will be placed into the hash table, which can later + !> be searched via search_tile. On error, 1 will be returned and tile + !> will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_add_tile(mgr, lat, lon, tile) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr, c_int, c_float + use mpas_c_interfacing, only : mpas_f_to_c_string + + implicit none + + interface + subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & + wordsize, status) bind(C) + use iso_c_binding, only : c_char, c_int, c_float, c_ptr + character (c_char), dimension(*), intent(in) :: fname + type (c_ptr), value :: rarray + integer (c_int), intent(in), value :: nx + integer (c_int), intent(in), value :: ny + integer (c_int), intent(in), value :: nz + integer (c_int), intent(in), value :: isigned + integer (c_int), intent(in), value :: endian + integer (c_int), intent(in), value :: wordsize + integer (c_int), intent(inout) :: status + end subroutine read_geogrid + end interface + + ! Arguments + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), intent(in) :: lat + real (kind=RKIND), intent(in) :: lon + type (mpas_geotile_type), intent(inout), pointer :: tile + integer :: ierr + + ! Local variables + integer, pointer :: tile_nx, tile_ny, tile_nz + integer, pointer :: tile_z_start, tile_z_end + integer, pointer :: tile_bdr + integer, pointer :: wordsize + integer :: start_x, start_y + integer, pointer :: signed + character (len=StrKIND), pointer :: endian + integer :: err_level + logical :: res + + character (len=StrKIND) :: fname + character (kind=c_char), dimension(StrKIND+1) :: c_fname + integer (c_int) :: c_tile_nx, c_tile_ny, c_tile_nz + integer (c_int) :: c_endian + integer (c_int) :: c_wordsize + integer (c_int) :: c_signed + integer (c_int) :: status + type (c_ptr) :: c_tile_ptr + + ierr = 0 + + tile_nx => null() + tile_ny => null() + tile_nz => null() + tile_z_start => null() + tile_z_end => null() + tile_bdr => null() + wordsize => null() + tile => null() + endian => null() + signed => null() + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'wordsize', wordsize) + call mpas_pool_get_config(mgr % pool, 'signed', signed) + call mpas_pool_get_config(mgr % pool, 'endian', endian) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + + ! Reset the pool's error level + call mpas_pool_set_error_level(err_level) + + c_tile_nx = tile_nx + 2 * tile_bdr ! The number of pixels in the x direction, including halo cells + c_tile_ny = tile_ny + 2 * tile_bdr ! The number of pixels in the y direction, including halo cells + c_tile_nz = tile_nz + + c_wordsize = wordsize + c_signed = signed + + if (endian == "big") then + c_endian = 0 + else if (endian == "little") then + c_endian = 1 + endif + + ! + ! Determine the file that contains lat, lon. + ! + ierr = mgr % gen_filename(lat, lon, fname, start_x, start_y) + if (ierr /= 0) then + call mpas_log_write("Error creating filename for coordinate: ($r, $r)", realArgs=(/lat, lon/), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + ! + ! See if this file actually exists + ! + fname = trim(mgr % directory)//trim(fname) + inquire(file=trim(fname), exist=res) + if (.not. res) then + call mpas_log_write("This geotile file does not exist: "//trim(fname), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + call mpas_f_to_c_string(fname, c_fname) + + ! + ! Allocate and read the tile + ! + allocate(tile) + allocate(tile % tile(tile_nx + (tile_bdr * 2), tile_ny + (tile_bdr * 2), tile_z_start:tile_z_end)) + c_tile_ptr = c_loc(tile % tile) + call read_geogrid(c_fname, c_tile_ptr, c_tile_nx, c_tile_ny, c_tile_nz, c_signed, c_endian, c_wordsize, status) + if (status /= 0) then + call mpas_log_write("Error reading this geogrid file: "//trim(fname), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + tile % fname = fname + tile % hash_x = (start_x - 1) / tile_nx + tile % hash_y = (start_y - 1) / tile_ny + tile % x = start_x + tile % y = start_y + + ! + ! Add the tile to the hash table + ! + mgr % hash(tile % hash_x, tile % hash_y) % ptr => tile + + end function mpas_geotile_mgr_add_tile + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_gen_tile_name => gen_filename + ! + !> \brief Generate the filename of the tile at lat, lon + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Generate the name of the file that contains the coordinate lat, lon + !> (in radians) and optionally return start_x and start_y (the location + !> of the first global pixel coordinate of tile). Warning: This function + !> can produce filenames that may not exist (For lon less than -.5 * pi and + !> greater than .5 * pi and lat less than -pi and greater than pi). + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_gen_tile_name(mgr, lat, lon, fname, start_x, start_y) result(ierr) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + character (len=StrKIND), intent(out) :: fname + integer, intent(out), optional :: start_x + integer, intent(out), optional :: start_y + + character (len=StrKIND), parameter :: fname_format = "(i5.5, '-', i5.5, '.', i5.5, '-', i5.5)" + + real (kind=RKIND), pointer :: dx + real (kind=RKIND), pointer :: dy + integer, pointer :: tile_nx + integer, pointer :: tile_ny + integer, dimension(2) :: x + integer, dimension(2) :: y + + integer :: ierr + ierr = 0 + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + ! Find the global pixel location that contains lat, lon + call mgr % latlon_to_pixel(lat, lon, x(1), y(1)) + + ! Calculate the range of this tile, which will be its filename + x(1) = (x(1) - modulo(x(1), tile_nx)) + 1 + x(2) = x(1) + tile_nx - 1 + + y(1) = (y(1) - modulo(y(1), tile_ny)) + 1 + y(2) = y(1) + tile_ny - 1 + + write(fname, fname_format) x(1), x(2), y(1), y(2) + + if (present(start_x)) then + start_x = x(1) + endif + if (present(start_y)) then + start_y = y(1) + endif + + end function mpas_geotile_mgr_gen_tile_name + + + !*********************************************************************** + ! + ! public subroutine mpas_geotile_mgr_tile_to_latlon => tile_to_latlon + ! + !> \brief Find the latitude, longitude location of a tile's pixels + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Given a tile, translate the pixel coordinates, i, j to a corresponding latitude + !> and longitude coordinate. + !> + !> If supersample_fac is present each pixel will be subdivided into supersample_fac ^ 2 + !> sub-pixels. If supersample_fac is greater than 1, then the calling code will need + !> to pass in supersampled i and j coordinates. + !> + !> Upon success, lat, lon will be in the range of -1/2 * pi to 1/2 * pi and 0 to + !> 2.0 * pi, respectively. + ! + !----------------------------------------------------------------------- + subroutine mpas_geotile_mgr_tile_to_latlon(mgr, tile, j, i, lat, lon, supersample_fac) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer, intent(in) :: tile + integer, value :: j + integer, value :: i + real (kind=RKIND), intent(out) :: lat + real (kind=RKIND), intent(out) :: lon + integer, optional, intent(in) :: supersample_fac + + integer, pointer :: tile_bdr + real (kind=RKIND), pointer :: known_lon + real (kind=RKIND), pointer :: known_lat + real (kind=RKIND), pointer :: dx + real (kind=RKIND), pointer :: dy + integer :: supersample_lcl + integer :: ierr + + ierr = 0 + + if (present(supersample_fac)) then + supersample_lcl = supersample_fac + else + supersample_lcl = 1 + end if + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'known_lat', known_lat) + call mpas_pool_get_config(mgr % pool, 'known_lon', known_lon) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + lat = known_lat + real(j - (supersample_lcl * tile_bdr + 1) + (supersample_lcl * (tile % y - 1)), kind=RKIND) * dy & + / supersample_lcl + lon = known_lon + real(i - (supersample_lcl * tile_bdr + 1) + (supersample_lcl * (tile % x - 1)), kind=RKIND) * dx & + / supersample_lcl + + call deg2Rad(lat) + call deg2Rad(lon) + + end subroutine mpas_geotile_mgr_tile_to_latlon + + + !*********************************************************************** + ! + ! public subroutine mpas_geotile_mgr_latlon_to_pixel => latlon_to_pixel + ! + !> \brief Translate a latitude, longitude coordinate to pixel coordinates + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Translate a latitude, longitude coordinate into global pixel coordinates. lat + !> should be in the range of -.5 * pi to .5 * pi and lon should be between -pi + !> and pi. + ! + !----------------------------------------------------------------------- + subroutine mpas_geotile_mgr_latlon_to_pixel(mgr, lat, lon, pixel_x, pixel_y) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + integer, intent(out) :: pixel_x + integer, intent(out) :: pixel_y + + integer, pointer :: tile_bdr + real (kind=RKIND), pointer :: known_lon + real (kind=RKIND), pointer :: known_lat + real, pointer :: dx + real, pointer :: dy + integer :: ierr + + ierr = 0 + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'known_lon', known_lon) + call mpas_pool_get_config(mgr % pool, 'known_lat', known_lat) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + call rad2Deg(lat) + call rad2Deg(lon) + + pixel_x = nint((lon - known_lon) / dx) + pixel_y = nint((lat - known_lat) / dy) + + if (pixel_x < 0) then + pixel_x = pixel_x + mgr % pixel_nx + else if (pixel_x >= mgr % pixel_nx) then + pixel_x = pixel_x - mgr % pixel_nx + endif + + if (pixel_y < 0) then + pixel_y = 0 + else if (pixel_y >= mgr % pixel_ny) then + pixel_y = mgr % pixel_ny - 1 + endif + + end subroutine mpas_geotile_mgr_latlon_to_pixel + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_hash_to_latlon => hash_to_ll + ! + !> \brief Find the lat, lon center from a hash entry + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Translate the index within the hash table into the latitude and longitude + !> coordinate (in radians) of the center of the datatile at that index. + ! + !----------------------------------------------------------------------- + subroutine mpas_geotile_mgr_hash_to_latlon(mgr, xHash, yHash, lat, lon) + + implicit none + + class(mpas_geotile_mgr_type) :: mgr + integer, intent(in), value :: xHash + integer, intent(in), value :: yHash + real, intent(out) :: lat + real, intent(out) :: lon + + integer, pointer :: tile_nx + integer, pointer :: tile_ny + real (kind=RKIND), pointer :: known_lat + real (kind=RKIND), pointer :: known_lon + real (kind=RKIND), pointer :: dx + real (kind=RKIND), pointer :: dy + + integer :: x + integer :: y + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'known_lat', known_lat) + call mpas_pool_get_config(mgr % pool, 'known_lon', known_lon) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + x = (xHash * tile_nx) + (tile_nx / 2) + y = (yHash * tile_ny) + (tile_ny / 2) + + lon = (real((x), kind=RKIND) * dx ) + known_lon + lat = (real((y), kind=RKIND) * dy ) + known_lat + + call deg2Rad(lat) + call deg2Rad(lon) + + end subroutine mpas_geotile_mgr_hash_to_latlon + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_push_neighbors => push_neighbors + ! + !> \brief Determine the tile nighbors and push them onto the stack + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Determine the neighbors of a tile and push them onto the stack. If the + !> tile neighbors have not been loaded, via add_tile, then they will be. + !> Upon success, the neighbors of a tile will be pushed onto the stack and + !> 0 will be returned. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_push_neighbors(mgr, tile) result(ierr) + + implicit none + + class(mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer, intent(in) :: tile + + integer :: ierr + type (mpas_geotile_type), pointer :: neighbor + real (kind=RKIND) :: lat + real (kind=RKIND) :: lon + integer :: xHash + integer :: yHash + + ierr = 0 + + ! Up + ! Calculate the tile's hash coordinates + neighbor => null() + if (tile % hash_y + 1 > mgr % nTileY - 1) then + xHash = modulo(tile % hash_x + (mgr % nTileX / 2), mgr % nTileX) + yHash = tile % hash_y + else + xHash = tile % hash_x + yHash = tile % hash_y + 1 + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the up tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + ! Down + neighbor => null() + if (tile % hash_y - 1 < 0) then + xHash = modulo(tile % hash_x + (mgr % nTileX / 2), mgr % nTileX) + yHash = tile % hash_y + else + xHash = tile % hash_x + yHash = tile % hash_y - 1 + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the down tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + ! Right + neighbor => null() + if (tile % hash_x + 1 > mgr % nTileX - 1) then + yHash = tile % hash_y + xHash = 0 + else + xHash = tile % hash_x + 1 + yHash = tile % hash_y + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the right tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + ! Left + neighbor => null() + if (tile % hash_x -1 < 0) then + xHash = mgr % nTileX - 1 + yHash = tile % hash_y + else + xHash = tile % hash_x - 1 + yHash = tile % hash_y + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the left tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + end function mpas_geotile_mgr_push_neighbors + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!! Stack wrappers and helper functions !!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_push_tile => push_tile + ! + !> \brief Push a mpas_geotile_type onto the stack + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Wrapper subroutine for mpas_stack_push from mpas_stack.F. Aftering calling + !> this subroutine, the tile pushed will be on the top of the stack associated + !> with mpas_geotile_mgr instance (TODO: Is instance the correct term??) and pop_tile + !> can be used to retrive the tile that was last pushed onto the stack. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_push_tile(mgr, tile) result(ierr) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer :: tile + integer :: ierr + + ierr = 0 + + mgr % stack => mpas_stack_push(mgr % stack, tile) + + end function mpas_geotile_mgr_push_tile + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_pop_tile => pop_tile + ! + !> \brief Pop the top mpas_geotile_type off of the stack + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Retrieve and remove the last tile that was pushed onto the stack that + !> is associated with this mpas_geotile_mgr instance (TODO: Is instance the correct term?). If the stack is empty, + !> then tile will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_pop_tile(mgr) result(tile) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + class (mpas_stack_payload_type), pointer :: top + type (mpas_geotile_type), pointer :: tile + + tile => null() + + if (mpas_stack_is_empty(mgr % stack)) then + return + endif + + top => mpas_stack_pop(mgr % stack) + + select type(top) + type is(mpas_geotile_type) + tile => top + return + class default + ! Should not get here + end select + + end function mpas_geotile_mgr_pop_tile + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_stack_is_empty => is_stack_empty + ! + !> \brief Return .true. if stack is empty and .false. otherwise + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Return .true. if the stack associated with this mpas_geotile_mgr instance (TODO: Is instance the correct term?) + !> is empty, and .false. if it is not empty. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_stack_is_empty(mgr) result(empty) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + logical :: empty + + empty = mpas_stack_is_empty(mgr % stack) + + end function mpas_geotile_mgr_stack_is_empty + + + !*********************************************************************** + ! + ! public subroutine mpas_latlon_to_xyz + ! + !> \brief Convert a latitude, longitude coordinate into its Cartesian equivalent + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Given a latitude, longitude coordinate and a radius, convert the latitude, + !> longitude coordinate into the equivalent Cartesian coordinate. + ! + !----------------------------------------------------------------------- + subroutine mpas_latlon_to_xyz(x, y, z, radius, lat, lon) + + implicit none + + real (kind=RKIND), intent(in) :: radius + real (kind=RKIND), intent(in) :: lat + real (kind=RKIND), intent(in) :: lon + real (kind=RKIND), intent(out) :: x, y, z + + z = radius * sin(lat) + x = radius * cos(lon) * cos(lat) + y = radius * sin(lon) * cos(lat) + + end subroutine mpas_latlon_to_xyz + + + ! Convert radians to degrees + subroutine rad2Deg(rad) + + implicit none + real (kind=RKIND), intent(inout) :: rad + + rad = rad * (180.0_RKIND / pii) + + end subroutine rad2Deg + + + ! Convert degrees to radians + subroutine deg2Rad(deg) + + implicit none + real (kind=RKIND), intent(inout) :: deg + + deg = deg * (pii / 180.0_RKIND) + + end subroutine deg2Rad + + + ! Normalize logitude (in radians) to be between -pi and pi. + subroutine normalize_lon(lon) + + implicit none + real (kind=RKIND), intent(inout) :: lon + + if (lon > pii) then + lon = lon - (2.0 * pii) + else if (lon < -pii) then + lon = lon + (2.0 * pii) + endif + + end subroutine normalize_lon + +end module mpas_geotile_manager diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 50d5068a0e..e3e1ba56ea 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -51,7 +51,6 @@ subroutine init_atm_setup_case(domain, stream_manager) type (MPAS_streamManager_type), intent(inout) :: stream_manager - integer :: i integer :: ierr type (block_type), pointer :: block_ptr @@ -69,6 +68,7 @@ subroutine init_atm_setup_case(domain, stream_manager) logical, pointer :: config_blend_bdy_terrain character (len=StrKIND), pointer :: config_start_time character (len=StrKIND), pointer :: config_met_prefix + character (len=StrKIND), pointer :: config_specified_zeta_levels character(len=StrKIND), pointer :: mminlu character(len=StrKIND), pointer :: xtime @@ -112,7 +112,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) call mpas_log_write(' calling test case setup ') - call init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) + call init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, block_ptr % configs) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -134,7 +134,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_log_write(' calling test case setup ') - call init_atm_case_squall_line(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case) + call init_atm_case_squall_line(domain % dminfo, mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -154,7 +154,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_log_write(' calling test case setup ') - call init_atm_case_mtn_wave(domain % dminfo, mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) + call init_atm_case_mtn_wave(mesh, nCells, nVertLevels, state, diag, block_ptr % configs) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -207,20 +207,6 @@ subroutine init_atm_setup_case(domain, stream_manager) end if if (config_static_interp) then - - ! - ! Without a convex mesh partition file, interpolating static fields in parallel - ! will give incorrect results. Since it is very unlikely that typical users - ! will have convex partitions, it's safer to just stop if multiple MPI tasks are - ! detected when performing the static_interp step. - ! - if (domain % dminfo % nprocs > 1) then - call mpas_log_write('****************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('Error: Interpolation of static fields does not work in parallel.', messageType=MPAS_LOG_ERR) - call mpas_log_write('Please run the static_interp step using only a single MPI task.', messageType=MPAS_LOG_ERR) - call mpas_log_write('****************************************************************', messageType=MPAS_LOG_CRIT) - end if - call init_atm_static(mesh, block_ptr % dimensions, block_ptr % configs) end if @@ -252,7 +238,7 @@ subroutine init_atm_setup_case(domain, stream_manager) end if call init_atm_case_gfs(block_ptr, mesh, nCells, nEdges, nVertLevels, fg, state, & - diag, diag_physics, config_init_case, block_ptr % dimensions, block_ptr % configs) + diag, diag_physics, block_ptr % dimensions, block_ptr % configs) if (config_met_interp) then call physics_initialize_real(mesh, fg, domain % dminfo, block_ptr % dimensions, block_ptr % configs) @@ -352,11 +338,40 @@ subroutine init_atm_setup_case(domain, stream_manager) ! call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lbc', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + else if (config_init_case == 13 ) then + + call mpas_log_write(' CAM-MPAS grid ') + + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_config(block_ptr % configs, 'config_specified_zeta_levels', config_specified_zeta_levels) + + if (len_trim(config_specified_zeta_levels) < 1) then + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Setup of CAM-MPAS grid requires a specified set of zeta levels.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please set the namelist option config_specified_zeta_levels', messageType=MPAS_LOG_ERR) + call mpas_log_write('in the &vertical_grid namelist group.', messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + + call mpas_log_write('Errors were detected in the namelist.init_atmosphere file.', messageType=MPAS_LOG_CRIT) + end if + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + + ! nVertLevels is used to allocate variables on the stack in init_atm_case_cam_mpas + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call init_atm_case_cam_mpas(stream_manager, domain % dminfo, block_ptr, & + mesh, block_ptr % dimensions, block_ptr % configs, nVertLevels) + + block_ptr => block_ptr % next + end do + else - call mpas_log_write(' ****************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Only test cases 1 through 9 are currently supported.', messageType=MPAS_LOG_ERR) - call mpas_log_write(' ****************************************************', messageType=MPAS_LOG_CRIT) + call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Only test cases 1 through 9 and 13 are currently supported.', messageType=MPAS_LOG_ERR) + call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_CRIT) end if @@ -379,7 +394,7 @@ end subroutine init_atm_setup_case !---------------------------------------------------------------------------------------------------------- - subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, test_case) + subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -392,7 +407,6 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: test_case real (kind=RKIND), parameter :: u0 = 35.0 real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation @@ -409,7 +423,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp real (kind=RKIND), dimension(:), pointer :: surface_pressure real (kind=RKIND), dimension(:,:), pointer :: zgrid, zxu, 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 :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt real (kind=RKIND), dimension(:,:), pointer :: u, ru, w, rw, v real (kind=RKIND), dimension(:,:), pointer :: rho, theta real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 @@ -427,29 +441,25 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes integer, pointer :: nz1, nCellsSolve, nEdges, maxEdges, nVertices !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, verticesOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - real (kind=RKIND) :: flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r + real (kind=RKIND) :: flux, fluxk, lat1, lat2, r_pert, u_pert, lat_pert, lon_pert - real (kind=RKIND) :: ptop, p0, phi + real (kind=RKIND) :: p0, phi real (kind=RKIND) :: lon_Edge - real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str - - real (kind=RKIND) :: es, qvs, xnutr, znut, ptemp - integer :: iter + real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, str - real (kind=RKIND), dimension(nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn + real (kind=RKIND) :: es, xnutr, znut, ptemp real (kind=RKIND), dimension(nVertLevels + 1 ) :: sh, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND), dimension(nVertLevels ) :: eta, etav, teta, ppi, tt, temperature_1d - real (kind=RKIND) :: d1, d2, d3, cof1, cof2, psurf + real (kind=RKIND) :: cof1, cof2, psurf real (kind=RKIND), pointer :: cf1, cf2, cf3 ! storage for (lat,z) arrays for zonal velocity calculation @@ -473,6 +483,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), pointer :: nominalMinDc real (kind=RKIND), dimension(:), pointer :: latCell, latVertex, lonVertex, latEdge, lonEdge real (kind=RKIND), dimension(:), pointer :: fEdge, fVertex @@ -483,11 +494,12 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes integer, pointer :: config_theta_adv_order integer, pointer :: config_init_case + character (len=StrKIND), pointer :: config_interface_projection call mpas_pool_get_config(configs, 'config_init_case', config_init_case) call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) - + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) ! ! Scale all distances and areas from a unit sphere to one with radius sphere_radius @@ -506,6 +518,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -523,6 +536,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes areaCell(:) = areaCell(:) * sphere_radius**2.0 areaTriangle(:) = areaTriangle(:) * sphere_radius**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * sphere_radius**2.0 + nominalMinDc = nominalMinDc * sphere_radius call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -669,12 +683,25 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral are supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) @@ -793,7 +820,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes !get moisture if (moisture) then - qv_2d(k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max ) + qv_2d(k,i) = env_qv( temperature_1d(k), ptemp, rh_max ) end if tt(k) = temperature_1d(k)*(1.+1.61*qv_2d(k,i)) @@ -901,7 +928,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes !get moisture if (moisture) then - !scalars(index_qv,k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max ) + !scalars(index_qv,k,i) = env_qv( temperature_1d(k), ptemp, rh_max ) if(ptemp < 50000.) then relhum(k,i) = 0.0 @@ -1011,7 +1038,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes if (rebalance) then - call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,dvEdge(iEdge),sphere_radius,u0,nz1,nlat) + call init_atm_calc_flux_zonal(u_2d,lat_2d,flux_zonal,lat1,lat2,dvEdge(iEdge),sphere_radius,u0,nz1,nlat) do k=1,nVertLevels fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2))) u(k,iEdge) = fluxk + u_pert @@ -1175,12 +1202,12 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes end subroutine init_atm_case_jw - subroutine init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat) + subroutine init_atm_calc_flux_zonal(u_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat) implicit none integer, intent(in) :: nz1,nlat - real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_2d,etavs_2d + real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_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 @@ -1325,7 +1352,7 @@ subroutine init_atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz end subroutine init_atm_recompute_geostrophic_wind - subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, diag, test_case) + subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, diag, configs, test_case) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup squall line and supercell test case !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1338,6 +1365,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer, intent(in) :: nVertLevels type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: test_case real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp @@ -1347,46 +1375,46 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum, thi, tbi, cqwb - real (kind=RKIND) :: r, xnutr + real (kind=RKIND) :: xnutr real (kind=RKIND) :: ztemp, zd, zt, dz, str real (kind=RKIND), dimension(nVertLevels ) :: qvb real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d - real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND) :: cof1, cof2 real (kind=RKIND), pointer :: cf1, cf2, cf3 real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0 real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale - real (kind=RKIND) :: pres, temp, es, qvs + real (kind=RKIND) :: pres, temp, qvs real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + character (len=StrKIND), pointer :: config_interface_projection + call mpas_pool_get_array(mesh, 'xCell', xCell) call mpas_pool_get_array(mesh, 'yCell', yCell) call mpas_pool_get_array(mesh, 'zCell', zCell) @@ -1401,9 +1429,11 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) ! ! Scale all distances @@ -1425,6 +1455,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d areaCell(:) = areaCell(:) * a_scale**2.0 areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + nominalMinDc = nominalMinDc * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -1552,12 +1583,25 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) @@ -1912,21 +1956,19 @@ end subroutine init_atm_case_squall_line !---------------------------------------------------------------------------------------------------------- - subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag, configs, init_case) + subroutine init_atm_case_mtn_wave(mesh, nCells, nVertLevels, state, diag, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (dm_info), intent(in) :: dminfo type (mpas_pool_type), intent(inout) :: mesh integer, intent(in) :: nCells integer, intent(in) :: nVertLevels type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(inout) :: configs - integer, intent(in) :: init_case real (kind=RKIND), parameter :: t0=288., hm=250. @@ -1936,12 +1978,12 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag 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 :: eoe integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2, nz1 + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, itr, cell1, cell2, nz1 integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices integer, pointer :: index_qv @@ -1950,20 +1992,18 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND) :: ztemp, zd, zt, dz, str real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum - real (kind=RKIND) :: es, qvs, xnutr, ptemp - integer :: iter + real (kind=RKIND) :: qvs, xnutr real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND) :: d1, d2, d3, cof1, cof2 real (kind=RKIND) :: um, vm,rcp, rcv - real (kind=RKIND) :: xmid, temp, pres, a_scale + real (kind=RKIND) :: temp, pres, a_scale - real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, z_edge, z_edge3 + real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, z_edge, z_edge3 integer, dimension(nCells, 2) :: next_cell - real (kind=RKIND), dimension(nCells) :: hxzt logical, parameter :: terrain_smooth = .false. real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell @@ -1971,6 +2011,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius real (kind=RKIND), pointer :: config_coef_3rd_order @@ -1981,6 +2022,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, v_init, angleEdge, fEdge, fVertex + character (len=StrKIND), pointer :: config_interface_projection call mpas_pool_get_array(mesh, 'xCell', xCell) call mpas_pool_get_array(mesh, 'yCell', yCell) @@ -1996,12 +2038,14 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -2036,6 +2080,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag areaCell(:) = areaCell(:) * a_scale**2.0 areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + nominalMinDc = nominalMinDc * a_scale call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -2143,12 +2188,25 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? d1 = .5*dzw(1) @@ -2540,7 +2598,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag end subroutine init_atm_case_mtn_wave - subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, diag_physics, init_case, dims, configs) + subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, diag_physics, dims, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Real-data test case using GFS data !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2563,7 +2621,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(inout):: diag_physics - integer, intent(in) :: init_case type (mpas_pool_type), intent(inout):: dims type (mpas_pool_type), intent(inout):: configs @@ -2598,7 +2655,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND) :: target_z - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, i, k, nz, cell1, cell2 integer, pointer :: nCellsSolve, nz1 integer :: nInterpPoints, ndims @@ -2612,11 +2669,10 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state integer :: masked !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: j integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, edgesOnCell, cellsOnCell real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell - real (kind=RKIND), dimension(:,:), pointer :: v real (kind=RKIND), dimension(:,:), pointer :: sorted_arr integer, dimension(:), pointer :: bdyMaskCell @@ -2625,7 +2681,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state type (field1DReal), target :: tempFieldTarget real(kind=RKIND), dimension(:), pointer :: hs, hs1, sm0 - real(kind=RKIND) :: hm, hm_global, zh, dzmin, dzmina, dzmina_global, dzminf, dzminf_global, sm + real(kind=RKIND) :: hm, hm_global, zh, dzmin, dzmina, dzminf, dzminf_global, sm real(kind=RKIND) :: dcsum integer :: nsmterrain, kz, sfc_k logical :: hybrid, smooth @@ -2634,46 +2690,31 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND) :: p_check ! For interpolating terrain and land use - integer :: nx, ny integer :: istatus real (kind=RKIND), allocatable, dimension(:,:) :: rslab, maskslab integer, dimension(:), pointer :: mask_array integer, dimension(nEdges), target :: edge_mask - character (len=StrKIND) :: fname logical :: is_sfc_field - real (kind=RKIND) :: flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r + real (kind=RKIND) :: flux real (kind=RKIND) :: lat, lon, x, y - real (kind=RKIND) :: ptop, p0, phi - real (kind=RKIND) :: lon_Edge - - real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str + real (kind=RKIND) :: p0 - real (kind=RKIND), dimension(nVertLevels, nCells) :: rel_hum, temperature, qv - real (kind=RKIND) :: ptmp, es, rs, rgas_moist, qvs, xnutr, znut, ptemp, rcv - integer :: iter + real (kind=RKIND) :: etavs, ztemp, zd, zt, dz, str - real (kind=RKIND), dimension(nVertLevels + 1) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm - real (kind=RKIND), dimension(nVertLevels + 1) :: znuc, znuv, bn, divh, dpn + real (kind=RKIND) :: es, rs, xnutr, znut, rcv real (kind=RKIND), dimension(:), pointer :: specified_zw - real (kind=RKIND), dimension(nVertLevels + 1) :: sh, zw, ah + real (kind=RKIND), dimension(nVertLevels + 1) :: zw, ah real (kind=RKIND), dimension(nVertLevels) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND), dimension(nVertLevels) :: eta, etav, teta, ppi, tt - real (kind=RKIND) :: d1, d2, d3, cof1, cof2, psurf + real (kind=RKIND) :: cof1, cof2 ! storage for (lat,z) arrays for zonal velocity calculation integer, parameter :: nlat=361 - real (kind=RKIND), dimension(nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d - real (kind=RKIND), dimension(nVertLevels) :: flux_zonal - real (kind=RKIND), dimension(nlat, nVertLevels) :: u_2d, etavs_2d - real (kind=RKIND), dimension(nVertLevels + 1) :: fsum - real (kind=RKIND), dimension(nlat) :: lat_2d - real (kind=RKIND) :: dlat real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2 real (kind=RKIND) :: alt, als, zetal, zl @@ -2744,18 +2785,17 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:), pointer :: sm_fg real (kind=RKIND), dimension(:), pointer :: soilz - type (hashtable) :: level_hash + type (hashtable), allocatable :: level_hash logical :: too_many_fg_levs integer :: level_value ! For outputting surface fields u10, v10, q2, rh2, and t2m from first-guess data - real (kind=RKIND), dimension(:), pointer :: u10 - real (kind=RKIND), dimension(:), pointer :: v10 real (kind=RKIND), dimension(:), pointer :: q2 real (kind=RKIND), dimension(:), pointer :: rh2 real (kind=RKIND), dimension(:), pointer :: t2m character (len=StrKIND) :: errstring + character (len=StrKIND), pointer :: config_interface_projection call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) call mpas_pool_get_config(configs, 'config_start_time', config_start_time) @@ -2774,6 +2814,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) call mpas_pool_get_config(configs, 'config_blend_bdy_terrain', config_blend_bdy_terrain) + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) call mpas_pool_get_config(configs, 'config_extrap_airtemp', config_extrap_airtemp) if (trim(config_extrap_airtemp) == 'constant') then @@ -2894,8 +2935,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state omega_e = omega p0 = 1.e+05 - scalars(:,:,:) = 0. - ! ! If requested, blend the terrain along the domain boundaries with terrain from @@ -3125,12 +3164,25 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) @@ -3396,6 +3448,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) end if + allocate(level_hash) call mpas_hash_init(level_hash) too_many_fg_levs = .false. @@ -4200,6 +4253,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call read_met_close() level_value = mpas_hash_size(level_hash) call mpas_hash_destroy(level_hash) + deallocate(level_hash) if (too_many_fg_levs) then write(errstring,'(a,i4)') ' Please increase config_nfglevels to at least ', level_value @@ -4514,9 +4568,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state if (allocated(maskslab)) deallocate(maskslab) - ! Freeze really cold ocean - where (sst < 271.0 .and. landmask == 0) xice = 1.0 - ! Limit XICE to values between 0 and 1. Although the input meteorological field is between 0. ! and 1., interpolation to the MPAS grid can yield values of XiCE less than 0. and greater ! than 1.: @@ -4649,7 +4700,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state do k=1,nVertLevels target_z = 0.25 * (zgrid(k,cellsOnEdge(1,iEdge)) + zgrid(k+1,cellsOnEdge(1,iEdge)) + zgrid(k,cellsOnEdge(2,iEdge)) + zgrid(k+1,cellsOnEdge(2,iEdge))) ! u(k,iEdge) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=0) - u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) + u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) end do end do @@ -5025,8 +5076,6 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels real (kind=RKIND) :: rs, rcv - real (kind=RKIND), dimension(nVertLevels + 1) :: sh - ! calculation of the water vapor mixing ratio: real (kind=RKIND) :: sh_max,sh_min,global_sh_max,global_sh_min @@ -5061,7 +5110,7 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels real (kind=RKIND), dimension(:,:), pointer :: p_fg real (kind=RKIND), dimension(:), pointer :: soilz - type (hashtable) :: level_hash + type (hashtable), allocatable :: level_hash logical :: too_many_fg_levs integer :: level_value @@ -5191,6 +5240,7 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels messageType=MPAS_LOG_CRIT) end if + allocate(level_hash) call mpas_hash_init(level_hash) too_many_fg_levs = .false. @@ -5378,6 +5428,7 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels call read_met_close() level_value = mpas_hash_size(level_hash) call mpas_hash_destroy(level_hash) + deallocate(level_hash) if (too_many_fg_levs) then write(errstring,'(a,i4)') ' Please increase config_nfglevels to at least ', level_value @@ -5740,6 +5791,633 @@ subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels end subroutine init_atm_case_lbc + !----------------------------------------------------------------------- + ! routine init_atm_case_cam_mpas + ! + !> \brief Generate a 3-d grid for use with CAM-MPAS + !> \author Michael Duda + !> \date 20 October 2020 + !> \details + !> Given a unit-sphere SCVT, this initialization case produces an earth-radius + !> mesh with a vertical grid suitable for use with CAM-MPAS. + !> + !> The config_specified_zeta_levels must be set to the name of a text file with + !> zeta levels, the number of which must be one more than config_nvertlevels. + !> + !> Optionally, a mutable stream named 'cam_topo' may also be defined with + !> a single field, PHIS, that provides the surface geopotential to be used in + !> generating the vertical grid. + !> + !> Namelist options used by this routine: + !> * config_specified_zeta_levels + !> * config_nsmterrain + !> * config_nsm + !> * config_smooth_surfaces + !> * config_smooth_dzmin + !> * config_smooth_theta_adv_order + ! + !----------------------------------------------------------------------- + subroutine init_atm_case_cam_mpas(stream_manager, dminfo, block, mesh, & + dims, configs, nVertLevels) + + use mpas_dmpar, only : mpas_dmpar_exch_halo_field, mpas_dmpar_min_real, mpas_dmpar_max_real + use mpas_stream_manager, only : MPAS_stream_mgr_stream_exists, MPAS_stream_mgr_read + use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR + + implicit none + + ! + ! Arguments + ! + type (MPAS_streamManager_type), intent(inout) :: stream_manager + type (dm_info), intent(inout) :: dminfo + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout):: dims + type (mpas_pool_type), intent(inout):: configs + integer, intent(in) :: nVertLevels + + + ! + ! Local variables + ! + integer :: i, j, k + integer :: iCell, iEdge, iVtx + integer :: ierr + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: nCellsSolve + integer, pointer :: nVertices + integer, pointer :: maxEdges + + character (len=StrKIND), pointer :: config_specified_zeta_levels + + real(kind=RKIND), dimension(:), pointer :: specified_zw + + logical, pointer :: on_a_sphere + real(kind=RKIND), pointer :: sphere_radius + + real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real(kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real(kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real(kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real(kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real(kind=RKIND), pointer :: nominalMinDc + + real(kind=RKIND), dimension(:), pointer :: fEdge, fVertex + real(kind=RKIND), dimension(:), pointer :: latEdge + real(kind=RKIND), dimension(:), pointer :: latVertex + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: edgesOnCell + + real(kind=RKIND), dimension(:), pointer :: PHIS + real(kind=RKIND), dimension(:), pointer :: ter + real(kind=RKIND) :: min_ter, max_ter + type (field1DReal), pointer :: ter_field + + real(kind=RKIND), dimension(:), pointer :: hs, hs1 + integer, pointer :: config_nsmterrain + integer :: nsmterrain + + logical :: hybrid + integer :: kz + real(kind=RKIND), dimension(nVertLevels+1) :: zw, ah + real (kind=RKIND), dimension(nVertLevels) :: zu, dzw, rdzwp, rdzwm + real(kind=RKIND), dimension(:,:), pointer :: zgrid + real(kind=RKIND), dimension(:), pointer :: rdzw + real(kind=RKIND), dimension(:), pointer :: dzu + real(kind=RKIND), dimension(:), pointer :: rdzu + real(kind=RKIND), dimension(:), pointer :: fzm + real(kind=RKIND), dimension(:), pointer :: fzp + real(kind=RKIND), dimension(:,:), pointer :: zxu + real(kind=RKIND), dimension(:,:), pointer :: zz + + real(kind=RKIND) :: zh, zt + + real(kind=RKIND), dimension(:,:), pointer :: hx + + real(kind=RKIND) :: cof1, cof2 + real(kind=RKIND), pointer :: cf1, cf2, cf3 + + logical, pointer :: config_smooth_surfaces + integer, pointer :: config_nsm + real(kind=RKIND), pointer :: config_dzmin + + real(kind=RKIND) :: dzmin, dzmina, dzminf, dzminf_global, sm + real(kind=RKIND), dimension(:), pointer :: sm0 + real(kind=RKIND) :: dcsum + + type (field1DReal), pointer :: tempField + type (field1DReal), target :: tempFieldTarget + + integer :: cell1, cell2 + + integer, pointer :: config_theta_adv_order + real(kind=RKIND) :: z_edge, z_edge3 + real(kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2 + real(kind=RKIND), dimension(:,:,:), pointer :: deriv_two + real(kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + + + ! + ! Get dimensions + ! + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nEdges', nEdges) + call mpas_pool_get_dimension(dims, 'nVertices', nVertices) + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + + + ! + ! Scale all distances and areas from a unit sphere to one with radius sphere_radius + ! + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + xCell(:) = xCell(:) * sphere_radius + yCell(:) = yCell(:) * sphere_radius + zCell(:) = zCell(:) * sphere_radius + xVertex(:) = xVertex(:) * sphere_radius + yVertex(:) = yVertex(:) * sphere_radius + zVertex(:) = zVertex(:) * sphere_radius + xEdge(:) = xEdge(:) * sphere_radius + yEdge(:) = yEdge(:) * sphere_radius + zEdge(:) = zEdge(:) * sphere_radius + dvEdge(:) = dvEdge(:) * sphere_radius + dcEdge(:) = dcEdge(:) * sphere_radius + areaCell(:) = areaCell(:) * sphere_radius**2 + areaTriangle(:) = areaTriangle(:) * sphere_radius**2 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * sphere_radius**2 + nominalMinDc = nominalMinDc * sphere_radius + + + ! + ! Initialize Coriolis parameter field on edges and vertices + ! + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'latVertex', latVertex) + + do iEdge=1,nEdges + fEdge(iEdge) = 2.0 * omega * sin(latEdge(iEdge)) + end do + do iVtx=1,nVertices + fVertex(iVtx) = 2.0 * omega * sin(latVertex(iVtx)) + end do + + + ! + ! Compute weights used in advection and deformation calculation + ! + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + + + ! + ! Read PHIS field from cam_topo stream + ! + if (MPAS_stream_mgr_stream_exists(stream_manager, 'cam_topo')) then + call MPAS_stream_mgr_read(stream_manager, 'cam_topo', rightNow=.true., whence=MPAS_STREAM_NEAREST, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Error reading the ''cam_topo'' stream.', messageType=MPAS_LOG_CRIT) + end if + else + call mpas_log_write('') + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_WARN) + call mpas_log_write('No ''cam_topo'' input stream with a PHIS field was defined.', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('The terrain field will be set to zero everywhere. To specify', messageType=MPAS_LOG_WARN) + call mpas_log_write('a non-zero terrain field, define a ''cam_topo'' stream, e.g.,', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write(' ', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_WARN) + call mpas_log_write('') + end if + + + ! + ! Set terrain field based on PHIS + ! + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_array(mesh, 'PHIS', PHIS) + + ter(:) = PHIS(:) / gravity + + call mpas_dmpar_min_real(dminfo, minval(ter(1:nCellsSolve)), min_ter) + call mpas_dmpar_max_real(dminfo, maxval(ter(1:nCellsSolve)), max_ter) + call mpas_log_write('') + call mpas_log_write('Terrain min/max = $r / $r', realArgs=[min_ter, max_ter]) + call mpas_log_write('') + + + ! + ! Read zeta levels from a text file + ! + call mpas_pool_get_config(configs, 'config_specified_zeta_levels', config_specified_zeta_levels) + + call mpas_log_write('Setting up vertical grid using levels from '''//trim(config_specified_zeta_levels)//'''') + + if (read_text_array(dminfo, trim(config_specified_zeta_levels), specified_zw) /= 0) then + call mpas_log_write('Failed to read vertical levels from '''//trim(config_specified_zeta_levels)//'''', & + messageType=MPAS_LOG_CRIT) + end if + + if (size(specified_zw) /= nVertLevels+1) then + call mpas_log_write('In the namelist.init_atmosphere file, config_nvertlevels = $i, ', & + intArgs=(/nVertLevels/), & + messageType=MPAS_LOG_ERR) + call mpas_log_write('but '''//trim(config_specified_zeta_levels)//''' has $i values.', & + intArgs=(/size(specified_zw)/), & + messageType=MPAS_LOG_ERR) + call mpas_log_write(''''//trim(config_specified_zeta_levels)//''' must contain nVertLevels+1 ($i) values.', & + intArgs=(/nVertLevels+1/), & + messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Fourth order smoother for terrain + ! + allocate(hs (nCells+1)) + allocate(hs1(nCells+1)) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_field(mesh, 'ter', ter_field) + call mpas_pool_get_config(configs, 'config_nsmterrain', config_nsmterrain) + nsmterrain = config_nsmterrain + + do i = 1, nsmterrain + + do iCell = 1, nCells + hs(iCell) = 0.0 + if (ter(iCell) /= 0.0) then + do j = 1, nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the terrain value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the terrain in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + ter(nCells+1) = ter(iCell) + end if + + hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) & + / dcEdge(edgesOnCell(j,iCell)) & + * (ter(cellsOnCell(j,iCell))-ter(iCell)) + end do + end if + + hs(iCell) = ter(iCell) + 0.216 * hs(iCell) + end do + + do iCell = 1, nCells + ter(iCell) = 0.0 + if (hs(iCell) /= 0.0) then + do j = 1, nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the terrain value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the terrain in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + hs(nCells+1) = hs(iCell) + end if + + ter(iCell) = ter(iCell) + dvEdge(edgesOnCell(j,iCell)) & + / dcEdge(edgesOnCell(j,iCell)) & + * (hs(cellsOnCell(j,iCell))-hs(iCell)) + end do + end if + + ter(iCell) = hs(iCell) - 0.216 * ter(iCell) + end do + + call mpas_dmpar_exch_halo_field(ter_field) + end do + + call mpas_pool_get_array(mesh, 'hx', hx) + do iCell = 1, nCells + hx(:,iCell) = ter(iCell) + end do + + + ! + ! Metrics for hybrid coordinate and vertical stretching + ! + + zw(:) = specified_zw(:) + zt = zw(nVertLevels+1) + + deallocate(specified_zw) + + +! ah(k) governs the transition between terrain-following +! and pure height coordinates +! ah(k) = 1 is a smoothed terrain-following coordinate +! ah(k) = 1.-zw(k)/zt is the basic terrain-following coordinate +! ah(k) = 0 is a height coordinate + + hybrid = .true. + + kz = nVertLevels+1 + if (hybrid) then + + zh = 30000.0 +! zh = 0.5*zt + + do k = 1, nVertLevels+1 + if (zw(k) < zh) then + ah(k) = cos(0.5*pii*zw(k)/zh)**6 + +!!! ah(k) = ah(k)*(1.0 - zw(k)/zt) + + else + ah(k) = 0.0 + kz = min(kz,k) + end if + end do + + else + + do k = 1, nVertLevels+1 + ah(k) = 1.0 - zw(k)/zt + end do + + end if + + call mpas_log_write('') + call mpas_log_write('k zw(k) ah(k)') + call mpas_log_write('-----------------------------------------') + do k = 1, nVertLevels+1 + call mpas_log_write('$i $r $r', intArgs=(/k/), realArgs=(/zw(k), ah(k)/)) + end do + + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + + do k = 1, nVertLevels + dzw (k) = zw(k+1) - zw(k) + rdzw(k) = 1.0 / dzw(k) + zu(k ) = 0.5*(zw(k) + zw(k+1)) + end do + do k = 2, nVertLevels + dzu(k) = 0.5*(dzw(k) + dzw(k-1)) + rdzu(k) = 1.0 / dzu(k) + fzm(k) = 0.5*dzw(k )/dzu(k) + fzp(k) = 0.5*dzw(k-1)/dzu(k) + rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) + rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) + end do + + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + cof1 = (2.0*dzu(2)+dzu(3))/(dzu(2)+dzu(3))*dzw(1)/dzu(2) + cof2 = dzu(2) /(dzu(2)+dzu(3))*dzw(1)/dzu(3) + cf1 = fzp(2) + cof1 + cf2 = fzm(2) - cof1 - cof2 + cf3 = cof2 + +! d1 = .5*dzw(1) +! d2 = dzw(1)+.5*dzw(2) +! d3 = dzw(1)+dzw(2)+.5*dzw(3) +! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) +! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) +! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) + + + ! + ! Smoothing algorithm for coordinate surfaces + ! + call mpas_pool_get_config(configs, 'config_smooth_surfaces', config_smooth_surfaces) + call mpas_pool_get_config(configs, 'config_nsm', config_nsm) + call mpas_pool_get_config(configs, 'config_dzmin', config_dzmin) + + if (config_smooth_surfaces) then + + dzmin = config_dzmin + + allocate(sm0(nCells+1)) + + do iCell = 1, nCells + dcsum = 0.0 + do j = 1, nEdgesOnCell(iCell) + dcsum = dcsum + dcEdge(edgesOnCell(j,iCell)) + end do + dcsum = dcsum / real(nEdgesOnCell(iCell)) + sm0(iCell) = max(0.01_RKIND, 0.125 * min(1.0_RKIND, 3000.0_RKIND/dcsum)) + end do + + + call mpas_log_write('') + call mpas_log_write('k nsm sm dzminf / dzw') + call mpas_log_write('-----------------------------------------') + + do k = 2, kz-1 + hx(k,:) = hx(k-1,:) + dzminf = zw(k) - zw(k-1) + + do i = 1, config_nsm + k + do iCell = 1, nCells + + sm = sm0(iCell) * min((3.0*zw(k)/zt)**2.0, 1.0_RKIND) + + hs1(iCell) = 0.0 + do j = 1, nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the hx value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the hx in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + hx(k,nCells+1) = hx(k,iCell) + end if + + hs1(iCell) = hs1(iCell) + dvEdge(edgesOnCell(j,iCell)) & + / dcEdge(edgesOnCell(j,iCell)) & + * (hx(k,cellsOnCell(j,iCell))-hx(k,iCell)) + end do + hs(iCell) = hx(k,iCell) + sm*hs1(iCell) + + end do + + tempField => tempFieldTarget + tempField % block => block + tempField % dimSizes(1) = nCells + tempField % sendList => block % parinfo % cellsToSend + tempField % recvList => block % parinfo % cellsToRecv + tempField % copyList => block % parinfo % cellsToCopy + tempField % array => hs + tempField % isActive = .true. + tempField % prev => null() + tempField % next => null() + + call mpas_dmpar_exch_halo_field(tempField) + + do iCell = 1, nCells + dzmina = (zw(k) + ah(k)*hs(iCell)) - (zw(k-1) + ah(k-1)*hx(k-1,iCell)) + if (dzmina > dzmin*(zw(k)-zw(k-1))) then + hx(k,iCell) = hs(iCell) + if (dzmina < dzminf) then + dzminf = dzmina + end if + end if + end do + + end do + call mpas_dmpar_min_real(dminfo, dzminf, dzminf_global) + call mpas_log_write('$i $i $r $r', intArgs=(/k,i/), realArgs=(/sm,dzminf_global/(zw(k)-zw(k-1))/)) + end do + + deallocate(sm0) + + do k = kz, nVertLevels+1 + hx(k,:) = 0.0 + end do + + else + + do k = 2, nVertLevels+1 + dzmina = minval(zw(k)+ah(k)*hx(k,:)-zw(k-1)-ah(k-1)*hx(k-1,:)) + call mpas_log_write('$i $r', intArgs=(/k/), realArgs=(/dzmina/(zw(k)-zw(k-1))/)) + end do + + end if + + deallocate(hs ) + deallocate(hs1) + + + ! + ! Height of coordinate levels (calculation of zgrid) + ! + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'zxu', zxu) + call mpas_pool_get_array(mesh, 'zz', zz) + + do iCell = 1, nCells + do k = 1, nVertLevels+1 + zgrid(k,iCell) = zw(k) + ah(k)*hx(k,iCell) + end do + do k = 1, nVertLevels + zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell)) + end do + end do + + do i = 1, nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) + do k = 1, nVertLevels + zxu (k,i) = 0.5 * (zgrid(k,cell2)-zgrid(k,cell1) + zgrid(k+1,cell2)-zgrid(k+1,cell1)) / dcEdge(i) + end do + end do + + + ! + ! For z-metric term in omega equation + ! + + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! Avoid referencing the garbage cell for exterior edges + if (cell1 == nCells+1) then + cell1 = cell2 + end if + if (cell2 == nCells+1) then + cell2 = cell1 + end if + + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then + + do k = 1, nVertLevels + + if (config_theta_adv_order == 2) then + + z_edge = 0.5 * (zgrid(k,cell1)+zgrid(k,cell2)) + + else !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, nEdgesOnCell(cell1) + if (cellsOnCell(i,cell1) > 0) then + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,cellsOnCell(i,cell1)) + end if + end do + do i = 1, nEdgesOnCell(cell2) + if (cellsOnCell(i,cell2) > 0) then + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,cellsOnCell(i,cell2)) + end if + end do + + z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & + - (dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.0 + + if (config_theta_adv_order == 3) then + z_edge3 = - (dcEdge(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.0 + else + z_edge3 = 0.0 + end if + + 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 if + + end do + + end subroutine init_atm_case_cam_mpas + + integer function nearest_edge(target_lat, target_lon, & start_edge, & nCells, nEdges, maxEdges, nEdgesOnCell, edgesOnCell, cellsOnEdge, latCell, lonCell, latEdge, lonEdge) @@ -5891,25 +6569,13 @@ end function vertical_interp !---------------------------------------------------------------------------------------------------------- - real (kind=RKIND) function env_qv( z, temperature, pressure, rh_max ) + real (kind=RKIND) function env_qv( temperature, pressure, rh_max ) implicit none - real (kind=RKIND) :: z, temperature, pressure, ztr, es, qvs, p0, rh_max + real (kind=RKIND) :: temperature, pressure, 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 @@ -6041,7 +6707,7 @@ subroutine decouple_variables(mesh, nCells, nVertLevels, state, diag) type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag - integer :: iCell, iEdge, k + integer :: iCell, k integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: rdzw diff --git a/src/core_init_atmosphere/mpas_init_atm_core_interface.F b/src/core_init_atmosphere/mpas_init_atm_core_interface.F index 7f478b5ad9..ba68bd2a21 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -115,6 +115,7 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) logical, pointer :: initial_conds, sfc_update, lbcs logical, pointer :: gwd_stage_in, gwd_stage_out, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out logical, pointer :: config_native_gwd_static, config_static_interp, config_vertical_grid, config_met_interp + logical, pointer :: first_guess_field integer, pointer :: config_init_case @@ -224,6 +225,14 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) initial_conds = .false. ! Also, turn off the initial_conds package to avoid writing the IC "output" stream + else if (config_init_case == 13) then + gwd_stage_in = .false. + gwd_stage_out = .false. + vertical_stage_in = .false. + vertical_stage_out = .true. + met_stage_in = .false. + met_stage_out = .false. + else gwd_stage_in = .false. gwd_stage_out = .false. @@ -233,6 +242,18 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) met_stage_out = .true. end if + ! + ! Package for 3-d first-guess atmospheric and land-surface fields is only active if + ! we are interpolating real-data ICs or LBCs + ! + nullify(first_guess_field) + call mpas_pool_get_package(packages, 'first_guess_fieldActive', first_guess_field) + + first_guess_field = .false. + if ((config_init_case == 7 .and. config_met_interp) .or. config_init_case == 9) then + first_guess_field = .true. + end if + end function init_atm_setup_packages @@ -299,15 +320,19 @@ end function init_atm_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ + function init_atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open +#ifdef MPAS_OPENMP + use mpas_threading, only : mpas_threading_get_num_threads +#endif implicit none type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -316,7 +341,7 @@ function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -328,13 +353,55 @@ function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = ior(iErr, local_err) call mpas_log_write('') + call mpas_log_write('MPAS Init-Atmosphere Version '//trim(domain % core % modelVersion)) + call mpas_log_write('') + call mpas_log_write('') + call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) + call mpas_log_write('') + call mpas_log_write('Compile-time options:') + call mpas_log_write(' Build target: '//trim(domain % core % build_target)) + call mpas_log_write(' OpenMP support: ' // & +#ifdef MPAS_OPENMP + 'yes') +#else + 'no') +#endif + call mpas_log_write(' OpenACC support: ' // & +#ifdef MPAS_OPENACC + 'yes') +#else + 'no') +#endif + call mpas_log_write(' Default real precision: ' // & #ifdef SINGLE_PRECISION - call mpas_log_write('Using default single-precision reals') + 'single') +#else + 'double') +#endif + call mpas_log_write(' Compiler flags: ' // & +#ifdef MPAS_DEBUG + 'debug') #else - call mpas_log_write('Using default double-precision reals') + 'optimize') +#endif + call mpas_log_write(' I/O layer: ' // & +#ifdef MPAS_PIO_SUPPORT +#ifdef USE_PIO2 + 'PIO 2.x') +#else + 'PIO 1.x') +#endif +#else + 'SMIOL') #endif call mpas_log_write('') + call mpas_log_write('Run-time settings:') + call mpas_log_write(' MPI task count: $i', intArgs=[domain % dminfo % nprocs]) +#ifdef MPAS_OPENMP + call mpas_log_write(' OpenMP max threads: $i', intArgs=[mpas_threading_get_max_threads()]) +#endif + call mpas_log_write('') end function init_atm_setup_log!}}} diff --git a/src/core_init_atmosphere/mpas_init_atm_gwd.F b/src/core_init_atmosphere/mpas_init_atm_gwd.F index 6d1632f9b2..25ef93c8c6 100644 --- a/src/core_init_atmosphere/mpas_init_atm_gwd.F +++ b/src/core_init_atmosphere/mpas_init_atm_gwd.F @@ -21,7 +21,7 @@ module mpas_init_atm_gwd interface subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, status) bind(C) + wordsize, status) bind(C) use iso_c_binding, only : c_char, c_int, c_float, c_ptr character (c_char), dimension(*), intent(in) :: fname type (c_ptr), value :: rarray @@ -30,7 +30,6 @@ subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & integer (c_int), intent(in), value :: nz integer (c_int), intent(in), value :: isigned integer (c_int), intent(in), value :: endian - real (c_float), intent(in), value :: scalefactor integer (c_int), intent(in), value :: wordsize integer (c_int), intent(inout) :: status end subroutine read_geogrid @@ -116,6 +115,7 @@ function compute_gwd_fields(domain) result(iErr) character(len=StrKIND), pointer :: config_geog_data_path character(len=StrKIND), pointer :: config_topo_data character(len=StrKIND) :: geog_sub_path + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash ! Variables for smoothing variance integer, dimension(:,:), pointer:: cellsOnCell @@ -134,6 +134,12 @@ function compute_gwd_fields(domain) result(iErr) call mpas_pool_get_config(domain % configs, 'config_topo_data', config_topo_data) call mpas_pool_get_config(domain % configs, 'config_gwd_cell_scaling', config_gwd_cell_scaling) + write(geog_data_path, '(a)') config_geog_data_path + i = len_trim(geog_data_path) + if (geog_data_path(i:i) /= '/') then + geog_data_path(i+1:i+1) = '/' + end if + select case(trim(config_topo_data)) case('GTOPO30') call mpas_log_write('--- Using GTOPO30 terrain dataset for GWDO static fields') @@ -188,13 +194,13 @@ function compute_gwd_fields(domain) result(iErr) allocate(hlanduse(nCells+1)) ! +1, since we access hlanduse(cellsOnCell(i,iCell)) later on for iCell=1,nCells - iErr = read_global_30s_topo(config_geog_data_path, geog_sub_path) + iErr = read_global_30s_topo(geog_data_path, geog_sub_path) if (iErr /= 0) then call mpas_log_write('Error reading global 30-arc-sec topography for GWD statistics', messageType=MPAS_LOG_ERR) return end if - iErr = read_global_30s_landuse(config_geog_data_path) + iErr = read_global_30s_landuse(geog_data_path) if (iErr /= 0) then call mpas_log_write('Error reading global 30-arc-sec landuse for GWD statistics', messageType=MPAS_LOG_ERR) return @@ -370,7 +376,8 @@ function read_global_30s_topo(path, sub_path) result(iErr) iy, '-', (iy+tile_y-1) call mpas_f_to_c_string(filename, c_filename) call read_geogrid(c_filename, tile_ptr, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, istatus) + wordsize, istatus) + tile(:,:,:) = tile(:,:,:) * scalefactor if (istatus /= 0) then call mpas_log_write('Error reading topography tile '//trim(filename), messageType=MPAS_LOG_ERR) iErr = 1 @@ -439,7 +446,8 @@ function read_global_30s_landuse(path) result(iErr) iy, '-', (iy+tile_y-1) call mpas_f_to_c_string(filename, c_filename) call read_geogrid(c_filename, tile_ptr, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, istatus) + wordsize, istatus) + tile(:,:,:) = tile(:,:,:) * scalefactor if (istatus /= 0) then call mpas_log_write('Error reading landuse tile '//trim(filename)) iErr = 1 diff --git a/src/core_init_atmosphere/mpas_init_atm_read_met.F b/src/core_init_atmosphere/mpas_init_atm_read_met.F index 510fa4574d..45cd3121b5 100644 --- a/src/core_init_atmosphere/mpas_init_atm_read_met.F +++ b/src/core_init_atmosphere/mpas_init_atm_read_met.F @@ -51,6 +51,7 @@ subroutine read_met_init(fg_source, source_is_constant, datestr, istatus) use mpas_derived_types, only : MPAS_LOG_ERR use mpas_log, only : mpas_log_write + use mpas_io_units, only : mpas_new_unit implicit none @@ -75,11 +76,8 @@ subroutine read_met_init(fg_source, source_is_constant, datestr, istatus) end if ! 2) OPEN FILE - do input_unit=10,100 - inquire(unit=input_unit, opened=is_used) - if (.not. is_used) exit - end do - if (input_unit > 100) call mpas_log_write('In read_met_init(), couldn''t find an available Fortran unit.', messageType=MPAS_LOG_ERR) + call mpas_new_unit(input_unit, unformatted = .true.) + if (input_unit < 0) call mpas_log_write('In read_met_init(), couldn''t find an available Fortran unit.', messageType=MPAS_LOG_ERR) open(unit=input_unit, file=trim(filename), status='old', form='unformatted', iostat=io_status) if (io_status > 0) istatus = 1 @@ -418,9 +416,12 @@ end subroutine read_next_met_field !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine read_met_close() + use mpas_io_units, only : mpas_release_unit + implicit none close(unit=input_unit) + call mpas_release_unit(input_unit) filename = 'UNINITIALIZED_FILENAME' end subroutine read_met_close diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index e72dca987f..92a5613881 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -17,8 +17,12 @@ module mpas_init_atm_static use init_atm_llxy use mpas_c_interfacing, only : mpas_f_to_c_string + use mpas_geometry_utils, only : mpas_in_cell use mpas_atmphys_utilities + use mpas_kd_tree, only : mpas_kd_type, mpas_kd_construct, mpas_kd_free, mpas_kd_search + use mpas_geotile_manager, only : mpas_geotile_mgr_type, mpas_geotile_type, mpas_latlon_to_xyz + use iso_c_binding, only : c_char, c_int, c_float, c_loc, c_ptr implicit none @@ -28,9 +32,14 @@ module mpas_init_atm_static nearest_cell, & sphere_distance +!constants + integer, parameter :: nBdyLayers = 7 ! The number of relaxation layers plus the number of specified layers + ! This value is used in determining whether extra checks are needed + ! in the remapping of terrain, land use, and soil category pixels + interface subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, status) bind(C) + wordsize, status) bind(C) use iso_c_binding, only : c_char, c_int, c_float, c_ptr character (c_char), dimension(*), intent(in) :: fname type (c_ptr), value :: rarray @@ -39,12 +48,59 @@ subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & integer (c_int), intent(in), value :: nz integer (c_int), intent(in), value :: isigned integer (c_int), intent(in), value :: endian - real (c_float), intent(in), value :: scalefactor integer (c_int), intent(in), value :: wordsize integer (c_int), intent(inout) :: status end subroutine read_geogrid end interface + ! Abstract interface for determining if the cell, iCell, needs to be added to the stack + ! for processing. If an interface returns .true., it will indicate to the calling code + ! that the cell has not received any mappings and needs to be processed. Returning .false. + ! will indicate that the cell has received mappings and does not need to be processed. + abstract interface + function interp_criteria_function(iCell) + integer, intent(in) :: iCell + logical :: interp_criteria_function + end function interp_criteria_function + end interface + + ! Abstract interface to accumulate pixel values with the cell they map to. Depending on + ! the dataset, values may need to be accumulated in different ways (continuous vs. + ! categorical) or specific values of a dataset may need to be ignored (for instance, + ! ignoring pixels over water), this routine allows interpolations to differ according + ! to each dataset's needs + abstract interface + subroutine interp_accumulation_function(iCell, pixel) + use mpas_derived_types, only : I8KIND + integer, intent(in) :: iCell + ! Note: Datasets that are have one grid point in the z direction (tile_z = 1) + ! will need to access pixel values as pixel(1) + integer (kind=I8KIND), dimension(:), intent(in) :: pixel + end subroutine interp_accumulation_function + end interface + + ! + ! Module level variables needed for the unified static interpolation function. This is not + ! ideal, a better solution would be to have these variables reside in each interpolation + ! function (e.g. interp_terrain) and then have the criteria and accumulation functions + ! be internal/nested subroutines; however, passing a nested subroutine (internal + ! subroutine) as an actual argument is not allowed in the 2003 standard (Section + ! 12.1.2.2 of the Fortran standard) and currently, only PGI does not support this, so + ! use module level variables for now... + ! + integer (kind=I8KIND), dimension(:), pointer :: ter_integer + integer, dimension(:), pointer :: lu_index + integer, dimension(:), pointer :: soilcat_top + integer, dimension(:), pointer :: nhs + integer, dimension(:,:), allocatable:: ncat + ! Landmask is used by the accumulation function for maxsnoalb so it needs to be a global variable + integer, dimension(:), pointer :: landmask + + integer, pointer :: category_min + integer, pointer :: category_max + + real(kind=RKIND) :: max_kdtree_distance2 + contains !================================================================================================== @@ -56,11 +112,6 @@ subroutine init_atm_static(mesh, dims, configs) type (mpas_pool_type), intent(in) :: dims type (mpas_pool_type), intent(in) :: configs -!constants - integer, parameter :: nBdyLayers = 7 ! The number of relaxation layers plus the number of specified layers - ! This value is used in determining whether extra checks are needed - ! in the remapping of terrain, land use, and soil category pixels - !local variables: type(proj_info):: proj @@ -75,34 +126,29 @@ subroutine init_atm_static(mesh, dims, configs) character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash character(len=StrKIND+1) :: geog_sub_path ! subdirectory names in config_geog_data_path, with trailing slash - integer:: ismax_lu - integer(c_int):: nx,ny,nz integer(c_int):: endian,isigned,istatus,wordsize integer:: i,j,k integer :: ii, jj - integer:: iCell,iEdge,iVtx,iPoint,iTileStart,iTileEnd,jTileStart,jTileEnd + integer:: iCell,iEdge,iVtx integer,dimension(5) :: interp_list integer,dimension(:),allocatable :: nhs - integer,dimension(:,:),allocatable:: ncat - real(kind=c_float):: scalefactor + real(kind=RKIND), pointer :: scalefactor_ptr + real(kind=RKIND) :: scalefactor real(kind=c_float),dimension(:,:,:),pointer,contiguous :: rarray type(c_ptr) :: rarray_ptr - real(kind=RKIND):: start_lat - real(kind=RKIND):: start_lon - integer, pointer :: supersample_fac - real(kind=RKIND):: lat,lon,x,y,z + real(kind=RKIND):: lat,lon,x,y real(kind=RKIND):: lat_pt,lon_pt - real(kind=RKIND),dimension(:,:),allocatable :: soiltemp_1deg real(kind=RKIND),dimension(:,:),allocatable :: maxsnowalb real(kind=RKIND),dimension(:,:,:),allocatable:: vegfra integer, pointer :: isice_lu, iswater_lu - integer, pointer :: nCells, nEdges, nVertices, maxEdges + integer :: iswater_soil + integer, pointer :: nCells, nCellsSolve, nEdges, nVertices, maxEdges logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius @@ -119,14 +165,17 @@ subroutine init_atm_static(mesh, dims, configs) real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge real (kind=RKIND), dimension(:), pointer :: fEdge, fVertex + real (kind=RKIND), pointer :: nominalMinDc - real (kind=RKIND), dimension(:), pointer :: ter - real (kind=RKIND), dimension(:), pointer :: soiltemp + integer (kind=I8KIND), dimension(:,:), pointer :: greenfrac_int real (kind=RKIND), dimension(:), pointer :: snoalb + integer (kind=I8KIND), dimension(:), pointer :: snoalb_integer real (kind=RKIND), dimension(:), pointer :: shdmin, shdmax real (kind=RKIND), dimension(:,:), pointer :: greenfrac real (kind=RKIND), dimension(:,:), pointer :: albedo12m - real (kind=RKIND) :: msgval, fillval + integer (kind=I8KIND), dimension(:,:), pointer :: albedo12m_int + real (kind=RKIND) :: fillval + real (kind=RKIND), pointer :: missing_value integer, dimension(:), pointer :: lu_index integer, dimension(:), pointer :: soilcat_top integer, dimension(:), pointer :: landmask @@ -135,6 +184,23 @@ subroutine init_atm_static(mesh, dims, configs) real (kind=RKIND) :: xPixel, yPixel, zPixel + type (mpas_kd_type), dimension(:), pointer :: kd_points + type (mpas_kd_type), pointer :: tree + type (mpas_kd_type), pointer :: res + + type (mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer :: tile + + integer (kind=I8KIND) :: i8val + integer, pointer :: tile_bdr + integer, pointer :: tile_nx, tile_ny, tile_nz + integer, pointer :: tile_z_start, tile_z_end + + logical :: all_pixels_mapped_to_halo_cells + integer :: ierr + + real(kind=RKIND) :: max_diameter + !-------------------------------------------------------------------------------------------------- @@ -188,14 +254,12 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) - call mpas_pool_get_array(mesh, 'ter', ter) call mpas_pool_get_array(mesh, 'lu_index', lu_index) call mpas_pool_get_array(mesh, 'mminlu', mminlu) call mpas_pool_get_array(mesh, 'isice_lu', isice_lu) call mpas_pool_get_array(mesh, 'iswater_lu', iswater_lu) call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) call mpas_pool_get_array(mesh, 'landmask', landmask) - call mpas_pool_get_array(mesh, 'soiltemp', soiltemp) call mpas_pool_get_array(mesh, 'snoalb', snoalb) call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) @@ -206,10 +270,13 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(dims, 'nEdges', nEdges) call mpas_pool_get_dimension(dims, 'nVertices', nVertices) call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + xCell = xCell * sphere_radius yCell = yCell * sphere_radius zCell = zCell * sphere_radius @@ -225,6 +292,32 @@ subroutine init_atm_static(mesh, dims, configs) areaTriangle = areaTriangle * sphere_radius**2.0 kiteAreasOnVertex = kiteAreasOnVertex * sphere_radius**2.0 + nominalMinDc = nominalMinDc * sphere_radius + +! +! Set max squared distance for k-d tree search to twice the squared cell diameter +! The factor of two is simply a safety factor to account for possible inaccuracies +! in the distance function used in the k-d tree +! + max_diameter = max_cell_diameter(nCells, nEdgesOnCell, verticesOnCell, latCell, lonCell, & + latVertex, lonVertex, sphere_radius) + max_kdtree_distance2 = 2.0_RKIND * max_diameter**2 + +! +! Initialize the KD-Tree +! + allocate(kd_points(nCells)) + do i = 1, nCells + allocate(kd_points(i) % point(3)) + kd_points(i) % point = (/xCell(i), yCell(i), zCell(i)/) + kd_points(i) % id = i ! Cell ID + enddo + tree => null() + tree => mpas_kd_construct(kd_points, 3) + if (.not. associated(tree)) then + call mpas_log_write('Error creating the KD-Tree for static interpolation', messageType=MPAS_LOG_CRIT) + endif + ! ! Initialize Coriolis parameter field on edges and vertices @@ -249,14 +342,8 @@ subroutine init_atm_static(mesh, dims, configs) ! surface_input_select0: select case(trim(config_landuse_data)) case('USGS') - isice_lu = 24 - iswater_lu = 16 - ismax_lu = 24 write(mminlu,'(a)') 'USGS' case('MODIFIED_IGBP_MODIS_NOAH') - isice_lu = 15 - iswater_lu = 17 - ismax_lu = 20 write(mminlu,'(a)') 'MODIFIED_IGBP_MODIS_NOAH' case default call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) @@ -267,36 +354,16 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select surface_input_select0 - ! ! Interpolate HGT ! -!nx = 126 -!ny = 126 - nx = 1206 - ny = 1206 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(nhs(nCells)) - nhs(:) = 0 - ter(:) = 0.0 - - rarray_ptr = c_loc(rarray) - - start_lat = -89.99583 select case(trim(config_topo_data)) case('GTOPO30') call mpas_log_write('Using GTOPO30 terrain dataset') geog_sub_path = 'topo_30s/' - start_lon = -179.99583 case('GMTED2010') call mpas_log_write('Using GMTED2010 terrain dataset') geog_sub_path = 'topo_gmted2010_30s/' - start_lon = 0.004166667 case('default') call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Invalid topography dataset '''//trim(config_topo_data) & @@ -306,66 +373,8 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select - do jTileStart = 1,20401,ny-6 - jTileEnd = jTileStart + ny - 1 - 6 - - do iTileStart=1,42001,nx-6 - iTileEnd = iTileStart + nx - 1 - 6 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)//trim(geog_sub_path), & - iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=4,ny-3 - do i=4,nx-3 - lat_pt = start_lat + (jTileStart + j - 5) * 0.0083333333 - lon_pt = start_lon + (iTileStart + i - 5) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - - ! - ! For all but the outermost boundary cells, we can safely assume that the nearest - ! model grid cell contains the pixel (else, a different cell would be nearest) - ! - if (bdyMaskCell(iPoint) < nBdyLayers) then - ter(iPoint) = ter(iPoint) + rarray(i,j,1) - nhs(iPoint) = nhs(iPoint) + 1 - - ! For outermost boundary cells, additional work is needed to verify that the pixel - ! actually lies within the nearest cell - else - zPixel = sphere_radius * sin(lat_pt) ! Model cell coordinates assume a "full" sphere radius - xPixel = sphere_radius * cos(lon_pt) * cos(lat_pt) ! at this point, so we need to ues the same radius - yPixel = sphere_radius * sin(lon_pt) * cos(lat_pt) ! for source pixel coordinates - - if (in_cell(xPixel, yPixel, zPixel, xCell(iPoint), yCell(iPoint), zCell(iPoint), & - nEdgesOnCell(iPoint), verticesOnCell(:,iPoint), xVertex, yVertex, zVertex)) then - - ter(iPoint) = ter(iPoint) + rarray(i,j,1) - nhs(iPoint) = nhs(iPoint) + 1 - - end if - end if - end do - end do - - end do - end do - - do iCell = 1,nCells - ter(iCell) = ter(iCell) / real(nhs(iCell)) - end do - deallocate(rarray) - deallocate(nhs) + call mpas_log_write('--- start interpolate TER') + call interp_terrain(mesh, tree, trim(geog_data_path)//trim(geog_sub_path)) call mpas_log_write('--- end interpolate TER') @@ -387,174 +396,20 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select surface_input_select1 - nx = 1200 - ny = 1200 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(ncat(ismax_lu,nCells)) - ncat(:,:) = 0 - lu_index(:) = 0.0 - - rarray_ptr = c_loc(rarray) - - do jTileStart = 1,20401,ny - jTileEnd = jTileStart + ny - 1 - - do iTileStart = 1,42001,nx - iTileEnd = iTileStart + nx - 1 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - trim(geog_sub_path),iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=1,ny - do i=1,nx -! -! The MODIS dataset appears to have zeros at the South Pole, possibly other places, too -! -if (rarray(i,j,1) == 0) cycle - - lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333 - lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - - ! - ! For all but the outermost boundary cells, we can safely assume that the nearest - ! model grid cell contains the pixel (else, a different cell would be nearest) - ! - if (bdyMaskCell(iPoint) < nBdyLayers) then - ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 - - ! For outermost boundary cells, additional work is needed to verify that the pixel - ! actually lies within the nearest cell - else - zPixel = sphere_radius * sin(lat_pt) ! Model cell coordinates assume a "full" sphere radius - xPixel = sphere_radius * cos(lon_pt) * cos(lat_pt) ! at this point, so we need to ues the same radius - yPixel = sphere_radius * sin(lon_pt) * cos(lat_pt) ! for source pixel coordinates - - if (in_cell(xPixel, yPixel, zPixel, xCell(iPoint), yCell(iPoint), zCell(iPoint), & - nEdgesOnCell(iPoint), verticesOnCell(:,iPoint), xVertex, yVertex, zVertex)) then - - ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 - - end if - end if - end do - end do - - end do - end do - - do iCell = 1,nCells - lu_index(iCell) = 1 - do i = 2,ismax_lu - if(ncat(i,iCell) > ncat(lu_index(iCell),iCell)) then - lu_index(iCell) = i - end if - end do - end do - deallocate(rarray) - deallocate(ncat) + call mpas_log_write('--- start interpolate LU_INDEX') + call interp_landuse(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), isice_lu, iswater_lu) call mpas_log_write('--- end interpolate LU_INDEX') - ! ! Interpolate SOILCAT_TOP ! - nx = 1200 - ny = 1200 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(ncat(16,nCells)) - ncat(:,:) = 0 - soilcat_top(:) = 0.0 - - rarray_ptr = c_loc(rarray) - - do jTileStart = 1,20401,ny - jTileEnd = jTileStart + ny - 1 - - do iTileStart = 1,42001,nx - iTileEnd = iTileStart + nx - 1 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'soiltype_top_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=1,ny - do i=1,nx - lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333 - lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - - ! - ! For all but the outermost boundary cells, we can safely assume that the nearest - ! model grid cell contains the pixel (else, a different cell would be nearest) - ! - if (bdyMaskCell(iPoint) < nBdyLayers) then - ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 - - ! For outermost boundary cells, additional work is needed to verify that the pixel - ! actually lies within the nearest cell - else - zPixel = sphere_radius * sin(lat_pt) ! Model cell coordinates assume a "full" sphere radius - xPixel = sphere_radius * cos(lon_pt) * cos(lat_pt) ! at this point, so we need to ues the same radius - yPixel = sphere_radius * sin(lon_pt) * cos(lat_pt) ! for source pixel coordinates - - if (in_cell(xPixel, yPixel, zPixel, xCell(iPoint), yCell(iPoint), zCell(iPoint), & - nEdgesOnCell(iPoint), verticesOnCell(:,iPoint), xVertex, yVertex, zVertex)) then - - ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 - - end if - end if - end do - end do - - end do - end do + geog_sub_path = 'soiltype_top_30s/' - do iCell = 1,nCells - soilcat_top(iCell) = 1 - do i = 2,16 - if(ncat(i,iCell) > ncat(soilcat_top(iCell),iCell)) then - soilcat_top(iCell) = i - end if - end do - end do - deallocate(rarray) - deallocate(ncat) + call mpas_log_write('--- start interpolate SOILCAT_TOP') + call interp_soilcat(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), iswater_soil) call mpas_log_write('--- end interpolate SOILCAT_TOP') - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! KLUDGE TO FIX SOIL TYPE OVER ANTARCTICA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -565,14 +420,14 @@ subroutine init_atm_static(mesh, dims, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do iCell = 1,nCells if (lu_index(iCell) == iswater_lu .or. & - soilcat_top(iCell) == 14) then + soilcat_top(iCell) == iswater_soil) then if (lu_index(iCell) /= iswater_lu) then call mpas_log_write('Turning lu_index into water at $i', intArgs=(/iCell/)) lu_index(iCell) = iswater_lu end if - if (soilcat_top(iCell) /= 14) then + if (soilcat_top(iCell) /= iswater_soil) then call mpas_log_write('Turning soilcat_top into water at $i', intArgs=(/iCell/)) - soilcat_top(iCell) = 14 + soilcat_top(iCell) = iswater_soil end if end if end do @@ -581,87 +436,16 @@ subroutine init_atm_static(mesh, dims, configs) ! ! Derive LANDMASK ! - landmask(:) = 0 - do iCell=1, nCells - if (lu_index(iCell) /= iswater_lu) landmask(iCell) = 1 - end do + call mpas_log_write('--- start interpolate LANDMASK') + call derive_landmask(mesh, dims, iswater_lu) call mpas_log_write('--- end interpolate LANDMASK') ! ! Interpolate SOILTEMP: ! - nx = 186 - ny = 186 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.01 - allocate(rarray(nx,ny,nz)) - allocate(soiltemp_1deg(-2:363,-2:183)) - soiltemp(:) = 0.0 - - rarray_ptr = c_loc(rarray) - - call map_set(PROJ_LATLON, proj, & - 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(geog_data_path)// & - 'soiltemp_1deg/',1,'-',180,'.',1,'-',180 - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned, endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - soiltemp_1deg(-2:180,-2:183) = rarray(1:183,1:186,1) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'soiltemp_1deg/',181,'-',360,'.',1,'-',180 - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - soiltemp_1deg(181:363,-2:183) = rarray(4:186,1:186,1) - - interp_list(1) = FOUR_POINT - interp_list(2) = W_AVERAGE4 - interp_list(3) = W_AVERAGE16 - interp_list(4) = SEARCH - interp_list(5) = 0 - - do iCell = 1,nCells - - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - if(x < 0.5) then - lon = lon + 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - else if (x >= 360.5) then - lon = lon - 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - end if - if (y < 1.0) y = 1.0 - if (y > 179.0) y = 179.0 - soiltemp(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, & - 1,1,0.0_RKIND,interp_list,1) - else - soiltemp(iCell) = 0.0 - end if - - end do - deallocate(rarray) - deallocate(soiltemp_1deg) + call mpas_log_write('--- start interpolate SOILTEMP') + call interp_soiltemp(mesh, dims, configs) call mpas_log_write('--- end interpolate SOILTEMP') @@ -670,106 +454,155 @@ subroutine init_atm_static(mesh, dims, configs) ! if (trim(config_maxsnowalbedo_data) == 'MODIS') then + geog_sub_path = 'maxsnowalb_modis/' + call mpas_log_write('Using MODIS 0.05-deg data for maximum snow albedo') if (supersample_fac > 1) then call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac/)) end if - nx = 1206 - ny = 1206 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.01 - msgval = real(-999.0,kind=R4KIND)*real(0.01,kind=R4KIND) - fillval = 0.0 - allocate(rarray(nx,ny,nz)) + ierr = mgr % init(trim(geog_data_path)//trim(geog_sub_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initializing the interpolation of snow albedo (snoalb)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor_ptr) + scalefactor = scalefactor_ptr + allocate(nhs(nCells)) - nhs(:) = 0 + allocate(snoalb_integer(nCells)) + snoalb_integer(:) = 0 snoalb(:) = 0.0 + nhs(:) = 0 + fillval = 0.0 - rarray_ptr = c_loc(rarray) + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) + end if + end if - start_lat = 90.0 - 0.05 * 0.5 / supersample_fac - start_lon = -180.0 + 0.05 * 0.5 / supersample_fac - geog_sub_path = 'maxsnowalb_modis/' + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + do j = supersample_fac * tile_bdr + 1, supersample_fac * (tile_ny + tile_bdr), 1 + do i = supersample_fac * tile_bdr + 1, supersample_fac * (tile_nx + tile_bdr), 1 + + ii = (i - 1) / supersample_fac + 1 + jj = (j - 1) / supersample_fac + 1 + + i8val = int(tile % tile(ii, jj, 1), kind=I8KIND) + + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt, supersample_fac) + call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat_pt, lon_pt) + call mpas_kd_search(tree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) + + if (.not. associated(res)) cycle + + if (bdyMaskCell(res % id) < nBdyLayers) then + ! + ! This field only matters for land cells, and for all but the outermost boundary cells, + ! we can safely assume that the nearest model grid cell contains the pixel (else, a different + ! cell would be nearest). + ! + ! Since values in i8val are not yet scaled, we can compare them to missing_value, which + ! also is not scaled, without scaling either value + if (landmask(res % id) == 1 .and. i8val /= int(missing_value, kind=I8KIND)) then + snoalb_integer(res % id) = snoalb_integer(res % id) + i8val + nhs(res % id) = nhs(res % id) + 1 + end if + + ! + ! When a pixel maps to a non-land cell or is a missing value, the values are not accumulated + ! above; however, these pixels may still reside in an owned cell, in which case we will still need + ! to push the tile's neighbors onto the stack for processing. + ! + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + ! For outermost cells, additional work is needed to verify that the pixel + ! actually lies within the nearest cell + else + if (mpas_in_cell(xPixel, yPixel, zPixel, xCell(res % id), yCell(res % id), zCell(res % id), & + nEdgesOnCell(res % id), verticesOnCell(:,res % id), xVertex, yVertex, zVertex)) then + + ! Since values in i8val are not yet scaled, we can compare them to missing_value, which + ! also is not scaled, without scaling either value + if (landmask(res % id) == 1 .and. i8val /= int(missing_value, kind=I8KIND)) then + snoalb_integer(res % id) = snoalb_integer(res % id) + i8val + nhs(res % id) = nhs(res % id) + 1 + end if + + ! + ! When a pixel maps to a non-land cell or is a missing value, the values are not accumulated + ! above; however, these pixels may still reside in an owned cell, in which case we will still need + ! to push the tile's neighbors onto the stack for processing. + ! + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if + end do + end do - do jTileStart = 1,02401,ny-6 - jTileEnd = jTileStart + ny - 1 - 6 - - do iTileStart=1,06001,nx-6 - iTileEnd = iTileStart + nx - 1 - 6 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)//trim(geog_sub_path), & - iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=supersample_fac * 3 + 1, supersample_fac * (ny-3) - do i=supersample_fac * 3 + 1, supersample_fac * (nx-3) - ii = (i - 1) / supersample_fac + 1 - jj = (j - 1) / supersample_fac + 1 - - lat_pt = start_lat - (supersample_fac*(jTileStart-1) + j - (supersample_fac*3+1)) * 0.05 / supersample_fac - lon_pt = start_lon + (supersample_fac*(iTileStart-1) + i - (supersample_fac*3+1)) * 0.05 / supersample_fac - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - if (rarray(ii,jj,1) /= msgval) then - - ! - ! This field only matters for land cells, and for all but the outermost boundary cells, - ! we can safely assume that the nearest model grid cell contains the pixel (else, a different - ! cell would be nearest) - ! - if (landmask(iPoint) == 1 .and. bdyMaskCell(iPoint) < nBdyLayers) then - snoalb(iPoint) = snoalb(iPoint) + rarray(ii,jj,1) - nhs(iPoint) = nhs(iPoint) + 1 - - ! For outermost land cells, additional work is needed to verify that the pixel - ! actually lies within the nearest cell - else if (landmask(iPoint) == 1) then - zPixel = sphere_radius * sin(lat_pt) ! Model cell coordinates assume a "full" sphere radius - xPixel = sphere_radius * cos(lon_pt) * cos(lat_pt) ! at this point, so we need to ues the same radius - yPixel = sphere_radius * sin(lon_pt) * cos(lat_pt) ! for source pixel coordinates - - if (in_cell(xPixel, yPixel, zPixel, xCell(iPoint), yCell(iPoint), zCell(iPoint), & - nEdgesOnCell(iPoint), verticesOnCell(:,iPoint), xVertex, yVertex, zVertex)) then - snoalb(iPoint) = snoalb(iPoint) + rarray(ii,jj,1) - nhs(iPoint) = nhs(iPoint) + 1 - end if - end if - end if - end do - end do + tile % is_processed = .true. + deallocate(tile % tile) - end do + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing the tile neighbors of: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) + end if + end if + end do end do - do iCell = 1,nCells - ! - ! Mismatches in land mask can lead to MPAS land points with no maximum snow albedo. - ! Ideally, we would perform a search for nearby valid albedos, but for now using - ! the fill value will at least allow the model to run. In general, the number of cells - ! to be treated in this way tends to be a very small fraction of the total number of cells. - ! - if (nhs(iCell) == 0) then - snoalb(iCell) = fillval - else - snoalb(iCell) = snoalb(iCell) / real(nhs(iCell)) - end if - snoalb(iCell) = 0.01_RKIND * snoalb(iCell) ! Convert from percent to fraction + do iCell = 1, nCells + ! + ! Mismatches in land mask can lead to MPAS land points with no maximum snow albedo. + ! Ideally, we would perform a search for nearby valid albedos, but for now using + ! the fill value will at least allow the model to run. In general, the number of cells + ! to be treated in this way tends to be a very small fraction of the total number of cells. + ! + if (nhs(iCell) == 0) then + snoalb(iCell) = fillval + else + snoalb(iCell) = real(real(snoalb_integer(iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + snoalb(iCell) = snoalb(iCell) * scalefactor + snoalb(iCell) = 0.01_RKIND * snoalb(iCell) ! Convert from percent to fraction + endif end do - deallocate(rarray) + deallocate(nhs) + deallocate(snoalb_integer) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of snow albedo (snoalb)', & + messageType=MPAS_LOG_CRIT) + endif else if (trim(config_maxsnowalbedo_data) == 'NCEP') then @@ -802,8 +635,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_f_to_c_string(fname, c_fname) call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) + wordsize,istatus) call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) maxsnowalb(-2:180,-2:183) = rarray(1:183,1:186,1) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -812,8 +646,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_f_to_c_string(fname, c_fname) call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) + wordsize,istatus) call init_atm_check_read_error(istatus, fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) maxsnowalb(181:363,-2:183) = rarray(4:186,1:186,1) interp_list(1) = FOUR_POINT @@ -869,103 +704,137 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('Using MODIS FPAR 30-arc-second data for climatological monthly vegetation fraction') - nx = 1200 - ny = 1200 - nz = 12 - isigned = 0 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - msgval = 200.0 - fillval = 0.0 - allocate(rarray(nx,ny,nz)) + geog_sub_path = 'greenfrac_fpar_modis/' + + ierr = mgr % init(trim(geog_data_path)//trim(geog_sub_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initalizing the interpolation of monthly vegetation fraction (greenfrac)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + allocate(nhs(nCells)) + allocate(greenfrac_int(tile_nz, nCells)) nhs(:) = 0 greenfrac(:,:) = 0.0 + greenfrac_int(:,:) = 0_I8KIND + fillval = 0.0 - rarray_ptr = c_loc(rarray) - - start_lat = -89.99583 - start_lon = -179.99583 - geog_sub_path = 'greenfrac_fpar_modis/' + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile % fname), messageType=MPAS_LOG_CRIT) + end if + end if - do jTileStart = 1,20401,ny - jTileEnd = jTileStart + ny - 1 - - do iTileStart=1,42001,nx - iTileEnd = iTileStart + nx - 1 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)//trim(geog_sub_path), & - iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=1,ny - do i=1,nx - lat_pt = start_lat + (jTileStart + j - 2) * 0.0083333333 - lon_pt = start_lon + (iTileStart + i - 2) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - - ! - ! This field only matters for land cells, and for all but the outermost boundary cells, - ! we can safely assume that the nearest model grid cell contains the pixel (else, a different - ! cell would be nearest) - ! - if (landmask(iPoint) == 1 .and. bdyMaskCell(iPoint) < nBdyLayers) then - do k=1,nz - if (rarray(i,j,k) == msgval) then - rarray(i,j,k) = fillval - end if - greenfrac(k,iPoint) = greenfrac(k,iPoint) + rarray(i,j,k) + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + do j = tile_bdr + 1, tile_ny + tile_bdr, 1 + do i = tile_bdr + 1, tile_nx + tile_bdr, 1 + + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt) + call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat_pt, lon_pt) + call mpas_kd_search(tree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) + + if (.not. associated(res)) cycle + + ! + ! This field only matters for land cells, and for all but the outermost boundary cells, + ! we can safely assume that the nearest model grid cell contains the pixel (else, a different + ! cell would be nearest) + ! + if (landMask(res % id) == 1 .and. bdyMaskCell(res % id) < nBdyLayers) then + do k = 1, tile_nz + if (tile % tile(i, j, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(i,j,k), kind=I8KIND) + end if + greenfrac_int(k, res % id) = greenfrac_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + + ! For outermost land cells, additional work is needed to verify that the pixel + ! actually lies within the nearest cell + else if (landMask(res % id) == 1) then + if (mpas_in_cell(xPixel, yPixel, zPixel, xCell(res % id), yCell(res % id), zCell(res % id), & + nEdgesOnCell(res % id), verticesOnCell(:,res % id), xVertex, yVertex, zVertex)) then + do k = 1, tile_nz + if (tile % tile(i, j, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(i,j,k), kind=I8KIND) + end if + greenfrac_int(k, res % id) = greenfrac_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if end do - nhs(iPoint) = nhs(iPoint) + 1 - - ! For outermost land cells, additional work is needed to verify that the pixel - ! actually lies within the nearest cell - else if (landmask(iPoint) == 1) then - zPixel = sphere_radius * sin(lat_pt) ! Model cell coordinates assume a "full" sphere radius - xPixel = sphere_radius * cos(lon_pt) * cos(lat_pt) ! at this point, so we need to ues the same radius - yPixel = sphere_radius * sin(lon_pt) * cos(lat_pt) ! for source pixel coordinates - - if (in_cell(xPixel, yPixel, zPixel, xCell(iPoint), yCell(iPoint), zCell(iPoint), & - nEdgesOnCell(iPoint), verticesOnCell(:,iPoint), xVertex, yVertex, zVertex)) then - do k=1,nz - if (rarray(i,j,k) == msgval) then - rarray(i,j,k) = fillval - end if - greenfrac(k,iPoint) = greenfrac(k,iPoint) + rarray(i,j,k) - end do - nhs(iPoint) = nhs(iPoint) + 1 + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing the tile neighbors of: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) end if - end if - end do - end do + end if - end do + end do end do - do iCell = 1,nCells - ! For land points that have no overlap with valid data, and for water points, - ! just use the fill value... - if (nhs(iCell) == 0) then - greenfrac(:,iCell) = fillval - else - greenfrac(:,iCell) = greenfrac(:,iCell) / real(nhs(iCell)) - end if - shdmin(iCell) = minval(greenfrac(:,iCell)) - shdmax(iCell) = maxval(greenfrac(:,iCell)) + do iCell = 1, nCells + ! For land points that have no overlap with valid data, and for water points, + ! just use the fill value... + if (nhs(iCell) == 0) then + greenfrac(:,iCell) = fillval + else + greenfrac(:,iCell) = real(real(greenfrac_int(:,iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + end if + shdmin(iCell) = minval(greenfrac(:,iCell)) + shdmax(iCell) = maxval(greenfrac(:,iCell)) end do - deallocate(rarray) + deallocate(nhs) + deallocate(greenfrac_int) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of monthly vegetation fraction (greenfrac)', & + messageType=MPAS_LOG_CRIT) + endif else if (trim(config_vegfrac_data) == 'NCEP') then @@ -998,8 +867,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_f_to_c_string(fname, c_fname) call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) + wordsize,istatus) call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -1008,8 +878,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_f_to_c_string(fname, c_fname) call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) + wordsize,istatus) call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) do iCell = 1,nCells @@ -1065,107 +936,139 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac/)) end if - nx = 1206 - ny = 1206 - nz = 12 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 0.01 - msgval = real(-999.0,kind=R4KIND)*real(0.01,kind=R4KIND) - fillval = 8.0 - allocate(rarray(nx,ny,nz)) + geog_sub_path = 'albedo_modis/' + + ierr = mgr % init(trim(geog_data_path)//trim(geog_sub_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initalizing the interpolation of monthly albedo (albedo12m)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor_ptr) + scalefactor = scalefactor_ptr + + allocate(albedo12m_int(tile_z_start:tile_z_end, nCells)) allocate(nhs(nCells)) - nhs(:) = 0 + albedo12m_int(:,:) = 0 albedo12m(:,:) = 0.0 + nhs(:) = 0 + fillval = 8.0 - rarray_ptr = c_loc(rarray) - - start_lat = 90.0 - 0.05 * 0.5 / supersample_fac - start_lon = -180.0 + 0.05 * 0.5 / supersample_fac - geog_sub_path = 'albedo_modis/' + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile % fname), messageType=MPAS_LOG_CRIT) + end if + end if - do jTileStart = 1,02401,ny-6 - jTileEnd = jTileStart + ny - 1 - 6 - - do iTileStart=1,06001,nx-6 - iTileEnd = iTileStart + nx - 1 - 6 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)//trim(geog_sub_path), & - iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - call mpas_f_to_c_string(fname, c_fname) - - call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=supersample_fac * 3 + 1, supersample_fac * (ny-3) - do i=supersample_fac * 3 + 1, supersample_fac * (nx-3) - ii = (i - 1) / supersample_fac + 1 - jj = (j - 1) / supersample_fac + 1 - - lat_pt = start_lat - (supersample_fac*(jTileStart-1) + j - (supersample_fac*3+1)) * 0.05 / supersample_fac - lon_pt = start_lon + (supersample_fac*(iTileStart-1) + i - (supersample_fac*3+1)) * 0.05 / supersample_fac - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - - ! - ! This field only matters for land cells, and for all but the outermost boundary cells, - ! we can safely assume that the nearest model grid cell contains the pixel (else, a different - ! cell would be nearest) - ! - if (landmask(iPoint) == 1 .and. bdyMaskCell(iPoint) < nBdyLayers) then - do k=1,nz - if (rarray(ii,jj,k) == msgval) then - rarray(ii,jj,k) = fillval - end if - albedo12m(k,iPoint) = albedo12m(k,iPoint) + rarray(ii,jj,k) + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + do j = supersample_fac * tile_bdr + 1, supersample_fac * (tile_ny + tile_bdr), 1 + do i = supersample_fac * tile_bdr + 1, supersample_fac * (tile_nx + tile_bdr), 1 + + ii = (i - 1) / supersample_fac + 1 + jj = (j - 1) / supersample_fac + 1 + + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt, supersample_fac) + call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat_pt, lon_pt) + call mpas_kd_search(tree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) + + if (.not. associated(res)) cycle + + if (bdyMaskCell(res % id) < nBdyLayers) then + if (landMask(res % id) == 1) then + do k = tile_z_start, tile_z_end + if (tile % tile(ii, jj, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(ii,jj,k), kind=I8KIND) + end if + albedo12m_int(k, res % id) = albedo12m_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + end if + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + else + if (mpas_in_cell(xPixel, yPixel, zPixel, xCell(res % id), yCell(res % id), zCell(res % id), & + nEdgesOnCell(res % id), verticesOnCell(:,res % id), xVertex, yVertex, zVertex)) then + if (landMask(res % id) == 1) then + do k = tile_z_start, tile_z_end + if (tile % tile(ii, jj, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(ii,jj,k), kind=I8KIND) + end if + albedo12m_int(k, res % id) = albedo12m_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + end if + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if end do - nhs(iPoint) = nhs(iPoint) + 1 - - ! For outermost land cells, additional work is needed to verify that the pixel - ! actually lies within the nearest cell - else if (landmask(iPoint) == 1) then - zPixel = sphere_radius * sin(lat_pt) ! Model cell coordinates assume a "full" sphere radius - xPixel = sphere_radius * cos(lon_pt) * cos(lat_pt) ! at this point, so we need to ues the same radius - yPixel = sphere_radius * sin(lon_pt) * cos(lat_pt) ! for source pixel coordinates - - if (in_cell(xPixel, yPixel, zPixel, xCell(iPoint), yCell(iPoint), zCell(iPoint), & - nEdgesOnCell(iPoint), verticesOnCell(:,iPoint), xVertex, yVertex, zVertex)) then - do k=1,nz - if (rarray(ii,jj,k) == msgval) then - rarray(ii,jj,k) = fillval - end if - albedo12m(k,iPoint) = albedo12m(k,iPoint) + rarray(ii,jj,k) - end do - nhs(iPoint) = nhs(iPoint) + 1 + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("error pushing the tile neighbors of: "//trim(tile%fname), messagetype=MPAS_LOG_CRIT) end if - end if - end do - end do + end if - end do + end do end do - do iCell = 1,nCells - ! For land points that have no overlap with valid data, and for water points, - ! just use the fill value... - if (nhs(iCell) == 0) then - albedo12m(:,iCell) = fillval - else - albedo12m(:,iCell) = albedo12m(:,iCell) / real(nhs(iCell)) - end if - if (lu_index(iCell) == isice_lu) then - albedo12m(:,iCell) = 70.0 - end if + do iCell = 1, nCells + if (nhs(iCell) == 0) then + albedo12m(:,iCell) = fillVal + else + albedo12m(:,iCell) = real(real(albedo12m_int(:,iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + albedo12m(:,iCell) = albedo12m(:,iCell) * scalefactor + end if + if (lu_index(iCell) == isice_lu) then + albedo12m(:,iCell) = 70.0 ! TODO: Where does this come from? + endif end do - deallocate(rarray) + deallocate(nhs) + deallocate(albedo12m_int) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of monthly albedo (albedo12m)', & + messageType=MPAS_LOG_CRIT) + endif else if (trim(config_albedo_data) == 'NCEP') then @@ -1198,8 +1101,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_f_to_c_string(fname, c_fname) call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor, wordsize, istatus) + wordsize, istatus) call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & @@ -1208,8 +1112,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_f_to_c_string(fname, c_fname) call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) + wordsize,istatus) call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) do iCell = 1,nCells @@ -1251,9 +1156,727 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('--- end interpolate ALBEDO12M') +! +! Deallocate and free the KD Tree +! + call mpas_kd_free(tree) + deallocate(kd_points) + end subroutine init_atm_static + + !*********************************************************************** + ! + ! routine init_atm_map_static_data + ! + !> \brief Map values of static datasets to cells + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Given a initialized geotile manager object, an initialized KD tree of cell centers + !> (xCell, yCell, zCell), and two function pointers, this subroutine maps pixels of a + !> Geogrid binary format dataset to the cells they reside in. The geogrid binary format + !> is described in Chapter 3 of the WRF User's Guide. Because this routine uses a K-Dimensional + !> tree to map pixels to cells, it can safely map datasets to MPAS meshes in parallel. + !> + !> The interp_criteria procedure will need to match the interp_criteria_function abstract + !> interface. The procedure is used to determine if the tile that contains iCell has been + !> processed or not. If it has not, then the tile will be added to the process stack for + !> processing. If a cell has not received any mappings than it is possible the tile that + !> contains that cell has not processed. In that case, the function should return .true. to add + !> the tile to the stack. A value of .false. will signify that the cell has received values, and + !> thus, that the tile that contains that cell does not need to be processed. Different datasets + !> may need to implement this function differently (e.g. continuous vs categorical). + !> + !> The accumulation_method procedure will be called with the mappings between pixel values + !> and the cells in which they map to. Currently, the accumulation_method does not need to + !> return any values. + !> + !> If supersample_fac is present each pixel will be subdivided into supersampel_fac ^ 2 + !> sub-pixels. + ! + !----------------------------------------------------------------------- + subroutine init_atm_map_static_data(mesh, mgr, kdtree, interp_criteria, accumulation_method, supersample_fac) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(in) :: mesh + type (mpas_geotile_mgr_type), intent(in) :: mgr + type (mpas_kd_type), pointer, intent(in) :: kdtree + procedure (interp_criteria_function) :: interp_criteria + procedure (interp_accumulation_function) :: accumulation_method + integer, intent(in), optional :: supersample_fac + + ! Local variables + integer, pointer :: nCells + integer, pointer :: nCellsSolve + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: verticesOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + + integer, pointer :: tile_bdr + integer, pointer :: tile_nx, tile_ny + integer, pointer :: tile_z_start, tile_z_end + integer :: supersample_fac_lcl + integer :: subsample_fac + + real (kind=RKIND) :: lat + real (kind=RKIND) :: lon + real (kind=RKIND) :: xPixel, yPixel, zPixel + real (kind=RKIND), pointer :: scale_factor + + integer :: iCell + integer :: i, ii + integer :: j, jj + + logical :: all_pixels_mapped_to_halo_cells + + type (mpas_geotile_type), pointer :: tile + type (mpas_kd_type), pointer :: res + + integer :: ierr + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scale_factor) + + if (present(supersample_fac)) then + supersample_fac_lcl = supersample_fac + else + supersample_fac_lcl = 1 + end if + + if (supersample_fac_lcl > 1) then + call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac_lcl/)) + end if + + ! Subsample_fac should always be 1, else datasets will not be fully interpolated. + subsample_fac = 1 + + do iCell = 1, nCells + ! + ! Insure all cells receive values by loading tiles that have not received values and + ! pushing them onto the stack. + ! + if (interp_criteria(iCell)) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_ERR) + return + end if + ierr = mgr % push_tile(tile) + end if + + ! + ! Process each tile by removing it from the stack. Determine the closest cell center to each tile + ! pixel by using a KD search and pass the pixel value and the closest cell center id to the + ! accumulation routine. + ! + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + all_pixels_mapped_to_halo_cells = .true. + + do j = supersample_fac_lcl * tile_bdr + 1, supersample_fac_lcl * (tile_ny + tile_bdr), subsample_fac + do i = supersample_fac_lcl * tile_bdr + 1, supersample_fac_lcl * (tile_nx + tile_bdr), subsample_fac + + ! Supersample coordinates + ii = (i - 1) / supersample_fac_lcl + 1 + jj = (j - 1) / supersample_fac_lcl + 1 + + call mgr % tile_to_latlon(tile, j, i, lat, lon, supersample_fac_lcl) + call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat, lon) + call mpas_kd_search(kdtree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) + + if (.not. associated(res)) cycle + + ! + ! For outermost boundary cells, extra work is needed to be done to determine if a pixel actually + ! lies within the cell returned by mpas_kd_search + ! + if (bdyMaskCell(res % id) == nBdyLayers) then + ! mpas_in_cell could be included in the if statement above, but calling it is expensive and the Fortran + ! standard does not require compilers to short circuit compound conditionals. + if (.not. mpas_in_cell(xPixel, yPixel, zPixel, xCell(res % id), yCell(res % id), zCell(res % id), & + nEdgesOnCell(res % id), verticesOnCell(:,res % id), xVertex, yVertex, zVertex)) then + ! + ! This pixel lies outside of res % cell and outside of the limited-area region, no further processing is + ! needed + ! + cycle + end if + end if + + ! + ! Send the entire pixel column to the accumulation method + ! + call accumulation_method(res % id, int(tile % tile(ii,jj,:), kind=I8KIND)) + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end do + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + ! + ! If at least one pixel maps to an owned cell (i.e. <= nCellsSolve) then + ! it is possible that the neighboring tiles might contain pixels that map + ! to this process' compute cells, so add them to the stack. + ! + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + end if + end do + end do + + end subroutine init_atm_map_static_data + + +!-------------------------------------------------------------------------------------------------- +! Terrain interpolation +!-------------------------------------------------------------------------------------------------- + + !*********************************************************************** + ! + ! routine continuous_interp_criteria + ! + !> \brief Continuous dataset interpolation criteria + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine can be used to determine if the tile that contains iCell needs + !> to be loaded and processed by init_atm_map_static_data for continuous datasets. + ! + !----------------------------------------------------------------------- + function continuous_interp_criteria(iCell) + + integer, intent(in) :: iCell + logical :: continuous_interp_criteria + + continuous_interp_criteria = .false. + + if (nhs(iCell) == 0) then + continuous_interp_criteria = .true. + end if + + end function continuous_interp_criteria + + + !*********************************************************************** + ! + ! routine terrain_interp_accumulation + ! + !> \brief Accumulate terrain dataset values + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine accumulates terrain values for the init_atm_map_static_data unified + !> function. + ! + !----------------------------------------------------------------------- + subroutine terrain_interp_accumulation(iCell, pixel) + + integer, intent(in) ::iCell + integer (kind=I8KIND), dimension(:), intent(in) :: pixel + + ter_integer(iCell) = ter_integer(iCell) + int(pixel(1), kind=I8KIND) + nhs(iCell) = nhs(iCell) + 1 + + end subroutine terrain_interp_accumulation + + + !*********************************************************************** + ! + ! routine interp_terrain + ! + !> \brief Interpolate terrain + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Interpolate terrain by using the init_atm_map_static_data routine and + !> accumulating pixel values into cells using terrain_interp_accumulation. + !> mesh, should be a mpas_pool that contains ter and the nCells dimension. kdtree + !> should be a initialized kdtree of (xCell, yCell, zCell), and geog_data_path + !> should be the path to the terrain dataset. + ! + !----------------------------------------------------------------------- + subroutine interp_terrain(mesh, kdtree, geog_data_path) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_kd_type), pointer, intent(in) :: kdtree + character (len=*), intent(in) :: geog_data_path + + ! Local variables + type (mpas_geotile_mgr_type) :: mgr + integer, pointer :: nCells + + real (kind=RKIND), dimension(:), pointer :: ter + + real (kind=RKIND), pointer :: scalefactor + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occurred initializing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + + allocate(ter_integer(nCells)) + allocate(nhs(nCells)) + + ! + ! Store tile values as a I8KIND integer temporarily to avoid floating + ! point round off differences and to have +/- 9.22x10^18 range of representative + ! values. For example, a 120 km mesh with a 1 meter data set with 6 decimal of + ! precision will allow for values of 180x10^12. + ! + ter(:) = 0.0 + ter_integer(:) = 0 + nhs(:) = 0 + + call init_atm_map_static_data(mesh, mgr, kdtree, continuous_interp_criteria, terrain_interp_accumulation) + + do iCell = 1, nCells + ter(iCell) = real(real(ter_integer(iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + ter(iCell) = ter(iCell) * scalefactor + end do + + deallocate(ter_integer) + deallocate(nhs) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write("Error occurred finalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + end subroutine interp_terrain + +!-------------------------------------------------------------------------------------------------- +! Categorical interpolations - Landuse and Soiltype +!-------------------------------------------------------------------------------------------------- + + !*********************************************************************** + ! + ! routine categorical_interp_criteria + ! + !> \brief Categorical dataset interp criteria + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine can be used to determine if the tile that contains iCell needs + !> to be loaded and processed by init_atm_map_static_data for categorical datasets. + ! + !----------------------------------------------------------------------- + function categorical_interp_criteria(iCell) + + integer, intent(in) :: iCell + logical :: categorical_interp_criteria + + categorical_interp_criteria = .false. + + if (all(ncat(:,iCell) == 0)) then + categorical_interp_criteria = .true. + end if + + end function categorical_interp_criteria + + !*********************************************************************** + ! + ! routine categorical_interp_accumulation + ! + !> \brief Accumulate categorical dataset values + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine accumulates categorical values for the init_atm_map_static_data unified + !> function. + ! + !----------------------------------------------------------------------- + subroutine categorical_interp_accumulation(iCell, cat) + + integer, intent(in) :: iCell + integer (kind=I8KIND), dimension(:), intent(in) :: cat + ! Use the module level category_min and category_max variables + + ! + ! Currently, the MODIS landuse dataset has zeros at the South Pole, and possibly other + ! places, so we need a check on the validity of the category to be accumulated. + ! + if (cat(1) >= category_min .and. cat(1) <= category_max) then + ncat(cat(1), iCell) = ncat(cat(1), iCell) + 1 + end if + + end subroutine categorical_interp_accumulation + + !*********************************************************************** + ! + ! routine interp_landuse + ! + !> \brief Interpolate landuse + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Interpolate landuse by using the init_atm_map_static_data routine and + !> accumulating the pixel values into each cell using categorical_interp_accumulation. + !> + !> mesh should be a mpas_pool that contains nCells and lu_index, kdtree should be an + !> initialized mpas_kd_type tree with (xCell, yCell, zCell), and geog_data_path + !> should be the path to the landuse dataset. The values used by this dataset to + !> specify water and ice values will be set in isice_lu, iswater_lu, assuming + !> that isice and iswater are in the dataset's index file. + ! + !----------------------------------------------------------------------- + subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_kd_type), pointer, intent(in) :: kdtree + character (len=*), intent(in) :: geog_data_path + integer, intent(out) :: isice_lu + integer, intent(out) :: iswater_lu + + ! Local variables + type (mpas_geotile_mgr_type) :: mgr + integer, pointer :: nCells + integer, pointer :: isice_lu_ptr + integer, pointer :: iswater_lu_ptr + + real (kind=RKIND), pointer :: scalefactor + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occured initalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + call mpas_pool_get_config(mgr % pool, 'isice', isice_lu_ptr) + call mpas_pool_get_config(mgr % pool, 'iswater', iswater_lu_ptr) + + isice_lu = isice_lu_ptr + iswater_lu = iswater_lu_ptr + + allocate(ncat(category_min:category_max, nCells)) + ncat(:,:) = 0 + + call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation) + + do iCell = 1, nCells + ! Because maxloc returns the location of the maximum value of an array as if the + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + end do + deallocate(ncat) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write("Error occured finalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + nullify(category_min) + nullify(category_max) + + end subroutine interp_landuse + + !*********************************************************************** + ! + ! routine interp_soilcat + ! + !> \brief Interpolate soiltop category + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Interpolate soil category top by using the init_atm_map_static_data routine and + !> accumulating the pixel values into each cell using category_interp_accumulation. + !> + !> mesh should be an mpas_pool that contains and lu_index, kdtree should be an + !> initialized mpas_kd_type tree with (xCell, yCell, zCell), and geog_data_path + !> should be the path to the landuse dataset.The values used by this dataset to + !> signify water will be set in iswater_soil, assuming that + !> iswater is present in the dataset's index file. + !> + !----------------------------------------------------------------------- + subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_kd_type), pointer, intent(in) :: kdtree + character (len=*), intent(in) :: geog_data_path + integer, intent(out) :: iswater_soil + + ! Local variables + type (mpas_geotile_mgr_type) :: mgr + integer, pointer :: nCells + integer, pointer :: iswater_soil_ptr + + real (kind=RKIND), pointer :: scalefactor + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occured initalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + call mpas_pool_get_config(mgr % pool, 'isoilwater', iswater_soil_ptr) + + iswater_soil = iswater_soil_ptr + + allocate(ncat(category_min:category_max, nCells)) + ncat(:,:) = 0 + + call init_atm_map_static_data(mesh, mgr, kdtree, categorical_interp_criteria, categorical_interp_accumulation) + + do iCell = 1, nCells + ! Because maxloc returns the location of the maximum value of an array as if the + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + soilcat_top(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + end do + deallocate(ncat) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write("Error occured finalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return + end if + + nullify(category_min) + nullify(category_max) + + end subroutine interp_soilcat + + !*********************************************************************** + ! + ! routine derive_landmask + ! + !> \brief Derive the landmask field + !> \details + !> Derive the landmask field from lu_index. mesh should be an mpas_pool + !> that contains landmask, and lu_index. iswater_lu should be the value that + !> the landuse dataset uses to signify water. Before calling this function, + !> the landuse dataset will need to be successfully interpolated to lu_index. + ! + !----------------------------------------------------------------------- + subroutine derive_landmask(mesh, dims, iswater_lu) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + integer, intent(in) :: iswater_lu + + ! Local variables + integer :: iCell + integer, pointer :: nCells + integer, dimension(:), pointer :: lu_index + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + + ! + ! Derive LANDMASK + ! + landmask(:) = 0 + do iCell=1, nCells + if (lu_index(iCell) /= iswater_lu) landmask(iCell) = 1 + end do + + end subroutine derive_landmask + + !*********************************************************************** + ! + ! routine interp_soiltemp + ! + !> \brief Interpolate soil temperature + !> \details + !> Interpolate soil temperature by using the soiltemp_1deg/ dataset. The mesh + !> pool should contain latCell, lonCell and soiltemp, dims should contain nCells, + !> and the configs pool should contain config_geog_data_path. + ! + !----------------------------------------------------------------------- + subroutine interp_soiltemp(mesh, dims, configs) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs + + ! Local variables + type (proj_info) :: proj + character (len=StrKIND) :: fname + character (kind=c_char), dimension(StrKIND+1) :: c_fname + character(len=StrKIND), pointer :: config_geog_data_path + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash + real (kind=c_float), dimension(:,:,:), pointer, contiguous :: rarray + real (kind=RKIND) :: scalefactor + real (kind=RKIND), dimension(:), pointer ::latCell, lonCell + real (kind=RKIND) :: lat, lon, x, y + real (kind=RKIND), dimension(:,:), allocatable :: soiltemp_1deg + real (kind=RKIND), dimension(:), pointer :: soiltemp + integer :: i, iCell + integer, pointer :: nCells + integer, dimension(5) :: interp_list + integer (c_int) :: endian, isigned, istatus, wordsize + integer (c_int) :: nx, ny, nz + type (c_ptr) :: rarray_ptr + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'soiltemp', soiltemp) + call mpas_pool_get_config(configs, 'config_geog_data_path', config_geog_data_path) + + write(geog_data_path, '(a)') config_geog_data_path + i = len_trim(geog_data_path) + if (geog_data_path(i:i) /= '/') then + geog_data_path(i+1:i+1) = '/' + end if + + nx = 186 + ny = 186 + nz = 1 + isigned = 0 + endian = 0 + wordsize = 2 + scalefactor = 0.01 + allocate(rarray(nx,ny,nz)) + allocate(soiltemp_1deg(-2:363,-2:183)) + soiltemp(:) = 0.0 + + rarray_ptr = c_loc(rarray) + + call map_set(PROJ_LATLON, proj, & + 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(geog_data_path)// & + 'soiltemp_1deg/',1,'-',180,'.',1,'-',180 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned, endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus, fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + soiltemp_1deg(-2:180,-2:183) = rarray(1:183,1:186,1) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'soiltemp_1deg/',181,'-',360,'.',1,'-',180 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + soiltemp_1deg(181:363,-2:183) = rarray(4:186,1:186,1) + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = W_AVERAGE16 + interp_list(4) = SEARCH + interp_list(5) = 0 + + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD + call latlon_to_ij(proj, lat, lon, x, y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= 360.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 1.0) y = 1.0 + if (y > 179.0) y = 179.0 + soiltemp(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, & + 1,1,0.0_RKIND,interp_list,1) + else + soiltemp(iCell) = 0.0 + end if + + end do + deallocate(rarray) + deallocate(soiltemp_1deg) + + end subroutine interp_soiltemp + !================================================================================================== subroutine init_atm_check_read_error(istatus, fname) !================================================================================================== @@ -1327,145 +1950,39 @@ real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius) end function sphere_distance +!================================================================================================== + real (kind=RKIND) function max_cell_diameter(nCells, nEdgesOnCell, verticesOnCell, latCell, lonCell, & + latVertex, lonVertex, sphere_radius) result(max_diameter) -!----------------------------------------------------------------------- -! routine mirror_point -! -!> \brief Finds the "mirror" of a point about a great-circle arc -!> \author Michael Duda -!> \date 7 March 2019 -!> \details -!> Given the endpoints of a great-circle arc (A,B) and a point, computes -!> the location of the point on the opposite side of the arc along a great- -!> circle arc that intersects (A,B) at a right angle, and such that the arc -!> between the point and its mirror is bisected by (A,B). -!> -!> Assumptions: A, B, and the point to be reflected all lie on the surface -!> of the unit sphere. -! -!----------------------------------------------------------------------- -subroutine mirror_point(xPoint, yPoint, zPoint, xA, yA, zA, xB, yB, zB, xMirror, yMirror, zMirror) - - implicit none - - real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint - real(kind=RKIND), intent(in) :: xA, yA, zA - real(kind=RKIND), intent(in) :: xB, yB, zB - real(kind=RKIND), intent(out) :: xMirror, yMirror, zMirror - - real(kind=RKIND) :: alpha - - ! - ! Find the spherical angle between arcs AP and AB (where P is the point to be reflected) - ! - alpha = sphere_angle(xA, yA, zA, xPoint, yPoint, zPoint, xB, yB, zB) - - ! - ! Rotate the point to be reflected by twice alpha about the vector from the origin to A - ! - call rotate_about_vector(xPoint, yPoint, zPoint, 2.0_RKIND * alpha, 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & - xA, yA, zA, xMirror, yMirror, zMirror) - -end subroutine mirror_point - - -!----------------------------------------------------------------------- -! routine rotate_about_vector -! -!> \brief Rotates a point about a vector in R3 -!> \author Michael Duda -!> \date 7 March 2019 -!> \details -!> Rotates the point (x,y,z) through an angle theta about the vector -!> originating at (a, b, c) and having direction (u, v, w). -! -!> Reference: https://sites.google.com/site/glennmurray/Home/rotation-matrices-and-formulas/rotation-about-an-arbitrary-axis-in-3-dimensions -! -!----------------------------------------------------------------------- -subroutine rotate_about_vector(x, y, z, theta, a, b, c, u, v, w, xp, yp, zp) - - implicit none - - real (kind=RKIND), intent(in) :: x, y, z, theta, a, b, c, u, v, w - real (kind=RKIND), intent(out) :: xp, yp, zp - - real (kind=RKIND) :: vw2, uw2, uv2 - real (kind=RKIND) :: m - - vw2 = v**2.0 + w**2.0 - uw2 = u**2.0 + w**2.0 - uv2 = u**2.0 + v**2.0 - m = sqrt(u**2.0 + v**2.0 + w**2.0) - - xp = (a*vw2 + u*(-b*v-c*w+u*x+v*y+w*z) + ((x-a)*vw2+u*(b*v+c*w-v*y-w*z))*cos(theta) + m*(-c*v+b*w-w*y+v*z)*sin(theta))/m**2.0 - yp = (b*uw2 + v*(-a*u-c*w+u*x+v*y+w*z) + ((y-b)*uw2+v*(a*u+c*w-u*x-w*z))*cos(theta) + m*( c*u-a*w+w*x-u*z)*sin(theta))/m**2.0 - zp = (c*uv2 + w*(-a*u-b*v+u*x+v*y+w*z) + ((z-c)*uv2+w*(a*u+b*v-u*x-v*y))*cos(theta) + m*(-b*u+a*v-v*x+u*y)*sin(theta))/m**2.0 - -end subroutine rotate_about_vector - - -!----------------------------------------------------------------------- -! routine in_cell -! -!> \brief Determines whether a point is within a Voronoi cell -!> \author Michael Duda -!> \date 7 March 2019 -!> \details -!> Given a point on the surface of the sphere, the corner points of a Voronoi -!> cell, and the generating point for that Voronoi cell, determines whether -!> the given point is within the Voronoi cell. -! -!----------------------------------------------------------------------- -logical function in_cell(xPoint, yPoint, zPoint, xCell, yCell, zCell, & - nEdgesOnCell, verticesOnCell, xVertex, yVertex, zVertex) - - use mpas_geometry_utils, only : mpas_arc_length - - implicit none - - real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint - real(kind=RKIND), intent(in) :: xCell, yCell, zCell - integer, intent(in) :: nEdgesOnCell - integer, dimension(:), intent(in) :: verticesOnCell - real(kind=RKIND), dimension(:), intent(in) :: xVertex, yVertex, zVertex - - integer :: i - integer :: vtx1, vtx2 - real(kind=RKIND) :: xNeighbor, yNeighbor, zNeighbor - real(kind=RKIND) :: inDist, outDist - real(kind=RKIND) :: radius - real(kind=RKIND) :: radius_inv - - radius = sqrt(xCell * xCell + yCell * yCell + zCell * zCell) - radius_inv = 1.0_RKIND / radius - - inDist = mpas_arc_length(xPoint, yPoint, zPoint, xCell, yCell, zCell) - - in_cell = .true. - - do i=1,nEdgesOnCell - vtx1 = verticesOnCell(i) - vtx2 = verticesOnCell(mod(i,nEdgesOnCell)+1) - - call mirror_point(xCell*radius_inv, yCell*radius_inv, zCell*radius_inv, & - xVertex(vtx1)*radius_inv, yVertex(vtx1)*radius_inv, zVertex(vtx1)*radius_inv, & - xVertex(vtx2)*radius_inv, yVertex(vtx2)*radius_inv, zVertex(vtx2)*radius_inv, & - xNeighbor, yNeighbor, zNeighbor) - - xNeighbor = xNeighbor * radius - yNeighbor = yNeighbor * radius - zNeighbor = zNeighbor * radius - - outDist = mpas_arc_length(xPoint, yPoint, zPoint, xNeighbor, yNeighbor, zNeighbor) +! Calculate upper bound on maximum diameter of any cell in block owned by this task +!================================================================================================== + implicit none - if (outDist < inDist) then - in_cell = .false. - return - end if + ! Arguments + integer, intent(in) :: nCells + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: verticesOnCell + real(kind=RKIND), dimension(:), intent(in) :: latCell, lonCell + real(kind=RKIND), dimension(:), intent(in) :: latVertex, lonVertex + real(kind=RKIND), intent(in) :: sphere_radius + + ! Local variables + integer :: iCell, j + + + max_diameter = 0.0_RKIND + do iCell = 1, nCells + do j = 1, nEdgesOnCell(iCell) + max_diameter = max(max_diameter, & + sphere_distance(latCell(iCell), lonCell(iCell), & + latVertex(verticesOnCell(j,iCell)), lonVertex(verticesOnCell(j,iCell)), & + sphere_radius)) + end do + end do - end do + max_diameter = 2.0_RKIND * max_diameter -end function in_cell + end function max_cell_diameter !================================================================================================== diff --git a/src/core_init_atmosphere/mpas_kd_tree.F b/src/core_init_atmosphere/mpas_kd_tree.F new file mode 100644 index 0000000000..e1b39dc621 --- /dev/null +++ b/src/core_init_atmosphere/mpas_kd_tree.F @@ -0,0 +1,474 @@ +module mpas_kd_tree + + !*********************************************************************** + ! + ! module mpas_kd_tree + ! + !> \brief MPAS KD-Tree module + !> \author Miles A. Curry + !> \date 01/28/20 + !> A KD-Tree implementation to create and search perfectly balanced + !> KD-Trees. + !> + !> Use `mpas_kd_type` dervied type to construct points for mpas_kd_construct: + !> + !> real (kind=RKIND), dimension(:,:), allocatable :: array + !> type (mpas_kd_type), pointer :: tree => null() + !> type (mpas_kd_type), dimension(:), pointer :: points => null() + !> + !> allocate(array(k,n)) ! K dims and n points + !> allocate(points(n)) + !> array(:,:) = (/.../) ! Fill array with values + !> + !> do i = 1, n + !> allocate(points(i) % point(k)) ! Allocate point with k dimensions + !> points(i) % point(:) = array(:,i) + !> points(i) % id = i ! Or a value of your choice + !> enddo + !> + !> tree => mpas_kd_construct(points, k) + !> + !> call mpas_kd_free(tree) + !> deallocate(points) + !> deallocate(array) + !> + ! + !----------------------------------------------------------------------- + use mpas_kind_types, only : RKIND + + implicit none + + private + + public :: mpas_kd_type + + ! Public Subroutines + public :: mpas_kd_construct + public :: mpas_kd_search + public :: mpas_kd_free + + type mpas_kd_type + type (mpas_kd_type), pointer :: left => null() + type (mpas_kd_type), pointer :: right => null() + + integer :: split_dim + real (kind=RKIND), dimension(:), pointer :: point => null() + + integer :: id + end type mpas_kd_type + + contains + + !*********************************************************************** + ! + ! recursive routine mpas_kd_construct_internal + ! + !> \brief Create a KD-Tree from a set of k-Dimensional points + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Private, recursive function to construct a KD-Tree from an array + !> of mpas_kd_type, points, and return the root of the tree. + !> + !> ndims should be the dimensioned of each individual point found + !> in points and npoints should be the number of points. dim represents + !> the current split dimensioned and is used internally. Upon calling + !> this function, dim should always be set to 0. + ! + !----------------------------------------------------------------------- + recursive function mpas_kd_construct_internal(points, ndims, npoints, dim) result(tree) + + implicit none + + ! Input Variables + type (mpas_kd_type), dimension(:), target :: points + integer, intent(in) :: ndims + integer, value :: npoints + integer, value :: dim + + ! Return Value + type (mpas_kd_type), pointer :: tree + + ! Local Variables + integer :: median + + if (npoints < 1) then + tree => null() + return + endif + + ! Sort the points at the split dimension + dim = mod(dim, ndims) + 1 + call quickSort(points, dim, 1, npoints, ndims) + + median = (1 + npoints) / 2 + + points(median) % split_dim = dim + tree => points(median) + + ! Build the right and left sub-trees but do not include the median + ! point (the root of the current tree) + if (npoints /= 1) then + points(median) % left => mpas_kd_construct_internal(points(1:median-1), ndims, median - 1, points(median) % split_dim) + points(median) % right => mpas_kd_construct_internal(points(median+1:npoints), ndims, npoints - median, & + points(median) % split_dim) + endif + + end function mpas_kd_construct_internal + + + !*********************************************************************** + ! + ! routine mpas_kd_construct + ! + !> \brief Construct a balanced KD-Tree + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Create and return a perfectly balanced KD-Tree from an array of + !> mpas_kd_type, points. The point member of every element of the points + !> array should be allocated and set to the points desired to be in the + !> KD-Tree and ndims should be the dimensions of the points. + !> + !> Upon error, the returned tree will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_kd_construct(points, ndims) result(tree) + + implicit none + + ! Input Varaibles + type (mpas_kd_type), dimension(:) :: points + integer, intent(in) :: ndims + + ! Return Value + type (mpas_kd_type), pointer :: tree + + ! Local Varaibles + integer :: npoints + + npoints = size(points) + + if (npoints < 1) then + tree => null() + return + endif + + tree => mpas_kd_construct_internal(points(:), ndims, npoints, 0) + + end function mpas_kd_construct + + !*********************************************************************** + ! + ! routine break_tie + ! + !> \brief Break a tie for two n-dim points + !> \author Miles A. Curry + !> \date 07/07/20 + !> \details + !> Compare 1..n dimensions of p1 and p2 and return -1 if p1(i) is less than + !> p2(i) and return 1 if p1(i) is greater than p2(i). If p1(i) and p2(i) are + !> equal, then the same comparison will be done on p1(i+1) and p2(i+1) until + !> p1(n) and p2(n). If p1(:) and p2(:) are equal across all n, then 0 will + !> be returned. + ! + !----------------------------------------------------------------------- + function break_tie(p1, p2) result(tie) + + implicit none + + ! Input Variables + type (mpas_kd_type), intent(in) :: p1 + type (mpas_kd_type), intent(in) :: p2 + integer :: tie + + integer :: i + + tie = 0 + do i = 1, size(p1 % point(:)) + if (p1 % point(i) < p2 % point(i)) then + tie = -1 + return + else if (p1 % point(i) > p2 % point(i)) then + tie = 1 + return + endif + enddo + + end function break_tie + + + !*********************************************************************** + ! + ! recursive routine mpas_kd_search_internal + ! + !> \brief Recursively search the KD-Tree for query + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Private, recursive function to search kdtree for query. Upon succes + !> res will point to the nearest neighbor to query and distance will hold + !> the squared distance between query and res. + !> + !> Distance is calculated and compared as squared distance to increase + !> efficiency. + ! + !----------------------------------------------------------------------- + recursive subroutine mpas_kd_search_internal(kdtree, query, res, distance) + + implicit none + + ! Input Variables + type (mpas_kd_type), pointer, intent(in) :: kdtree + real (kind=RKIND), dimension(:), intent(in) :: query + type (mpas_kd_type), pointer, intent(inout) :: res + real (kind=RKIND), intent(inout) :: distance + + ! Local Values + real (kind=RKIND) :: current_distance + + current_distance = sum((kdtree % point(:) - query(:))**2) + if (current_distance < distance) then + distance = current_distance + res => kdtree + else if (current_distance == distance) then + ! + ! Consistently break a tie if a query is equidistant from two points + ! + if (associated(res)) then + if (break_tie(res, kdtree) == 1) then + res => kdtree + endif + endif + endif + + ! + ! To find the nearest neighbor, first serach the tree in a similar manner + ! as a single dimensioned BST, by comparing points on the current split + ! dimension. + ! + ! If the distance between the current node and the query is less then the + ! minimum distance found within the subtree we just searched, then the nearest + ! neighbor might be in the opposite subtree, so search it. + ! + + if (query(kdtree % split_dim) > kdtree % point(kdtree % split_dim)) then + if (associated(kdtree % right)) then ! Search right + call mpas_kd_search_internal(kdtree % right, query, res, distance) + endif + if ((kdtree % point(kdtree % split_dim) - query(kdtree % split_dim))**2 <= distance .and. associated(kdtree % left)) then + call mpas_kd_search_internal(kdtree % left, query, res, distance) ! Check the other subtree + endif + else if (query(kdtree % split_dim) < kdtree % point(kdtree % split_dim)) then + if (associated(kdtree % left)) then ! Search left + call mpas_kd_search_internal(kdtree % left, query, res, distance) + endif + if ((kdtree % point(kdtree % split_dim) - query(kdtree % split_dim))**2 <= distance .and. associated(kdtree % right)) then + call mpas_kd_search_internal(kdtree % right, query, res, distance) ! Check the other subtree + endif + else ! Nearest point could be in either left or right subtree, so search both + if (associated(kdtree % right)) then + call mpas_kd_search_internal(kdtree % right, query, res, distance) + endif + if (associated(kdtree % left)) then + call mpas_kd_search_internal(kdtree % left, query, res, distance) + endif + endif + + end subroutine mpas_kd_search_internal + + !*********************************************************************** + ! + ! routine mpas_kd_search + ! + !> \brief Find the nearest point in a KD-Tree to a query + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Search kdtree and returned the nearest point to query into the + !> res argument, or an unassociated res pointer in case no point in the + !> tree is within a specified maximum distance from any point in the tree. + !> + !> If present, the optional distance argument will contain the squared + !> distance between query and res in the case that res is associated. + !> + !> The optional input argument max_distance, if provided, specifies an + !> upper bound on the distance from the query point for points in the tree + !> to be considered. (Note: the max_distance is more like the maximum + !> squared distance due to implementation details of the kd-tree.) This + !> parameter can be useful, for example, if some query points are known + !> to be far from any point in the tree and in such cases it is desirable + !> to return no closest point. + !> + !> If the dimension of query does not match the dimensions of points + !> within kdtree, then res will be returned as unassociated. Likewise, + !> if kdtree is empty/unassociated, res will be returned as unassociated. + ! + !----------------------------------------------------------------------- + subroutine mpas_kd_search(kdtree, query, res, distance, max_distance) + + implicit none + type (mpas_kd_type), pointer, intent(in) :: kdtree + real (kind=RKIND), dimension(:), intent(in) :: query + type (mpas_kd_type), pointer, intent(inout) :: res + real (kind=RKIND), intent(inout), optional :: distance + real (kind=RKIND), intent(in), optional :: max_distance + + real (kind=RKIND) :: dis + + nullify(res) + + if (.not. associated(kdtree)) then + return + end if + + if (size(kdtree % point) /= size(query)) then + return + endif + + if (present(max_distance)) then + dis = max_distance + else + dis = huge(dis) + endif + + call mpas_kd_search_internal(kdtree, query, res, dis) + + if (present(distance) .and. associated(res)) then + distance = dis + endif + + end subroutine mpas_kd_search + + !*********************************************************************** + ! + ! routine mpas_kd_free + ! + !> \brief Free all nodes within a tree. + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Deallocate and nullify all point nodes of kdtree and nullify the + !> left and right pointers. + !> + !> After calling this function, the array of mpas_kd_type that was used + !> to construct kdtree will still be allocated and will need to be + !> deallocated separate from this routine. + ! + !----------------------------------------------------------------------- + recursive subroutine mpas_kd_free(kdtree) + + implicit none + type (mpas_kd_type), pointer :: kdtree + + if (.not. associated(kdtree)) then + return + endif + + if (associated(kdtree % left)) then + call mpas_kd_free(kdtree % left) + endif + + if (associated(kdtree % right)) then + call mpas_kd_free(kdtree % right) + endif + + deallocate(kdtree % point) + nullify(kdtree % left) + nullify(kdtree % right) + nullify(kdtree) + + end subroutine mpas_kd_free + + + !*********************************************************************** + ! + ! routine mpas_kd_quicksort + ! + !> \brief Sort an array along a dimension + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Sort points starting from arrayStart, to arrayEnd along the given dimension + !> `dim`. If two points are swapped, the entire K-Coordinate point are swapped. + ! + !----------------------------------------------------------------------- + recursive subroutine quickSort(array, dim, arrayStart, arrayEnd, ndims) + + implicit none + + ! Input Variables + type (mpas_kd_type), dimension(:) :: array + integer, intent(in), value :: dim + integer, intent(in), value :: arrayStart, arrayEnd + integer, intent(in) :: ndims + + ! Local Variables + type (mpas_kd_type) :: temp + real (kind=RKIND), dimension(ndims) :: pivot_value + + integer :: l, r, pivot, s + + if ((arrayEnd - arrayStart) < 1) then + return + endif + + ! Create the left, right, and start pointers + l = arrayStart + r = arrayEnd - 1 + s = l + + pivot = (l+r)/2 + pivot_value = array(pivot) % point + + ! Move the pivot to the far right + temp = array(pivot) + array(pivot) = array(arrayEnd) + array(arrayEnd) = temp + + do while (.true.) + ! Advance the left pointer until it is a value less then our pivot_value(dim) + do while (.true.) + if (array(l) % point(dim) < pivot_value(dim)) then + l = l + 1 + else + exit + endif + enddo + + ! Advance the right pointer until it is a value more then our pivot_value(dim) + do while (.true.) + if (r <= 0) then + exit + endif + + if(array(r) % point(dim) >= pivot_value(dim)) then + r = r - 1 + else + exit + endif + enddo + + if (l >= r) then + exit + else ! Swap elements about the pivot + temp = array(l) + array(l) = array(r) + array(r) = temp + endif + enddo + + ! Move the pivot to l ended up + temp = array(l) + array(l) = array(arrayEnd) + array(arrayEnd) = temp + + ! Quick Sort on the lower partition + call quickSort(array(:), dim, s, l-1, ndims) + + ! Quick sort on the upper partition + call quickSort(array(:), dim, l+1, arrayEnd, ndims) + + end subroutine quicksort + +end module mpas_kd_tree diff --git a/src/core_init_atmosphere/mpas_parse_geoindex.F b/src/core_init_atmosphere/mpas_parse_geoindex.F new file mode 100644 index 0000000000..753ed4ee80 --- /dev/null +++ b/src/core_init_atmosphere/mpas_parse_geoindex.F @@ -0,0 +1,256 @@ +module mpas_parse_geoindex + + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_LOG_WARN + use mpas_pool_routines + + implicit none + + private + + public :: mpas_parse_index + + contains + + !*********************************************************************** + ! + ! subroutine mpas_parse_index + ! + !> \brief Parse a geogrid's index file and put the results into an MPAS pool + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Parse an index file of a static data set into an MPAS pool, allocating + !> each keyword=value pair into the pool with the pool member key being + !> keyword, and the value being value. + !> + !> This function can parse index files with one keyword=value pair + !> per line; a "#" at the start of a line, which will cause the line to be + !> ignored; or an empty line containing only a newline/return character, which + !> will also be ignored. Spaces or tabs before, between or after the + !> keyword=value tokens are > ignored. + !> + !> If a line contains anything but the above valid syntaxes, a syntax + !> error will raised and -1 will be returned. + !> + !> Case is ignored. + !> + !> The definitions of a keyword, which can found in section 3-53 + !> of the WRF-AWR User's Guide, will determine the corresponding type + !> of that keyword. A keyword that has been assigned the wrong type + !> will raise a type error and -1 will be returned. + !> + !> Keywords that are not handled explicitly by this function will produce + !> a warning that the keyword is unrecognized. + ! + !----------------------------------------------------------------------- + function mpas_parse_index(path, geo_pool) result(ierr) + + use mpas_io_units + + implicit none + ! Input Variables + character (len=*), intent(in) :: path + type (mpas_pool_type), intent(inout) :: geo_pool + integer :: ierr + + ! Local Variables + character (len=StrKIND) :: line, lhs, rhs + character (len=StrKIND) :: read_err_msg, open_msg + integer :: geo_unit + integer :: open_stat, read_stat, line_read_stat + integer :: i, k + logical :: res + + character (len=StrKIND) :: char_t + integer :: iceiling, ifloor + integer :: int_t + real(kind=RKIND) :: real_t + + ierr = 0 + + inquire(file=trim(path), exist=res) + if ( .not. res) then + call mpas_log_write("Could not find or open the file at: "//trim(path), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_new_unit(geo_unit) + open_stat = 0 + open(geo_unit, FILE=trim(path), action='READ', iostat=open_stat, iomsg=open_msg) + if (open_stat /= 0) then + call mpas_release_unit(geo_unit) + call mpas_log_write("Could not open 'index' file at:'"//trim(path)//"'", messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(open_msg), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + line_read_stat = 0 + read_stat = 0 + k = 1 ! Keep track of line numbers for error reporting + read(geo_unit,'(a)', iostat=line_read_stat) line + do while ( line_read_stat == 0 ) + line = lowercase(line) + + ! + ! If a blank or comment line is encountered, read the next line + ! + if (line(1:1) == '#' .or. len_trim(line) == 0) then + k = k + 1 + read(geo_unit,'(a)', iostat=line_read_stat) line + cycle + endif + + do i = 1, len(trim(line)), 1 + if (line(i:i) == '=') then + lhs = adjustl(trim(line(1:i-1))) + rhs = adjustl(trim(line(i+1:len(trim(line))))) + exit + endif + ! If i is at the end of the string, and we haven't broken out of this loop, + ! then we do not have a '=' present in this line, thus we have a syntax error + if (i == len(trim(line))) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Syntax error on line $i of index file: '"//trim(path)//"'", & + intArgs=(/k/), messageType=MPAS_LOG_ERR) + call mpas_log_write("Line $i: '"//trim(line)//"'", intArgs=(/k/), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + enddo + + ! + ! Strings + ! + if ( trim(lhs) == 'type' & + .or. trim(lhs) == 'projection' & + .or. trim(lhs) == 'units' & + .or. trim(lhs) == 'description' & + .or. trim(lhs) == 'row_order' & + .or. trim(lhs) == 'endian' & + .or. trim(lhs) == 'mminlu' ) then + + char_t = rhs + call mpas_pool_add_config(geo_pool, trim(lhs), char_t) + + ! + ! Reals + ! + else if ( trim(lhs) == 'dx' & + .or. trim(lhs) == 'dy' & + .or. trim(lhs) == 'known_x' & + .or. trim(lhs) == 'known_y' & + .or. trim(lhs) == 'known_lat' & + .or. trim(lhs) == 'known_lon' & + .or. trim(lhs) == 'scale_factor' & + .or. trim(lhs) == 'stdlon' & + .or. trim(lhs) == 'truelat1' & + .or. trim(lhs) == 'truelat2' & + .or. trim(lhs) == 'missing_value' ) then + + read(rhs, *, iostat=read_stat, iomsg=read_err_msg) real_t + call mpas_pool_add_config(geo_pool, trim(lhs), real_t) + + ! + ! Integers + ! + else if ( trim(lhs) == 'tile_x' & + .or. trim(lhs) == 'tile_y' & + .or. trim(lhs) == 'tile_z' & + .or. trim(lhs) == 'tile_z_start' & + .or. trim(lhs) == 'tile_z_end' & + .or. trim(lhs) == 'tile_bdr' & + .or. trim(lhs) == 'wordsize' & + .or. trim(lhs) == 'category_max' & + .or. trim(lhs) == 'category_min' & + .or. trim(lhs) == 'iswater' & + .or. trim(lhs) == 'islake' & + .or. trim(lhs) == 'isice' & + .or. trim(lhs) == 'isurban' & + .or. trim(lhs) == 'isoilwater' & + .or. trim(lhs) == 'filename_digits' ) then + + ! Because each compiler handles reporting type errors when transferring + ! data in a read statement a little bit differently, we will have to type check + ! integer values ourselves. + read(rhs, *, iostat=read_stat, iomsg=read_err_msg) real_t + iceiling = ceiling(real_t) + ifloor = floor(real_t) + if (iceiling /= ifloor) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Type error while reading '"//trim(path)//"'.", messageType=MPAS_LOG_ERR) + call mpas_log_write("Could not convert '"//trim(rhs)//"' to an integer on line $i: '"//trim(line)//"'", & + intArgs=(/k/), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + int_t = int(real_t) + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + + ! + ! Booleans - Yes will be assigned 1, and no will be assigned to 0 + ! + else if (lhs == 'signed') then + if (trim(rhs) == 'yes') then + int_t = 1 + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + else if (trim(rhs) == 'no') then + int_t = 0 + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + else + read_stat = -1 + read_err_msg = "Logical was not correct type" + endif + else + call mpas_log_write("Unrecognized keyword: '"//trim(lhs)//"' on line $i of '"//trim(path)//"'", intArgs=(/k/), & + messageType=MPAS_LOG_WARN) + endif + ! Since read gives us an error string in iomsg on a type error, we + ! can handle all errors for any type in one place + if ( read_stat /= 0) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Type error on line $i of: '"//trim(path)//"'.", intArgs=(/k/), messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(read_err_msg)//": '"//trim(line)//"'", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + k = k + 1 + read(geo_unit,'(a)', iostat=line_read_stat) line + enddo + + close(geo_unit) + call mpas_release_unit(geo_unit) + + end function mpas_parse_index + + + ! Returns a copy of 'str' in which all upper-case letters have been converted + ! to lower-case letters. + function lowercase(str) result(lowerStr) + + character(len=*), intent(in) :: str + character(len=len(str)) :: lowerStr + + integer :: i + integer, parameter :: offset = (iachar('a') - iachar('A')) + + + do i=1,len(str) + if (iachar(str(i:i)) >= iachar('A') .and. iachar(str(i:i)) <= iachar('Z')) then + lowerStr(i:i) = achar(iachar(str(i:i)) + offset) + else + lowerStr(i:i) = str(i:i) + end if + end do + + end function lowercase + + +end module mpas_parse_geoindex diff --git a/src/core_init_atmosphere/mpas_stack.F b/src/core_init_atmosphere/mpas_stack.F new file mode 100644 index 0000000000..7227295a9f --- /dev/null +++ b/src/core_init_atmosphere/mpas_stack.F @@ -0,0 +1,280 @@ +module mpas_stack + + implicit none + + private + + ! Public Subroutines and Structures + public :: mpas_stack_is_empty + public :: mpas_stack_push + public :: mpas_stack_pop + public :: mpas_stack_free + + public :: mpas_stack_type, mpas_stack_payload_type + + type mpas_stack_payload_type + end type mpas_stack_payload_type + + type mpas_stack_type + type (mpas_stack_type), pointer :: next => null() + class (mpas_stack_payload_type), pointer :: payload => null() + end type mpas_stack_type + + !*********************************************************************** + ! + ! module mpas_stack + ! + !> \brief MPAS Stack module + !> \author Miles A. Curry + !> \date 04/04/19 + !> \details + !> + !> Introduction + !> ============== + !> The MPAS stack is a simple, extensible data stack data structure for use + !> within the MPAS atmospheric model. It functions as a wrapper around a + !> polymorphic data structure to provide usage in different areas. + !> + !> + !> Creating a Stack + !> ================== + !> The stack data structure (`type (mpas_stack_type)`) is defined by a single + !> `next` pointer > and a pointer to a `type (mpas_stack_payload_type)`, which + !> is defined as a empty derived type. + !> + !> To use the stack, create a derived type that extends the `mpas_stack_payload_type` + !> type. Define your extended derived type with members that meets your application. + !> + !> For instance: + !> ``` + !> type, extends(mpas_stack_payload_type) :: my_payload_name + !> ! Define the members of your type as you wish + !> end type my_payload_name + !> + !> class (my_payload_name), pointer :: item1 => null(), item2 => null() + !> ``` + !> + !> The extended mpas_stack_payload_type will enable a user defined type to be + !> associated with a stack item. The stack stores references of a payload, thus + !> a single payload can be used in multiple push operations. + !> + !> You will then need to create a stack (or multiple stacks if you desire) as + !> the following: + !> + !> ``` + !> type (mpas_stack_type), pointer :: stack1 => null(), stack2 => null() + !> ``` + !> + !> Pushing onto a Stack + !> ==================== + !> You can push your items onto a stack as: + !> + !> ``` + !> allocate(item1) + !> stack1 => mpas_stack_push(stack1, item1) + !> allocate(item2) + !> stack1 => mpas_stack_push(stack1, item2) + !> ``` + !> + !> Popping an item off of the stack + !> ================================ + !> Popping an item off of the stack will require a bit more work than pushing. + !> Because the payload is a polymorphic class , we will need to use the select + !> case to get our type (or multiple types) back into a usable object: + !> ``` + !> ! The item to pop items into + !> class (mpas_stack_payload_type), pointer :: top + !> type (my_payload_name), pointer :: my_item + !> + !> top => mpas_stack_pop(stack1) + !> select type(top) + !> type is(my_payload_name) + !> my_item => top + !> end select + !> ``` + !> + !> Note: It is recommended to create your own `pop` function so you can reduce + !> the amount of coded needed. An example is provided at the bottom of + !> this module as the function `user_pop(..)` + ! + !----------------------------------------------------------------------- + + contains + + !*********************************************************************** + ! + ! routine mpas_stack_is_empty + ! + !> \brief Returns .true. if the stack is empty, otherwise .false. + !> \author Miles A. Curry + !> \date 01/28/20 + !> Returns .true. If the stack is empty and/or if the stack is unassociated. + ! + !----------------------------------------------------------------------- + function mpas_stack_is_empty(stack) result(is_empty) + + implicit none + type (mpas_stack_type), intent(in), pointer :: stack + logical :: is_empty + + is_empty = .true. + if (associated(stack)) then + is_empty = .false. + return + endif + + end function mpas_stack_is_empty + + !*********************************************************************** + ! + ! routine mpas_stack_push + ! + !> \brief Push an item onto stack + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> + !> Push a mpas_stack_payload_type type, onto `stack` and return the new stack. If + !> `payload` is the first item to be pushed onto the stack, then `stack` + !> should be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_stack_push(stack, payload) result(new_stack) + + implicit none + + type(mpas_stack_type), intent(inout), pointer :: stack + class(mpas_stack_payload_type), intent(inout), target :: payload + + type(mpas_stack_type), pointer :: new_stack + + allocate(new_stack) + new_stack % payload => payload + new_stack % next => stack + + return + + end function mpas_stack_push + + !*********************************************************************** + ! + ! function mpas_stack_pop + ! + !> \brief Pop off the last item added from a stack + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Pop off and return the top item of the stack as a `class mpas_stack_payload_type`. + !> If the stack is empty (or unassociated), then a null `class mpas_stack_payload_type` + !> pointer will be returned. `select type` will need to be used to retrieve + !> any extended members. + ! + !----------------------------------------------------------------------- + function mpas_stack_pop(stack) result(top) + + implicit none + + type (mpas_stack_type), intent(inout), pointer :: stack + type (mpas_stack_type), pointer :: next => null() + class(mpas_stack_payload_type), pointer :: top + + if ( .not. associated(stack)) then + top => null() + return + endif + + top => stack % payload + next => stack % next + deallocate(stack) + stack => next + return + + end function mpas_stack_pop + + !*********************************************************************** + ! + ! function mpas_stack_free + ! + !> \brief Deallocate the entire stack. Optionally deallocate payloads + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Deallocate the entire stack. If free_payload is set to `.true.` or if + !> absent then the payload will be deallocated. If not, then the payload will not + !> be deallocated. Upon success, the stack will be unassociated. + ! + !----------------------------------------------------------------------- + subroutine mpas_stack_free(stack, free_payload) + + implicit none + + type(mpas_stack_type), intent(inout), pointer :: stack + logical, intent(in), optional :: free_payload + logical :: fpl + + type(mpas_stack_type), pointer :: cur + + if (present(free_payload)) then + fpl = free_payload + else + fpl = .true. + endif + + cur => stack + do while(associated(stack)) + stack => stack % next + if ( fpl ) then + deallocate(cur % payload) + endif + deallocate(cur) + cur => stack + enddo + + end subroutine mpas_stack_free + + + !*********************************************************************** + ! + ! Example user-defined pop function + ! + !> \brief Pop off the last item added from a stack and return it as our + !> defined type + !> \author Miles A. Curry + !> \date 01/28/20 + ! + !----------------------------------------------------------------------- + ! function user_pop(stack) result(item) + ! + ! use mpas_stack, only : mpas_stack_type, mpas_stack_payload_type, mpas_stack_pop + ! + ! implicit none + ! + ! type(mpas_stack_type), intent(inout), pointer :: stack + ! + ! type(my_item), pointer :: item ! Our user defined mpas_stack_type + ! + ! ! We will need to use the mpas_stack_payload_type type to use mpas_stack_pop(...) + ! class(mpas_stack_payload_type), pointer :: top + ! + ! ! + ! ! Handle a pop on an empty stack if we want to here + ! ! Note the stack will return null if it is empty. + ! ! + ! if (mpas_stack_is_empty(stack)) then + ! item => null() + ! return + ! endif + ! + ! top => mpas_stack_pop(stack) + ! + ! select type(top) + ! type is(my_item) + ! item => top + ! class default + ! write(0,*) "We got an Error and we should handle it if we need to!!" + ! stop + ! end select + ! + ! end function user_pop + +end module mpas_stack diff --git a/src/core_init_atmosphere/read_geogrid.c b/src/core_init_atmosphere/read_geogrid.c index e6ffc6d305..ec66892bea 100644 --- a/src/core_init_atmosphere/read_geogrid.c +++ b/src/core_init_atmosphere/read_geogrid.c @@ -26,7 +26,7 @@ interface subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, status) bind(C) + wordsize, status) bind(C) use iso_c_binding, only : c_char, c_int, c_float, c_ptr character (c_char), dimension(*), intent(in) :: fname type (c_ptr), value :: rarray @@ -35,7 +35,6 @@ integer (c_int), intent(in), value :: nz integer (c_int), intent(in), value :: isigned integer (c_int), intent(in), value :: endian - real (c_float), intent(in), value :: scalefactor integer (c_int), intent(in), value :: wordsize integer (c_int), intent(inout) :: status end subroutine read_geogrid @@ -51,7 +50,6 @@ int read_geogrid( int nz, /* z-dimension of the array */ int isigned, /* 0=unsigned data, 1=signed data */ int endian, /* 0=big endian, 1=little endian */ - float scalefactor, /* value to multiply array elements by before truncation to integers */ int wordsize, /* number of bytes to use for each array element */ int * status) { @@ -142,12 +140,5 @@ int read_geogrid( free(c); - /* Scale real-valued array by scalefactor */ - if (scalefactor != 1.0) - { - for (i=0; i - + diff --git a/src/core_landice/landice.cmake b/src/core_landice/landice.cmake new file mode 100644 index 0000000000..0d580d7800 --- /dev/null +++ b/src/core_landice/landice.cmake @@ -0,0 +1,79 @@ + +# build_options.mk stuff handled here +list(APPEND CPPDEFS "-DCORE_LANDICE") +list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_landice/shared" "${CMAKE_BINARY_DIR}/core_landice/analysis_members" "${CMAKE_BINARY_DIR}/core_landice/mode_forward") + +# +# Check if building with LifeV, Albany, and/or PHG external libraries +# + +if (LIFEV) + # LifeV can solve L1L2 or FO + list(APPEND CPPDEFS "-DLIFEV" "-DUSE_EXTERNAL_L1L2" "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") +endif() + +# Albany can only solve FO at present +if (ALBANY) + list(APPEND CPPDEFS "-DUSE_EXTERNAL_FIRSTORDER" "-DMPAS_LI_BUILD_INTERFACE") +endif() + +if (LIFEV AND ALBANY) + message(FATAL "Compiling with both LifeV and Albany is not allowed at this time.") +endif() + +# PHG currently requires LifeV +if (PHG AND NOT LIFEV) + message(FATAL "Compiling with PHG requires LifeV at this time.") +endif() + +# PHG can only Stokes at present +if (PHG) + list(APPEND CPPDEFS "-DUSE_EXTERNAL_STOKES" "-DMPAS_LI_BUILD_INTERFACE") +endif() + +# driver (files live in E3SM) +list(APPEND RAW_SOURCES + ../../mpas-albany-landice/driver/glc_comp_mct.F + ../../mpas-albany-landice/driver/glc_cpl_indices.F + ../../mpas-albany-landice/driver/glc_mct_vars.F +) + +# shared +list(APPEND RAW_SOURCES + core_landice/shared/mpas_li_constants.F + core_landice/shared/mpas_li_mask.F + core_landice/shared/mpas_li_setup.F +) + +# analysis members +list(APPEND RAW_SOURCES + core_landice/analysis_members/mpas_li_analysis_driver.F + core_landice/analysis_members/mpas_li_global_stats.F + core_landice/analysis_members/mpas_li_regional_stats.F +) + +# mode forward +list(APPEND RAW_SOURCES + core_landice/mode_forward/mpas_li_core.F + core_landice/mode_forward/mpas_li_core_interface.F + core_landice/mode_forward/mpas_li_time_integration.F + core_landice/mode_forward/mpas_li_time_integration_fe.F + core_landice/mode_forward/mpas_li_diagnostic_vars.F + core_landice/mode_forward/mpas_li_advection.F + core_landice/mode_forward/mpas_li_calving.F + core_landice/mode_forward/mpas_li_statistics.F + core_landice/mode_forward/mpas_li_velocity.F + core_landice/mode_forward/mpas_li_thermal.F + core_landice/mode_forward/mpas_li_iceshelf_melt.F + core_landice/mode_forward/mpas_li_sia.F + core_landice/mode_forward/mpas_li_velocity_simple.F + core_landice/mode_forward/mpas_li_velocity_external.F + core_landice/mode_forward/mpas_li_subglacial_hydro.F +) + +if (CPPDEFS MATCHES ".*MPAS_LI_BUILD_INTERFACE.*") + list(APPEND RAW_SOURCES core_landice/mode_forward/Interface_velocity_solver.cpp) +endif() + +# Generate core input +handle_st_nl_gen("namelist.landice" "streams.landice stream_list.landice. listed" ${CORE_INPUT_DIR} ${CORE_BLDDIR}) diff --git a/src/core_landice/mode_forward/mpas_li_core_interface.F b/src/core_landice/mode_forward/mpas_li_core_interface.F index 665be262f9..db27f38305 100644 --- a/src/core_landice/mode_forward/mpas_li_core_interface.F +++ b/src/core_landice/mode_forward/mpas_li_core_interface.F @@ -190,15 +190,16 @@ end function li_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function li_setup_log(logInfo, domain) result(iErr)!{{{ + function li_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -207,7 +208,7 @@ function li_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index 689775d2f5..c64049a5ea 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function ocn_setup_log(logInfo, domain) result(iErr)!{{{ + function ocn_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -500,7 +501,7 @@ function ocn_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_ocean/ocean.cmake b/src/core_ocean/ocean.cmake new file mode 100644 index 0000000000..287dbb523b --- /dev/null +++ b/src/core_ocean/ocean.cmake @@ -0,0 +1,207 @@ + +# build_options.mk stuff handled here +list(APPEND CPPDEFS "-DCORE_OCEAN") +list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_ocean/BGC" "${CMAKE_BINARY_DIR}/core_ocean/shared" "${CMAKE_BINARY_DIR}/core_ocean/analysis_members" "${CMAKE_BINARY_DIR}/core_ocean/cvmix" "${CMAKE_BINARY_DIR}/core_ocean/mode_forward" "${CMAKE_BINARY_DIR}/core_ocean/mode_analysis" "${CMAKE_BINARY_DIR}/core_ocean/mode_init") + +# driver (files live in E3SM) +list(APPEND RAW_SOURCES + ../../mpas-ocean/driver/ocn_comp_mct.F + ../../mpas-ocean/driver/mpaso_cpl_indices.F + ../../mpas-ocean/driver/mpaso_mct_vars.F +) + +# dycore +list(APPEND RAW_SOURCES + core_ocean/mode_forward/mpas_ocn_forward_mode.F + core_ocean/mode_forward/mpas_ocn_time_integration.F + core_ocean/mode_forward/mpas_ocn_time_integration_rk4.F + core_ocean/mode_forward/mpas_ocn_time_integration_split.F + + core_ocean/mode_analysis/mpas_ocn_analysis_mode.F + + core_ocean/mode_init/mpas_ocn_init_mode.F + core_ocean/mode_init/mpas_ocn_init_spherical_utils.F + core_ocean/mode_init/mpas_ocn_init_vertical_grids.F + core_ocean/mode_init/mpas_ocn_init_cell_markers.F + core_ocean/mode_init/mpas_ocn_init_interpolation.F + core_ocean/mode_init/mpas_ocn_init_ssh_and_landIcePressure.F + core_ocean/mode_init/mpas_ocn_init_baroclinic_channel.F + core_ocean/mode_init/mpas_ocn_init_lock_exchange.F + core_ocean/mode_init/mpas_ocn_init_dam_break.F + core_ocean/mode_init/mpas_ocn_init_internal_waves.F + core_ocean/mode_init/mpas_ocn_init_overflow.F + core_ocean/mode_init/mpas_ocn_init_cvmix_WSwSBF.F + core_ocean/mode_init/mpas_ocn_init_iso.F + core_ocean/mode_init/mpas_ocn_init_soma.F + core_ocean/mode_init/mpas_ocn_init_ziso.F + core_ocean/mode_init/mpas_ocn_init_sub_ice_shelf_2D.F + core_ocean/mode_init/mpas_ocn_init_periodic_planar.F + core_ocean/mode_init/mpas_ocn_init_ecosys_column.F + core_ocean/mode_init/mpas_ocn_init_sea_mount.F + core_ocean/mode_init/mpas_ocn_init_global_ocean.F + core_ocean/mode_init/mpas_ocn_init_isomip.F + core_ocean/mode_init/mpas_ocn_init_hurricane.F + core_ocean/mode_init/mpas_ocn_init_isomip_plus.F + core_ocean/mode_init/mpas_ocn_init_tidal_boundary.F + + core_ocean/shared/mpas_ocn_init_routines.F + core_ocean/shared/mpas_ocn_gm.F + core_ocean/shared/mpas_ocn_diagnostics.F + core_ocean/shared/mpas_ocn_diagnostics_routines.F + core_ocean/shared/mpas_ocn_thick_ale.F + core_ocean/shared/mpas_ocn_equation_of_state.F + core_ocean/shared/mpas_ocn_equation_of_state_jm.F + core_ocean/shared/mpas_ocn_equation_of_state_linear.F + core_ocean/shared/mpas_ocn_thick_hadv.F + core_ocean/shared/mpas_ocn_thick_vadv.F + core_ocean/shared/mpas_ocn_thick_surface_flux.F + core_ocean/shared/mpas_ocn_vel_hadv_coriolis.F + core_ocean/shared/mpas_ocn_vel_vadv.F + core_ocean/shared/mpas_ocn_vel_hmix.F + core_ocean/shared/mpas_ocn_vel_hmix_del2.F + core_ocean/shared/mpas_ocn_vel_hmix_leith.F + core_ocean/shared/mpas_ocn_vel_hmix_del4.F + core_ocean/shared/mpas_ocn_vel_forcing.F + core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.F + core_ocean/shared/mpas_ocn_vel_forcing_explicit_bottom_drag.F + core_ocean/shared/mpas_ocn_vel_pressure_grad.F + core_ocean/shared/mpas_ocn_vmix.F + core_ocean/shared/mpas_ocn_vmix_coefs_const.F + core_ocean/shared/mpas_ocn_vmix_coefs_rich.F + core_ocean/shared/mpas_ocn_vmix_coefs_tanh.F + core_ocean/shared/mpas_ocn_vmix_coefs_redi.F + core_ocean/shared/mpas_ocn_vmix_cvmix.F + core_ocean/shared/mpas_ocn_tendency.F + core_ocean/shared/mpas_ocn_tracer_hmix.F + core_ocean/shared/mpas_ocn_tracer_hmix_del2.F + core_ocean/shared/mpas_ocn_tracer_hmix_del4.F + core_ocean/shared/mpas_ocn_tracer_hmix_redi.F + core_ocean/shared/mpas_ocn_tracer_advection.F + core_ocean/shared/mpas_ocn_tracer_advection_mono.F + core_ocean/shared/mpas_ocn_tracer_advection_std.F + core_ocean/shared/mpas_ocn_tracer_nonlocalflux.F + core_ocean/shared/mpas_ocn_tracer_short_wave_absorption.F + core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_jerlov.F + core_ocean/shared/mpas_ocn_tracer_short_wave_absorption_variable.F + core_ocean/shared/mpas_ocn_tracer_surface_restoring.F + core_ocean/shared/mpas_ocn_tracer_interior_restoring.F + core_ocean/shared/mpas_ocn_tracer_exponential_decay.F + core_ocean/shared/mpas_ocn_tracer_ideal_age.F + core_ocean/shared/mpas_ocn_tracer_TTD.F + core_ocean/shared/mpas_ocn_tracer_ecosys.F + core_ocean/shared/mpas_ocn_tracer_DMS.F + core_ocean/shared/mpas_ocn_tracer_MacroMolecules.F + core_ocean/shared/mpas_ocn_high_freq_thickness_hmix_del2.F + core_ocean/shared/mpas_ocn_tracer_surface_flux_to_tend.F + core_ocean/shared/mpas_ocn_test.F + core_ocean/shared/mpas_ocn_constants.F + core_ocean/shared/mpas_ocn_forcing.F + core_ocean/shared/mpas_ocn_surface_bulk_forcing.F + core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.F + core_ocean/shared/mpas_ocn_effective_density_in_land_ice.F + core_ocean/shared/mpas_ocn_frazil_forcing.F + core_ocean/shared/mpas_ocn_tidal_forcing.F + core_ocean/shared/mpas_ocn_time_average_coupled.F + core_ocean/shared/mpas_ocn_sea_ice.F + core_ocean/shared/mpas_ocn_framework_forcing.F + core_ocean/shared/mpas_ocn_time_varying_forcing.F + core_ocean/shared/mpas_ocn_wetting_drying.F + core_ocean/shared/mpas_ocn_tidal_potential_forcing.F +) + +set(OCEAN_DRIVER + core_ocean/driver/mpas_ocn_core.F + core_ocean/driver/mpas_ocn_core_interface.F +) +list(APPEND RAW_SOURCES ${OCEAN_DRIVER}) +list(APPEND DISABLE_QSMP ${OCEAN_DRIVER}) + +# Get CVMix +execute_process(COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/core_ocean/get_cvmix.sh + WORKING_DIRECTORY ${CORE_BLDDIR}) + +# Get BGC +execute_process(COMMAND ${CMAKE_CURRENT_SOURCE_DIR}/core_ocean/get_BGC.sh + WORKING_DIRECTORY ${CORE_BLDDIR}) + +# Add CVMix +set(CVMIX_FILES + ${CORE_BLDDIR}/cvmix/cvmix_kinds_and_types.F90 + ${CORE_BLDDIR}/cvmix/cvmix_background.F90 + ${CORE_BLDDIR}/cvmix/cvmix_convection.F90 + ${CORE_BLDDIR}/cvmix/cvmix_ddiff.F90 + ${CORE_BLDDIR}/cvmix/cvmix_kpp.F90 + ${CORE_BLDDIR}/cvmix/cvmix_math.F90 + ${CORE_BLDDIR}/cvmix/cvmix_put_get.F90 + ${CORE_BLDDIR}/cvmix/cvmix_shear.F90 + ${CORE_BLDDIR}/cvmix/cvmix_tidal.F90 + ${CORE_BLDDIR}/cvmix/cvmix_utils.F90 +) + +# Add BGC +set(BGC_FILES + ${CORE_BLDDIR}/BGC/BGC_mod.F90 + ${CORE_BLDDIR}/BGC/BGC_parms.F90 + ${CORE_BLDDIR}/BGC/DMS_mod.F90 + ${CORE_BLDDIR}/BGC/DMS_parms.F90 + ${CORE_BLDDIR}/BGC/MACROS_mod.F90 + ${CORE_BLDDIR}/BGC/MACROS_parms.F90 + ${CORE_BLDDIR}/BGC/co2calc.F90 +) + +list(APPEND RAW_SOURCES ${CVMIX_FILES} ${BGC_FILES}) +list(APPEND NO_PREPROCESS ${CVMIX_FILES} ${BGC_FILES}) + +# Add analysis members +list(APPEND RAW_SOURCES + core_ocean/analysis_members/mpas_ocn_global_stats.F + core_ocean/analysis_members/mpas_ocn_okubo_weiss.F + core_ocean/analysis_members/mpas_ocn_okubo_weiss_eigenvalues.c + core_ocean/analysis_members/mpas_ocn_layer_volume_weighted_averages.F + core_ocean/analysis_members/mpas_ocn_surface_area_weighted_averages.F + core_ocean/analysis_members/mpas_ocn_water_mass_census.F + core_ocean/analysis_members/mpas_ocn_meridional_heat_transport.F + core_ocean/analysis_members/mpas_ocn_test_compute_interval.F + core_ocean/analysis_members/mpas_ocn_high_frequency_output.F + core_ocean/analysis_members/mpas_ocn_zonal_mean.F + core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_interpolations.F + core_ocean/analysis_members/mpas_ocn_particle_list.F + core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking_reset.F + core_ocean/analysis_members/mpas_ocn_lagrangian_particle_tracking.F + core_ocean/analysis_members/mpas_ocn_eliassen_palm.F + core_ocean/analysis_members/mpas_ocn_time_filters.F + core_ocean/analysis_members/mpas_ocn_mixed_layer_depths.F + core_ocean/analysis_members/mpas_ocn_pointwise_stats.F + core_ocean/analysis_members/mpas_ocn_debug_diagnostics.F + core_ocean/analysis_members/mpas_ocn_time_series_stats.F + core_ocean/analysis_members/mpas_ocn_regional_stats.F + core_ocean/analysis_members/mpas_ocn_rpn_calculator.F + core_ocean/analysis_members/mpas_ocn_transect_transport.F + core_ocean/analysis_members/mpas_ocn_eddy_product_variables.F + core_ocean/analysis_members/mpas_ocn_moc_streamfunction.F + core_ocean/analysis_members/mpas_ocn_analysis_driver.F +) + +# add accelerator/gpu flags +list(APPEND ADD_ACC_FLAGS + core_ocean/shared/mpas_ocn_equation_of_state_jm.f90 + core_ocean/shared/mpas_ocn_mesh.f90 + core_ocean/shared/mpas_ocn_surface_bulk_forcing.f90 + core_ocean/shared/mpas_ocn_surface_land_ice_fluxes.f90 + core_ocean/shared/mpas_ocn_tendency.f90 + core_ocean/shared/mpas_ocn_vel_forcing_explicit_bottom_drag.f90 + core_ocean/shared/mpas_ocn_vel_forcing_surface_stress.f90 + core_ocean/shared/mpas_ocn_vel_hadv_coriolis.f90 + core_ocean/shared/mpas_ocn_vel_hmix_del2.f90 + core_ocean/shared/mpas_ocn_vel_hmix_del4.f90 + core_ocean/shared/mpas_ocn_vel_hmix_leith.f90 + core_ocean/shared/mpas_ocn_vel_pressure_grad.f90 + core_ocean/shared/mpas_ocn_vel_vadv.f90 +) + +# Generate core input +handle_st_nl_gen( + "namelist.ocean;namelist.ocean.forward mode=forward;namelist.ocean.analysis mode=analysis;namelist.ocean.init mode=init" + "streams.ocean stream_list.ocean. mutable;streams.ocean.forward stream_list.ocean.forward. mutable mode=forward;streams.ocean.analysis stream_list.ocean.analysis. mutable mode=analysis;streams.ocean.init stream_list.ocean.init. mutable mode=init" + ${CORE_INPUT_DIR} ${CORE_BLDDIR} +) diff --git a/src/core_seaice/Registry.xml b/src/core_seaice/Registry.xml index d502221a15..6a07ca9d2b 100644 --- a/src/core_seaice/Registry.xml +++ b/src/core_seaice/Registry.xml @@ -1,5 +1,5 @@ - + and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function seaice_setup_log(logInfo, domain) result(iErr)!{{{ + function seaice_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -690,7 +691,7 @@ function seaice_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_seaice/seaice.cmake b/src/core_seaice/seaice.cmake new file mode 100644 index 0000000000..0ac2b0dd49 --- /dev/null +++ b/src/core_seaice/seaice.cmake @@ -0,0 +1,108 @@ + +# build_options.mk stuff handled here +list(APPEND CPPDEFS "-DCORE_SEAICE" "-Dcoupled" "-DCCSMCOUPLED") +list(APPEND INCLUDES "${CMAKE_BINARY_DIR}/core_seaice/column" "${CMAKE_BINARY_DIR}/core_seaice/shared" "${CMAKE_BINARY_DIR}/core_seaice/analysis_members" "${CMAKE_BINARY_DIR}/core_seaice/model_forward") + + +# driver (files live in E3SM) +list(APPEND RAW_SOURCES + ../../mpas-seaice/driver/ice_comp_mct.F + ../../mpas-seaice/driver/mpassi_cpl_indices.F + ../../mpas-seaice/driver/mpassi_mct_vars.F +) + +# column +list(APPEND RAW_SOURCES + core_seaice/column/ice_colpkg.F90 + core_seaice/column/ice_kinds_mod.F90 + core_seaice/column/ice_warnings.F90 + core_seaice/column/ice_colpkg_shared.F90 + core_seaice/column/constants/cesm/ice_constants_colpkg.F90 + core_seaice/column/ice_therm_shared.F90 + core_seaice/column/ice_orbital.F90 + core_seaice/column/ice_mushy_physics.F90 + core_seaice/column/ice_therm_mushy.F90 + core_seaice/column/ice_atmo.F90 + core_seaice/column/ice_age.F90 + core_seaice/column/ice_firstyear.F90 + core_seaice/column/ice_flux_colpkg.F90 + core_seaice/column/ice_meltpond_cesm.F90 + core_seaice/column/ice_meltpond_lvl.F90 + core_seaice/column/ice_meltpond_topo.F90 + core_seaice/column/ice_therm_vertical.F90 + core_seaice/column/ice_therm_bl99.F90 + core_seaice/column/ice_therm_0layer.F90 + core_seaice/column/ice_itd.F90 + core_seaice/column/ice_colpkg_tracers.F90 + core_seaice/column/ice_therm_itd.F90 + core_seaice/column/ice_shortwave.F90 + core_seaice/column/ice_mechred.F90 + core_seaice/column/ice_aerosol.F90 + core_seaice/column/ice_brine.F90 + core_seaice/column/ice_algae.F90 + core_seaice/column/ice_zbgc.F90 + core_seaice/column/ice_zbgc_shared.F90 + core_seaice/column/ice_zsalinity.F90 + core_seaice/column/ice_snow.F90 +) + +# shared +list(APPEND RAW_SOURCES + core_seaice/shared/mpas_seaice_time_integration.F + core_seaice/shared/mpas_seaice_advection_incremental_remap_tracers.F + core_seaice/shared/mpas_seaice_advection_incremental_remap.F + core_seaice/shared/mpas_seaice_advection_upwind.F + core_seaice/shared/mpas_seaice_advection.F + core_seaice/shared/mpas_seaice_velocity_solver_unit_tests.F + core_seaice/shared/mpas_seaice_velocity_solver.F + core_seaice/shared/mpas_seaice_velocity_solver_weak.F + core_seaice/shared/mpas_seaice_velocity_solver_variational.F + core_seaice/shared/mpas_seaice_velocity_solver_wachspress.F + core_seaice/shared/mpas_seaice_velocity_solver_pwl.F + core_seaice/shared/mpas_seaice_velocity_solver_variational_shared.F + core_seaice/shared/mpas_seaice_velocity_solver_constitutive_relation.F + core_seaice/shared/mpas_seaice_forcing.F + core_seaice/shared/mpas_seaice_initialize.F + core_seaice/shared/mpas_seaice_testing.F + core_seaice/shared/mpas_seaice_unit_test.F + core_seaice/shared/mpas_seaice_mesh.F + core_seaice/shared/mpas_seaice_diagnostics.F + core_seaice/shared/mpas_seaice_numerics.F + core_seaice/shared/mpas_seaice_constants.F + core_seaice/shared/mpas_seaice_column.F + core_seaice/shared/mpas_seaice_diagnostics.F + core_seaice/shared/mpas_seaice_error.F +) + +# analysis members +list(APPEND RAW_SOURCES + core_seaice/analysis_members/mpas_seaice_analysis_driver.F + core_seaice/analysis_members/mpas_seaice_high_frequency_output.F + core_seaice/analysis_members/mpas_seaice_temperatures.F + core_seaice/analysis_members/mpas_seaice_regional_statistics.F + core_seaice/analysis_members/mpas_seaice_ridging_diagnostics.F + core_seaice/analysis_members/mpas_seaice_conservation_check.F + core_seaice/analysis_members/mpas_seaice_geographical_vectors.F + core_seaice/analysis_members/mpas_seaice_ice_present.F + core_seaice/analysis_members/mpas_seaice_time_series_stats.F + core_seaice/analysis_members/mpas_seaice_load_balance.F + core_seaice/analysis_members/mpas_seaice_maximum_ice_presence.F + core_seaice/analysis_members/mpas_seaice_miscellaneous.F + core_seaice/analysis_members/mpas_seaice_area_variables.F + core_seaice/analysis_members/mpas_seaice_pond_diagnostics.F + core_seaice/analysis_members/mpas_seaice_deactivate_unneeded_fields.F + core_seaice/analysis_members/mpas_seaice_pointwise_stats.F + core_seaice/analysis_members/mpas_seaice_unit_conversion.F + core_seaice/analysis_members/mpas_seaice_ice_shelves.F +) + +# model_forward (DISABLE qsmp for these) +set(SEAICE_MODEL_FORWARD + core_seaice/model_forward/mpas_seaice_core.F + core_seaice/model_forward/mpas_seaice_core_interface.F +) +list(APPEND RAW_SOURCES ${SEAICE_MODEL_FORWARD}) +list(APPEND DISABLE_QSMP ${SEAICE_MODEL_FORWARD}) + +# Generate core input +handle_st_nl_gen("namelist.seaice" "streams.seaice stream_list.seaice. listed" ${CORE_INPUT_DIR} ${CORE_BLDDIR}) diff --git a/src/core_sw/Registry.xml b/src/core_sw/Registry.xml index 0dc4f768cf..8b69a19521 100644 --- a/src/core_sw/Registry.xml +++ b/src/core_sw/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_sw/mpas_sw_core_interface.F b/src/core_sw/mpas_sw_core_interface.F index ce0b8d5fa1..7596acf82a 100644 --- a/src/core_sw/mpas_sw_core_interface.F +++ b/src/core_sw/mpas_sw_core_interface.F @@ -188,15 +188,16 @@ end function sw_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function sw_setup_log(logInfo, domain) result(iErr)!{{{ + function sw_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -205,7 +206,7 @@ function sw_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/core_sw/mpas_sw_time_integration.F b/src/core_sw/mpas_sw_time_integration.F index 31ece470c2..39c2a73880 100644 --- a/src/core_sw/mpas_sw_time_integration.F +++ b/src/core_sw/mpas_sw_time_integration.F @@ -175,17 +175,54 @@ subroutine sw_rk4(domain, dt) block => block % next end do - + ! Fourth-order Runge-Kutta, solving dy/dt = f(t,y) is typically written as follows + ! dt is the large time step. Here f(t,y) is the right hand side, + ! called the tendencies in the code below. + ! k_1 = f(t_n , y_n) + ! k_2 = f(t_n + dt/2, y_n + dt/2 k_1) + ! k_3 = f(t_n + dt/2, y_n + dt/2 k_2) + ! k_4 = f(t_n + dt , y_n + dt k_3) + ! y_{n+1} = y_n + dt( 1/6 k_1 + 1/3 k_2 + 1/3 k_3 + 1/6 k_4 ) + + ! in index notation: + ! k_{j+1} = f(t_n + a_j dt, y_n + a_j dt k_j) + ! y_{n+1} = y_n + dt sum ( b_j k_j ) + + ! The algorithm here uses a provisional set of the state variables, yp, + ! to hold y_n + a_j dt k_j. The RK4 algorithm is then + + ! yp = y_n prep provisional + ! y_{n+1} = y_n prep new solution + ! do j = 1,4 + ! halo_exch(some diagnostics) + ! tp = t_n + a_j*dt provisional time + ! k_j = f(tp,yp) compute tendencies + ! halo_exch(k_j) update tendencies halo + ! if j<4 + ! yp = y_n + a_{j+1}*dt*k_j compute provisional for next stage + ! endif + ! compute diagnostics based on yp + ! y_{n+1} = y_{n+1} + b_j*dt*k_j accumulate final solution + ! enddo + ! compute diagnostics based on y_{n+1} + + ! Final solution weights + ! b_j = (1/6, 1/3, 1/3, 1/6) + ! and are initialized here as dt * b_j: rk_weights(1) = dt/6. rk_weights(2) = dt/3. rk_weights(3) = dt/3. rk_weights(4) = dt/6. + ! Provisional solution weights for each stage are typically written + ! a_j = (0, 1/2, 1/2, 1). + ! However, in the algorithm below we pre-compute the state for the tendency one + ! iteration early, so it is + ! a = (1/2, 1/2, 1) rk_substep_weights(1) = dt/2. rk_substep_weights(2) = dt/2. rk_substep_weights(3) = dt - rk_substep_weights(4) = 0. - + rk_substep_weights(4) = 0. ! This coefficient is not used. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN RK loop @@ -201,6 +238,8 @@ subroutine sw_rk4(domain, dt) end if ! --- compute tendencies + ! In RK4 notation, we are computing the right hand side f(t,y), + ! which is the same as k_j / h. block => domain % blocklist do while (associated(block)) @@ -221,6 +260,7 @@ subroutine sw_rk4(domain, dt) call mpas_dmpar_field_halo_exch(domain, 'tend_tracers') ! --- compute next substep state + ! In RK4 notation, we are computing y_n + a_j k_j. if (rk_step < 4) then block => domain % blocklist @@ -249,6 +289,13 @@ subroutine sw_rk4(domain, dt) hProvis(:,:) = hOld(:,:) + rk_substep_weights(rk_step) * hTend(:,:) do iCell = 1, nCells do k = 1, nVertLevels + ! The tracer timestep is applied to T*h, but we are only + ! solving for the tracer T here, so we divide by the + ! thickness. + ! Tp = ( h_n*T_n + a_k * dt * tend ) / hp + ! Tp*hp = h_n*T_n + a_k * dt * tend + ! Note that tracersTend has units of tracer*thickness/time, + ! and here tracersProvis has units of just tracer. tracersProvis(:,k,iCell) = ( hOld(k,iCell) * tracersOld(:,k,iCell) & + rk_substep_weights(rk_step) * tracersTend(:,k,iCell) & ) / hProvis(k,iCell) @@ -263,6 +310,10 @@ subroutine sw_rk4(domain, dt) end if !--- accumulate update (for RK4) + ! In RK4 notation, we are computing b_j k_j and adding it to an accumulating sum + ! so that we have + ! y_{n+1} = y_n + sum ( b_j k_j ) + ! after the fourth iteration. block => domain % blocklist do while (associated(block)) @@ -289,6 +340,10 @@ subroutine sw_rk4(domain, dt) hNew(:,:) = hNew(:,:) + rk_weights(rk_step) * hTend(:,:) do iCell = 1, nCells do k = 1, nVertLevels + ! Here, tracersNew is actually the thickness-weighted tracer, + ! T*h. We accumulate the final tracer sum here as T*h, and then + ! divide out the h below. Note that the tracer tendency has + ! units of tracer*thickness/time. tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersTend(:,k,iCell) end do end do diff --git a/src/core_test/Makefile b/src/core_test/Makefile index d784b4fcef..d47059490c 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -6,7 +6,8 @@ OBJS = mpas_test_core.o \ mpas_test_core_streams.o \ mpas_test_core_field_tests.o \ mpas_test_core_timekeeping_tests.o \ - mpas_test_core_sorting.o + mpas_test_core_sorting.o \ + mpas_halo_testing.o all: core_test @@ -33,7 +34,9 @@ post_build: mpas_test_core_interface.o: mpas_test_core.o -mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o mpas_test_core_field_tests.o mpas_test_core_timekeeping_tests.o mpas_test_core_sorting.o +mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o \ + mpas_test_core_field_tests.o mpas_test_core_timekeeping_tests.o \ + mpas_test_core_sorting.o mpas_halo_testing.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index e6f12148ad..9d2aeeced3 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + diff --git a/src/core_test/mpas_halo_testing.F b/src/core_test/mpas_halo_testing.F new file mode 100644 index 0000000000..447663ffaf --- /dev/null +++ b/src/core_test/mpas_halo_testing.F @@ -0,0 +1,286 @@ +! Copyright (c) 2023, The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at http://mpas-dev.github.com/license.html . +! +module mpas_halo_testing + + private + + public :: mpas_halo_tests + + contains + + !*********************************************************************** + ! + ! routine mpas_halo_tests + ! + !> \brief Tests functionality of the mpas_halo module + !> \author Michael Duda + !> \date 31 May 2023 + !> \details + !> This routine tests the functionality of the mpas_halo module by building + !> different halo exchange groups, exchanging halos for fields in those + !> groups, and checking the values in the halos. + !> + !> If no errors are encountered, the ierr argument is set to 0; otherwise, + !> ierr is set to a positive integer. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_tests(domain, ierr) + + use mpas_derived_types, only : domain_type, mpas_pool_type, field2DReal, field3DReal + use mpas_kind_types, only : StrKIND, RKIND + use mpas_log, only : mpas_log_write + use mpas_dmpar, only : mpas_dmpar_max_int + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_field, mpas_pool_get_array, & + mpas_pool_get_dimension + use mpas_field_routines, only : mpas_allocate_scratch_field, mpas_deallocate_scratch_field + use mpas_halo + + implicit none + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: ierr + + integer :: j, k + real (kind=RKIND) :: diff + integer :: ierr_local, ierr_global + character(len=StrKIND) :: test_mesg + type (mpas_pool_type), pointer :: haloExchTest_pool + type (mpas_pool_type), pointer :: mesh_pool + type (field2DReal), pointer :: scratch_2d + type (field3DReal), pointer :: scratch_3d + real (kind=RKIND), dimension(:,:), pointer :: array_2d + real (kind=RKIND), dimension(:,:,:), pointer :: array_3d + integer, dimension(:), pointer :: indexToCellID + integer, pointer :: nCells, nCellsSolve + + + ierr = 0 + ierr_local = 0 + + + nullify(haloExchTest_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'haloExchTest', haloExchTest_pool) + + nullify(mesh_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh_pool) + + nullify(indexToCellID) + call mpas_pool_get_array(mesh_pool, 'indexToCellID', indexToCellID) + + nullify(nCells) + call mpas_pool_get_dimension(mesh_pool, 'nCells', nCells) + + nullify(nCellsSolve) + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + + ! + ! Initialize the mpas_halo module + ! + write(test_mesg, '(a)') ' Initializing the mpas_halo module: ' + call mpas_halo_init(domain, ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Create a group with persistent fields + ! + write(test_mesg, '(a)') ' Creating a halo group with persistent fields: ' + call mpas_halo_exch_group_create(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'persistent_group', 'cellPersistReal2D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'persistent_group', 'cellPersistReal3D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_complete(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Create a group with scratch fields + ! + write(test_mesg, '(a)') ' Creating a halo group with scratch fields: ' + call mpas_halo_exch_group_create(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'scratch_group', 'cellScratchReal3D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'scratch_group', 'cellScratchReal2D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_complete(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Exchange a group with persistent fields + ! + write(test_mesg, '(a)') ' Exchanging a halo group with persistent fields: ' + + call mpas_pool_get_array(haloExchTest_pool, 'cellPersistReal2D', array_2d) + do k = 1, size(array_2d, dim=1) + array_2d(k,:) = -1.0_RKIND + array_2d(k,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + + call mpas_pool_get_array(haloExchTest_pool, 'cellPersistReal3D', array_3d) + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + array_3d(k,j,:) = -1.0_RKIND + array_3d(k,j,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + end do + + call mpas_halo_exch_group_full_halo_exch(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + diff = 0.0_RKIND + do k = 1, size(array_2d, dim=1) + diff = diff + sum(abs(array_2d(k,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + diff = diff + sum(abs(array_3d(k,j,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + end do + + if (diff > 0.0_RKIND) then + ierr_local = 1 + ierr = ior(ierr, ierr_local) + end if + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Exchange a group with scratch fields + ! + write(test_mesg, '(a)') ' Exchanging a halo group with scratch fields: ' + + call mpas_pool_get_field(haloExchTest_pool, 'cellScratchReal2D', scratch_2d) + call mpas_pool_get_field(haloExchTest_pool, 'cellScratchReal3D', scratch_3d) + + call mpas_allocate_scratch_field(scratch_2d) + call mpas_allocate_scratch_field(scratch_3d) + + call mpas_pool_get_array(haloExchTest_pool, 'cellScratchReal2D', array_2d) + do k = 1, size(array_2d, dim=1) + array_2d(k,:) = -1.0_RKIND + array_2d(k,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + + call mpas_pool_get_array(haloExchTest_pool, 'cellScratchReal3D', array_3d) + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + array_3d(k,j,:) = -1.0_RKIND + array_3d(k,j,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + end do + + call mpas_halo_exch_group_full_halo_exch(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + diff = 0.0_RKIND + do k = 1, size(array_2d, dim=1) + diff = diff + sum(abs(array_2d(k,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + diff = diff + sum(abs(array_3d(k,j,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + end do + + call mpas_deallocate_scratch_field(scratch_2d) + call mpas_deallocate_scratch_field(scratch_3d) + + if (diff > 0.0_RKIND) then + ierr_local = 1 + ierr = ior(ierr, ierr_local) + end if + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Destroy a group with persistent fields + ! + write(test_mesg, '(a)') ' Destroying a halo group with persistent fields: ' + call mpas_halo_exch_group_destroy(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Destroy a group with scratch fields + ! + write(test_mesg, '(a)') ' Destroying a halo group with scratch fields: ' + call mpas_halo_exch_group_destroy(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Finalize the mpas_halo module + ! + write(test_mesg, '(a)') ' Finalizing the mpas_halo module: ' + call mpas_halo_finalize(domain, ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + call mpas_dmpar_max_int(domain % dminfo, ierr, ierr_global) + ierr = ierr_global + + end subroutine mpas_halo_tests + +end module mpas_halo_testing diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index 033b4cab19..fc746aba48 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -92,6 +92,7 @@ function test_core_run(domain) result(iErr)!{{{ use mpas_geometry_utils use test_core_streams, only : test_core_streams_test use test_core_sorting, only : test_core_test_sorting + use mpas_halo_testing, only : mpas_halo_tests implicit none @@ -119,6 +120,19 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_log_write(' * Sorting tests: FAILURE', MPAS_LOG_ERR) end if + ! + ! Test functionality of mpas_halo module + ! + call mpas_log_write('') + call mpas_log_write('Testing mpas_halo module:') + call mpas_halo_tests(domain, iErr) + if (iErr == 0) then + call mpas_log_write('* mpas_halo tests: SUCCESS') + else + call mpas_log_write('* mpas_halo tests: FAILURE', MPAS_LOG_ERR) + end if + call mpas_log_write('') + iErr = 0 call mpas_unit_test_fix_periodicity(iErr) diff --git a/src/core_test/mpas_test_core_interface.F b/src/core_test/mpas_test_core_interface.F index 9779cfba1a..c0bce7d7fc 100644 --- a/src/core_test/mpas_test_core_interface.F +++ b/src/core_test/mpas_test_core_interface.F @@ -222,15 +222,16 @@ end function test_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function test_setup_log(logInfo, domain) result(iErr)!{{{ + function test_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -239,7 +240,7 @@ function test_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here diff --git a/src/driver/mpas.F b/src/driver/mpas.F index 339a80303a..d0370fd577 100644 --- a/src/driver/mpas.F +++ b/src/driver/mpas.F @@ -8,14 +8,18 @@ program mpas use mpas_subdriver + use mpas_derived_types, only : core_type, domain_type implicit none - call mpas_init() + type (core_type), pointer :: corelist => null() + type (domain_type), pointer :: domain => null() - call mpas_run() + call mpas_init(corelist, domain) - call mpas_finalize() + call mpas_run(domain) + + call mpas_finalize(corelist, domain) stop diff --git a/src/driver/mpas_subdriver.F b/src/driver/mpas_subdriver.F index 1952010044..bfe79d0508 100644 --- a/src/driver/mpas_subdriver.F +++ b/src/driver/mpas_subdriver.F @@ -35,14 +35,11 @@ module mpas_subdriver use test_core_interface #endif - type (core_type), pointer :: corelist => null() - type (dm_info), pointer :: dminfo - type (domain_type), pointer :: domain_ptr contains - subroutine mpas_init() + subroutine mpas_init(corelist, domain_ptr, mpi_comm, namelistFileParam, streamsFileParam) use mpas_stream_manager, only : MPAS_stream_mgr_init, MPAS_build_stream_filename, MPAS_stream_mgr_validate_streams use iso_c_binding, only : c_char, c_loc, c_ptr, c_int @@ -53,6 +50,12 @@ subroutine mpas_init() implicit none + type (core_type), intent(inout), pointer :: corelist + type (domain_type), intent(inout), pointer :: domain_ptr + integer, intent(in), optional :: mpi_comm + character(len=*), intent(in), optional :: namelistFileParam + character(len=*), intent(in), optional :: streamsFileParam + integer :: iArg, nArgs logical :: readNamelistArg, readStreamsArg character(len=StrKIND) :: argument, namelistFile, streamsFile @@ -81,6 +84,7 @@ subroutine mpas_init() character(len=StrKIND) :: iotype logical :: streamsExists integer :: mesh_iotype + integer, save :: domainID = 0 interface subroutine xml_stream_parser(xmlname, mgr_p, comm, ierr) bind(c) @@ -107,38 +111,68 @@ end subroutine xml_stream_get_attributes readNamelistArg = .false. readStreamsArg = .false. - nArgs = command_argument_count() - iArg = 1 - do while (iArg < nArgs) - call get_command_argument(iArg, argument) - if (len_trim(argument) == 0) exit - - if ( trim(argument) == '-n' ) then - iArg = iArg + 1 + ! If provided, error check the namelistFileParam and copy it to namelistFile to override default + if (present(namelistFileParam)) then + if (len_trim(namelistFileParam) == 0) then + write (0,*) 'WARNING: mpas_init argument namelistFileParam has 0 length and will be ignored' + else if (len_trim(namelistFileParam) > len(namelistFile)) then + write(0,'(A,I5,A,I5,A)') 'CRITICAL ERROR: mpas_init argument ''namelistFileParam'' has length ',& + len_trim(namelistFileParam), ', but the maximum allowed is ', len(namelistFile), ' characters' + stop + else readNamelistArg = .true. - call get_command_argument(iArg, namelistFile) - if ( len_trim(namelistFile) == 0 ) then - write(0,*) 'ERROR: The -n argument requires a namelist file argument.' - stop - else if ( trim(namelistFile) == '-s' ) then - write(0,*) 'ERROR: The -n argument requires a namelist file argument.' - stop - end if - else if ( trim(argument) == '-s' ) then - iArg = iArg + 1 + namelistFile = trim(namelistFileParam) + end if + end if + ! If provided, error check the streamsFileParam and copy it to streamsFile to override default + if (present(streamsFileParam)) then + if (len_trim(streamsFileParam) == 0) then + write (0,*) 'WARNING: mpas_init argument streamsFileParam has 0 length and will be ignored' + else if (len_trim(streamsFileParam) > len(streamsFile)) then + write(0,'(A,I5,A,I5,A)') 'CRITICAL ERROR: mpas_init argument ''streamsFileParam'' has length ',& + len_trim(streamsFileParam), ', but the maximum allowed is ', len(streamsFile), ' characters' + stop + else readStreamsArg = .true. - call get_command_argument(iArg, streamsFile) - if ( len_trim(streamsFile) == 0 ) then - write(0,*) 'ERROR: The -s argument requires a streams file argument.' - stop - else if ( trim(streamsFile) == '-n' ) then - write(0,*) 'ERROR: The -s argument requires a streams file argument.' - stop - end if + streamsFile = trim(streamsFileParam) end if + end if - iArg = iArg + 1 - end do + ! If optional arguments weren't used, parse the command-line arguments for -n and -s + if (.not. (present(namelistFileParam) .or. present(streamsFileParam))) then + nArgs = command_argument_count() + iArg = 1 + do while (iArg < nArgs) + call get_command_argument(iArg, argument) + if (len_trim(argument) == 0) exit + + if ( trim(argument) == '-n' ) then + iArg = iArg + 1 + readNamelistArg = .true. + call get_command_argument(iArg, namelistFile) + if ( len_trim(namelistFile) == 0 ) then + write(0,*) 'ERROR: The -n argument requires a namelist file argument.' + stop + else if ( trim(namelistFile) == '-s' ) then + write(0,*) 'ERROR: The -n argument requires a namelist file argument.' + stop + end if + else if ( trim(argument) == '-s' ) then + iArg = iArg + 1 + readStreamsArg = .true. + call get_command_argument(iArg, streamsFile) + if ( len_trim(streamsFile) == 0 ) then + write(0,*) 'ERROR: The -s argument requires a streams file argument.' + stop + else if ( trim(streamsFile) == '-n' ) then + write(0,*) 'ERROR: The -s argument requires a streams file argument.' + stop + end if + end if + + iArg = iArg + 1 + end do + end if allocate(corelist) nullify(corelist % next) @@ -151,10 +185,13 @@ end subroutine xml_stream_get_attributes call mpas_allocate_domain(domain_ptr) + domain_ptr % domainID = domainID + domainID = domainID + 1 + ! ! Initialize infrastructure ! - call mpas_framework_init_phase1(domain_ptr % dminfo) + call mpas_framework_init_phase1(domain_ptr % dminfo, mpi_comm=mpi_comm) #ifdef CORE_ATMOSPHERE @@ -338,12 +375,18 @@ end subroutine xml_stream_get_attributes end subroutine mpas_init - subroutine mpas_run() + subroutine mpas_run(domain_ptr) + + use mpas_log, only: mpas_log_info implicit none + type (domain_type), intent(inout), pointer :: domain_ptr + integer :: iErr + if ( associated(domain_ptr % logInfo) ) mpas_log_info => domain_ptr % logInfo + iErr = domain_ptr % core % core_run(domain_ptr) if ( iErr /= 0 ) then call mpas_log_write('Core run failed for core '//trim(domain_ptr % core % coreName), messageType=MPAS_LOG_CRIT) @@ -352,13 +395,16 @@ subroutine mpas_run() end subroutine mpas_run - subroutine mpas_finalize() + subroutine mpas_finalize(corelist, domain_ptr) use mpas_stream_manager, only : MPAS_stream_mgr_finalize - use mpas_log, only : mpas_log_finalize + use mpas_log, only : mpas_log_finalize, mpas_log_info implicit none + type (core_type), intent(inout), pointer :: corelist + type (domain_type), intent(inout), pointer :: domain_ptr + integer :: iErr @@ -383,6 +429,8 @@ subroutine mpas_finalize() ! Print out log stats and close log file ! (Do this after timer stats are printed and stream mgr finalized, ! but before framework is finalized because domain is destroyed there.) + if ( associated(domain_ptr % logInfo) ) mpas_log_info => domain_ptr % logInfo + call mpas_log_finalize(iErr) if ( iErr /= 0 ) then call mpas_dmpar_global_abort('ERROR: Log finalize failed for core ' // trim(domain_ptr % core % coreName)) diff --git a/src/external/Makefile b/src/external/Makefile index d2f9e86f2e..9f048d3880 100644 --- a/src/external/Makefile +++ b/src/external/Makefile @@ -1,13 +1,17 @@ .SUFFIXES: .F .c .o -all: esmf_time ezxml-lib +all: esmf_time ezxml-lib smiol-lib esmf_time: - ( cd esmf_time_f90; $(MAKE) FC="$(FC) $(FFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS) -DHIDE_MPI" GEN_F90=$(GEN_F90) ) + ( cd esmf_time_f90; $(MAKE) FC="$(FC)" FFLAGS="$(FFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS) -DHIDE_MPI" GEN_F90=$(GEN_F90) ) ezxml-lib: ( cd ezxml; $(MAKE) OBJFILE="ezxml.o" ) +smiol-lib: + $(MAKE) -C SMIOL + clean: ( cd esmf_time_f90; $(MAKE) clean ) ( cd ezxml; $(MAKE) clean ) + $(MAKE) -C SMIOL clean diff --git a/src/external/SMIOL/Makefile b/src/external/SMIOL/Makefile new file mode 100644 index 0000000000..965de3e8d2 --- /dev/null +++ b/src/external/SMIOL/Makefile @@ -0,0 +1,23 @@ +override CPPINCLUDES += -DSMIOL_PNETCDF + +all: libsmiol.a libsmiolf.a + +libsmiol.a: smiol.o smiol_utils.o + ar -cr libsmiol.a smiol.o smiol_utils.o + +libsmiolf.a: smiolf.o + ar -cr libsmiolf.a smiolf.o + +clean: + $(RM) -f smiol.o smiol_utils.o libsmiol.a + $(RM) -f smiolf.o smiolf.mod libsmiolf.a + +# Cancel the built-in implicit rule for Modula-2 files (.mod) to avoid having 'make' +# try to create .o files from Fortran .mod files +%.o : %.mod + +%.o : %.F90 + $(FC) $(CPPINCLUDES) $(FFLAGS) -c $< + +%.o : %.c + $(CC) $(CPPINCLUDES) $(CFLAGS) -c $< diff --git a/src/external/SMIOL/gen_put_get.sh b/src/external/SMIOL/gen_put_get.sh new file mode 100755 index 0000000000..fb67177e03 --- /dev/null +++ b/src/external/SMIOL/gen_put_get.sh @@ -0,0 +1,409 @@ +#!/usr/bin/env sh + +filename=smiolf_put_get_var.inc + + +################################################################################ +# +# gen_put_get_var +# +# Generate a function body for a specific "SMIOLf_put/get_var" function +# Required variables: +# d = 0, 1, 2, 3 +# io = put, get +# colon_list = ":,:,:" +# dim_list = "d1,d1,d3" +# type = real32, real64 +# kind = c_float, c_double +# base_type = real, integer +# size_args = "size(buf,dim=1), size(buf,dim=2)" +# +################################################################################ +gen_put_get_var() +{ + # + # For non-scalars, build, e.g., " dimension(:,:,:)," + # + if [ $d -ge 1 ]; then + dim=" dimension(${colon_list})," + c_loc_invocation=" ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_${d}d_${type}(buf${size_args})" + else + dim="" + c_loc_invocation=" c_buf = c_loc(buf)" + fi + + # + # Character variables need special copying code... + # + if [ "${kind}" = "c_char" ]; then + + if [ "${io}" = "put" ]; then + + char_copyin=" allocate(char_buf(len(buf))) + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do" + + char_copyout=" if (associated(buf)) then + deallocate(char_buf) + end if" + + else + + char_copyin=" allocate(char_buf(len(buf))) + + ! In case buf contains more characters than will be read from the file, + ! initialize char_buf with the contents of buf to preserve un-read + ! characters during the copy of char_buf back into buf later on + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do" + + char_copyout=" if (associated(buf)) then + do i=1,len(buf) + buf(i:i) = char_buf(i) + end do + + deallocate(char_buf) + end if" + + fi + + dummy_buf_decl=" ${base_type},${dim} pointer :: buf" + char_buf_decl=" character(kind=c_char), dimension(:), allocatable, target :: char_buf" + c_loc_invocation=" c_buf = c_loc(char_buf)" + + else + char_copyin="" + char_copyout="" + dummy_buf_decl=" ${base_type}(kind=${kind}),${dim} pointer :: buf" + char_buf_decl="" + fi + + + # + # Build function documentation block + # + if [ "${io}" = "put" ]; then + + header=" !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d${d}_${type} + ! + !> \brief Writes a ${d}-d ${type} variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !-----------------------------------------------------------------------" + + else + + header=" !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d${d}_${type} + ! + !> \brief Reads a ${d}-d ${type} variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !-----------------------------------------------------------------------" + + fi + + cat >> ${filename} << EOF +$header + function SMIOLf_${io}_var_${d}d_${type}(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : ${kind}, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp +${dummy_buf_decl} + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf +${char_buf_decl} + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then +${char_copyin} +${c_loc_invocation} + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_${io}_var(c_file, c_varname, c_decomp, c_buf) + +${char_copyout} + deallocate(c_varname) + + end function SMIOLf_${io}_var_${d}d_${type} + + +EOF +} + + +################################################################################ +# +# gen_c_loc +# +# Generate a function body for a specific "c_loc_assumed_shape" function +# Required variables: +# d = 1, 2, 3 +# dim_args = , d1, d1, d3 +# dim_list = d1,d1,d3 +# type = real32, real64 +# kind = c_float, c_double +# base_type = real, integer +# +################################################################################ +gen_c_loc() +{ + # + # Build, e.g., " dimension(d1,d2,d3)," + # + dim=" dimension(${dim_list})," + + # + # Build list of dimension argument declarations + # + d_decl="integer, intent(in) :: d1" + i=2 + while [ $i -le $d ]; do + d_decl="${d_decl}, d$i" + i=$(($i+1)) + done + + # + # Build function documentation block + # + header=" !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_${d}d_${type} + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !-----------------------------------------------------------------------" + + cat >> ${filename} << EOF +${header} + function c_loc_assumed_shape_${d}d_${type}(a${dim_args}) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, ${kind} + + implicit none + + ! Arguments + ${d_decl} + ${base_type}(kind=${kind}),${dim} target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_${d}d_${type} + + +EOF +} + + +################################################################################ +# +# gen_put_get.sh +# +################################################################################ +printf "" > ${filename} + +# +# For each type, handle each dimensionality +# +for d in 0 1 2 3 4 5; do + + # + # Build list of dimension formal arguments, e.g. ", d1, d2, d3" + # + dim_args='' + i=1 + while [ $i -le $d ]; do + dim_args="${dim_args}, d$i" + i=$(($i+1)) + done + + # + # Build explicit shape list, e.g., "d1,d2,d3" + # + dim_list='' + i=1 + while [ $i -le $d ]; do + dim_list="${dim_list}d$i" + if [ $i -lt $d ]; then + dim_list="${dim_list}," + fi + i=$(($i+1)) + done + + # + # Build assumed shape list, e.g., ":,:,:" + # + colon_list='' + i=1 + while [ $i -le $d ]; do + colon_list="${colon_list}:" + if [ $i -lt $d ]; then + colon_list="${colon_list}," + fi + i=$(($i+1)) + done + + # + # Build array size actual arguments , e.g., "size(buf,dim=1), size(buf,dim=2)" + # + size_args='' + i=1 + while [ $i -le $d ]; do + + # Break long lines after three dimensions + if [ $i -eq 4 -a $d -ge 4 ]; then + size_args="${size_args}, & + size(buf,dim=$i)" + else + size_args="${size_args}, size(buf,dim=$i)" + fi + + i=$(($i+1)) + + done + + # + # Create functions for each type + # + for type in char real32 real64 int32; do + + # Only up to 0-d char interfaces + if [ "${type}" = "char" ] && [ $d -gt 0 ]; then + continue + fi + + # Only up to 4-d int32 interfaces + if [ "${type}" = "int32" ] && [ $d -gt 4 ]; then + continue + fi + + if [ "$type" = "real32" ]; then + kind="c_float" + base_type="real" + elif [ "$type" = "real64" ]; then + kind="c_double" + base_type="real" + elif [ "$type" = "int32" ]; then + kind="c_int" + base_type="integer" + elif [ "$type" = "char" ]; then + kind="c_char" + base_type="character(len=:)" + fi + + if [ $d -ge 1 ]; then + gen_c_loc + fi + + for io in put get; do + gen_put_get_var + done + + done + +done diff --git a/src/external/SMIOL/smiol.c b/src/external/SMIOL/smiol.c new file mode 100644 index 0000000000..1953e6536d --- /dev/null +++ b/src/external/SMIOL/smiol.c @@ -0,0 +1,2852 @@ +#include +#include +#include +#include +#include +#include +#include "smiol.h" +#include "smiol_utils.h" + +#ifdef SMIOL_PNETCDF +#include "pnetcdf.h" +#define PNETCDF_DEFINE_MODE 0 +#define PNETCDF_DATA_MODE 1 +#define MAX_REQS 256 +#endif + +#define START_COUNT_READ 0 +#define START_COUNT_WRITE 1 + +/* + * Local functions + */ +int build_start_count(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, + int write_or_read, size_t *element_size, + size_t *basic_type_size, int *ndims, + int *has_unlimited_dim, + size_t **start, size_t **count); + +#ifdef SMIOL_PNETCDF +int write_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + const void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ); + +int read_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ); +#endif + + +/******************************************************************************** + * + * SMIOL_fortran_init + * + * Initialize a SMIOL context from Fortran. + * + * This function is a simply a wrapper for the SMOIL_init routine that is intended + * to be called from Fortran. Accordingly, the first argument is of type MPI_Fint + * (a Fortran integer) rather than MPI_Comm. + * + ********************************************************************************/ +int SMIOL_fortran_init(MPI_Fint comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context) +{ + return SMIOL_init(MPI_Comm_f2c(comm), num_io_tasks, io_stride, context); +} + + +/******************************************************************************** + * + * SMIOL_init + * + * Initialize a SMIOL context. + * + * Initializes a SMIOL context, within which decompositions may be defined and + * files may be read and written. The input argument comm is an MPI communicator, + * and the input arguments num_io_tasks and io_stride provide the total number + * of I/O tasks and the stride between those I/O tasks within the communicator. + * + * Upon successful return the context argument points to a valid SMIOL context; + * otherwise, it is NULL and an error code other than MPI_SUCCESS is returned. + * + * Note: It is assumed that MPI_Init has been called prior to this routine, so + * that any use of the provided MPI communicator will be valid. + * + ********************************************************************************/ +int SMIOL_init(MPI_Comm comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context) +{ + MPI_Comm smiol_comm; + + /* + * Before dereferencing context below, ensure that the pointer + * the context pointer is not NULL + */ + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * We cannot check for every possible invalid argument for comm, but + * at least we can verify that the communicator is not MPI_COMM_NULL + */ + if (comm == MPI_COMM_NULL) { + /* Nullifying (*context) here may result in a memory leak, but this + * seems better than disobeying the stated behavior of returning + * a NULL context upon failure + */ + (*context) = NULL; + + return SMIOL_INVALID_ARGUMENT; + } + + *context = (struct SMIOL_context *)malloc(sizeof(struct SMIOL_context)); + if ((*context) == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Initialize context + */ + (*context)->lib_ierr = 0; + (*context)->lib_type = SMIOL_LIBRARY_UNKNOWN; + + (*context)->num_io_tasks = num_io_tasks; + (*context)->io_stride = io_stride; + + + /* + * Make a duplicate of the MPI communicator for use by SMIOL + */ + if (MPI_Comm_dup(comm, &smiol_comm) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + (*context)->fcomm = MPI_Comm_c2f(smiol_comm); + + if (MPI_Comm_size(smiol_comm, &((*context)->comm_size)) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + + if (MPI_Comm_rank(smiol_comm, &((*context)->comm_rank)) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_finalize + * + * Finalize a SMIOL context. + * + * Finalizes a SMIOL context and frees all memory in the SMIOL_context instance. + * After this routine is called, no other SMIOL routines that make reference to + * the finalized context should be called. + * + ********************************************************************************/ +int SMIOL_finalize(struct SMIOL_context **context) +{ + MPI_Comm smiol_comm; + + /* + * If the pointer to the context pointer is NULL, assume we have nothing + * to do and declare success + */ + if (context == NULL) { + return SMIOL_SUCCESS; + } + + if ((*context) == NULL) { + return SMIOL_SUCCESS; + } + + smiol_comm = MPI_Comm_f2c((*context)->fcomm); + if (MPI_Comm_free(&smiol_comm) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + + free((*context)); + (*context) = NULL; + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire + * + * Inquire about a SMIOL context. + * + * Detailed description. + * + ********************************************************************************/ +int SMIOL_inquire(void) +{ + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_open_file + * + * Opens a file within a SMIOL context. + * + * Depending on the specified file mode, creates or opens the file specified + * by filename within the provided SMIOL context. + * + * The bufsize argument specifies the size in bytes of the buffer to be attached + * to the file by I/O tasks; at present this buffer is only used by the Parallel- + * NetCDF library if the file is opened with a mode of SMIOL_FILE_CREATE or + * SMIOL_FILE_WRITE. A bufsize of 0 will force the use of the Parallel-NetCDF + * blocking write interface, while a nonzero value enables the use of the + * non-blocking, buffered interface for writing. + * + * Upon successful completion, SMIOL_SUCCESS is returned, and the file handle + * argument will point to a valid file handle and the current frame for the + * file will be set to zero. Otherwise, the file handle is NULL and an error + * code other than SMIOL_SUCCESS is returned. + * + ********************************************************************************/ +int SMIOL_open_file(struct SMIOL_context *context, const char *filename, + int mode, struct SMIOL_file **file, size_t bufsize) +{ + int io_group; + MPI_Comm io_file_comm; + MPI_Comm io_group_comm; + int ierr; + + + /* + * Before dereferencing file below, ensure that the pointer + * the file pointer is not NULL + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that context is valid + */ + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + *file = (struct SMIOL_file *)malloc(sizeof(struct SMIOL_file)); + if ((*file) == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Save pointer to context for this file + */ + (*file)->context = context; + (*file)->frame = (SMIOL_Offset) 0; + + + /* + * Determine whether a task is an I/O task or not, and compute + * the I/O group to which each task belongs + */ + (*file)->io_task = context->comm_rank % context->io_stride == 0 ? 1 : 0; + io_group = context->comm_rank / context->io_stride; + + /* + * If there are fewer than comm_size / io_stride I/O tasks, some + * tasks that were set to I/O tasks above will actually not perform + * I/O. Also, place all remainder tasks in the last I/O group + */ + if (io_group >= context->num_io_tasks) { + (*file)->io_task = 0; + io_group = context->num_io_tasks - 1; + } + + /* + * Create a communicator for communicating within a group of tasks + * associated with an I/O task + */ + ierr = MPI_Comm_split(MPI_Comm_f2c(context->fcomm), io_group, + context->comm_rank, &io_group_comm); + if (ierr != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + (*file)->io_group_comm = MPI_Comm_c2f(io_group_comm); + + + /* + * Create a communicator for collective file I/O operations among + * I/O tasks (i.e., io_task == 1) + */ + ierr = MPI_Comm_split(MPI_Comm_f2c(context->fcomm), (*file)->io_task, + context->comm_rank, &io_file_comm); + if (ierr != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + (*file)->io_file_comm = MPI_Comm_c2f(io_file_comm); + + + if (mode & SMIOL_FILE_CREATE) { +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = ncmpi_create(io_file_comm, filename, + (NC_64BIT_DATA | NC_CLOBBER), + MPI_INFO_NULL, + &((*file)->ncidp)); + } + (*file)->state = PNETCDF_DEFINE_MODE; +#endif + } else if (mode & SMIOL_FILE_WRITE) { +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = ncmpi_open(io_file_comm, filename, + NC_WRITE, MPI_INFO_NULL, + &((*file)->ncidp)); + } + (*file)->state = PNETCDF_DATA_MODE; +#endif + } else if (mode & SMIOL_FILE_READ) { +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = ncmpi_open(io_file_comm, filename, + NC_NOWRITE, MPI_INFO_NULL, + &((*file)->ncidp)); + } + (*file)->state = PNETCDF_DATA_MODE; +#endif + } else { + free((*file)); + (*file) = NULL; + MPI_Comm_free(&io_file_comm); + MPI_Comm_free(&io_group_comm); + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + free((*file)); + (*file) = NULL; + MPI_Comm_free(&io_file_comm); + MPI_Comm_free(&io_group_comm); + context->lib_type = SMIOL_LIBRARY_PNETCDF; + context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + (*file)->bufsize = 0; + (*file)->n_reqs = 0; + (*file)->reqs = NULL; + + if (mode & SMIOL_FILE_CREATE || mode & SMIOL_FILE_WRITE) { + if (bufsize > 0 && (*file)->io_task) { + (*file)->bufsize = bufsize; + ierr = ncmpi_buffer_attach((*file)->ncidp, + (MPI_Offset)bufsize); + (*file)->reqs = malloc(sizeof(int) * (size_t)MAX_REQS); + } + + if (bufsize > 0) { + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + if ((*file)->reqs != NULL) { + free((*file)->reqs); + (*file)->reqs = NULL; + } + free((*file)); + (*file) = NULL; + MPI_Comm_free(&io_file_comm); + MPI_Comm_free(&io_group_comm); + context->lib_type = SMIOL_LIBRARY_PNETCDF; + context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_close_file + * + * Closes a file within a SMIOL context. + * + * Closes the file associated with the provided file handle. Upon successful + * completion, SMIOL_SUCCESS is returned, the file will be closed, and all memory + * that is uniquely associated with the file handle will be deallocated. + * Otherwise, an error code other than SMIOL_SUCCESS will be returned. + * + ********************************************************************************/ +int SMIOL_close_file(struct SMIOL_file **file) +{ + MPI_Comm io_file_comm; + MPI_Comm io_group_comm; +#ifdef SMIOL_PNETCDF + int ierr; +#endif + + + /* + * If the pointer to the file pointer is NULL, assume we have nothing + * to do and declare success + */ + if (file == NULL) { + return SMIOL_SUCCESS; + } + + io_file_comm = MPI_Comm_f2c((*file)->io_file_comm); + io_group_comm = MPI_Comm_f2c((*file)->io_group_comm); + +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = NC_NOERR; + if ((*file)->n_reqs > 0) { + int statuses[MAX_REQS]; + + ierr = ncmpi_wait_all((*file)->ncidp, (*file)->n_reqs, + (*file)->reqs, statuses); + (*file)->n_reqs = 0; + } + if ((*file)->reqs != NULL) { + free((*file)->reqs); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + ((*file)->context)->lib_type = SMIOL_LIBRARY_PNETCDF; + ((*file)->context)->lib_ierr = ierr; + free((*file)); + (*file) = NULL; + return SMIOL_LIBRARY_ERROR; + } + + ierr = NC_NOERR; + if ((*file)->io_task && (*file)->bufsize > 0) { + ierr = ncmpi_buffer_detach((*file)->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + ((*file)->context)->lib_type = SMIOL_LIBRARY_PNETCDF; + ((*file)->context)->lib_ierr = ierr; + free((*file)); + (*file) = NULL; + return SMIOL_LIBRARY_ERROR; + } + + if ((*file)->io_task) { + ierr = ncmpi_close((*file)->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + ((*file)->context)->lib_type = SMIOL_LIBRARY_PNETCDF; + ((*file)->context)->lib_ierr = ierr; + free((*file)); + (*file) = NULL; + return SMIOL_LIBRARY_ERROR; + } +#endif + + if (MPI_Comm_free(&io_file_comm) != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + + if (MPI_Comm_free(&io_group_comm) != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + + free((*file)); + (*file) = NULL; + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_define_dim + * + * Defines a new dimension in a file. + * + * Defines a dimension with the specified name and size in the file associated + * with the file handle. If a negative value is provided for the size argument, + * the dimension will be defined as an unlimited or record dimension. + * + * Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + * code is returned. + * + ********************************************************************************/ +int SMIOL_define_dim(struct SMIOL_file *file, const char *dimname, SMIOL_Offset dimsize) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int dimidp; + int ierr; + MPI_Offset len; +#endif + + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that dimension name is valid + */ + if (dimname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * The parallel-netCDF library does not permit zero-length dimensions + */ + if (dimsize == (SMIOL_Offset)0) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Handle unlimited / record dimension specifications + */ + if (dimsize < (SMIOL_Offset)0) { + len = NC_UNLIMITED; + } + else { + len = (MPI_Offset)dimsize; + } + + /* + * If the file is in data mode, then switch it to define mode + */ + if (file->state == PNETCDF_DATA_MODE) { + if (file->io_task) { + ierr = ncmpi_redef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DEFINE_MODE; + } + + if (file->io_task) { + ierr = ncmpi_def_dim(file->ncidp, dimname, len, &dimidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire_dim + * + * Inquires about an existing dimension in a file. + * + * Inquire about the size of an existing dimension and optionally inquire if the + * given dimension is the unlimited dimension or not. If dimsize is a non-NULL + * pointer then the dimension size will be returned in dimsize. For unlimited + * dimensions, the current size of the dimension is returned; future writes of + * additional records to a file can lead to different return sizes for + * unlimited dimensions. + * + * If is_unlimited is a non-NULL pointer and if the inquired dimension is the + * unlimited dimension, is_unlimited will be set to 1; if the inquired + * dimension is not the unlimited dimension then is_unlimited will be set to 0. + * + * Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + * code is returned. + * + ********************************************************************************/ +int SMIOL_inquire_dim(struct SMIOL_file *file, const char *dimname, + SMIOL_Offset *dimsize, int *is_unlimited) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int dimidp = 0; + int ierr; + MPI_Offset len = 0; +#endif + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that dimension name is valid + */ + if (dimname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that dimension size is not NULL + */ + if (dimsize == NULL && is_unlimited == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + if (dimsize != NULL) { + (*dimsize) = (SMIOL_Offset)0; /* Default dimension size if no library provides a value */ + } + + if (is_unlimited != NULL) { + (*is_unlimited) = 0; /* Return 0 if no library provides a value */ + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + if (file->io_task) { + ierr = ncmpi_inq_dimid(file->ncidp, dimname, &dimidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + (*dimsize) = (SMIOL_Offset)(-1); /* TODO: should there be a well-defined invalid size? */ + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + /* + * Inquire about dimsize + */ + if (dimsize != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_dimlen(file->ncidp, dimidp, &len); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + (*dimsize) = (SMIOL_Offset)(-1); /* TODO: should there be a well-defined invalid size? */ + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + (*dimsize) = (SMIOL_Offset)len; +/* TO DO: what if SMIOL_Offset is different in size from MPI_LONG */ + MPI_Bcast(dimsize, 1, MPI_LONG, 0, io_group_comm); + } + + + /* + * Inquire if this dimension is the unlimited dimension + */ + if (is_unlimited != NULL) { + int unlimdimidp = 0; + if (file->io_task) { + ierr = ncmpi_inq_unlimdim(file->ncidp, &unlimdimidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + if (file->io_task) { + if (unlimdimidp == dimidp) { + (*is_unlimited) = 1; + } else { + (*is_unlimited) = 0; /* Not the unlimited dim */ + } + } + MPI_Bcast(is_unlimited, 1, MPI_INT, 0, io_group_comm); + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_define_var + * + * Defines a new variable in a file. + * + * Defines a variable with the specified name, type, and dimensions in an open + * file pointed to by the file argument. The varname and dimnames arguments + * are expected to be null-terminated strings, except if the variable has zero + * dimensions, in which case the dimnames argument may be a NULL pointer. + * + * Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + * code is returned. + * + ********************************************************************************/ +int SMIOL_define_var(struct SMIOL_file *file, const char *varname, int vartype, int ndims, const char **dimnames) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int *dimids; + int ierr; + int i; + nc_type xtype; + int varidp; +#endif + + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that variable name is valid + */ + if (varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that the variable type is valid - handled below in a library-specific way... + */ + + /* + * Check that variable dimension names are valid + */ + if (dimnames == NULL && ndims > 0) { + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + dimids = (int *)malloc(sizeof(int) * (size_t)ndims); + if (dimids == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Build a list of dimension IDs + */ + for (i=0; iio_task) { + ierr = ncmpi_inq_dimid(file->ncidp, + dimnames[i], &dimids[i]); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + free(dimids); + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } + + /* + * Translate SMIOL variable type to parallel-netcdf type + */ + switch (vartype) { + case SMIOL_REAL32: + xtype = NC_FLOAT; + break; + case SMIOL_REAL64: + xtype = NC_DOUBLE; + break; + case SMIOL_INT32: + xtype = NC_INT; + break; + case SMIOL_CHAR: + xtype = NC_CHAR; + break; + default: + free(dimids); + return SMIOL_INVALID_ARGUMENT; + } + + /* + * If the file is in data mode, then switch it to define mode + */ + if (file->state == PNETCDF_DATA_MODE) { + if (file->io_task) { + ierr = ncmpi_redef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DEFINE_MODE; + } + + /* + * Define the variable + */ + if (file->io_task) { + ierr = ncmpi_def_var(file->ncidp, varname, xtype, ndims, dimids, + &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + free(dimids); + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + free(dimids); +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire_var + * + * Inquires about an existing variable in a file. + * + * Inquires about a variable in a file, and optionally returns the type + * of the variable, the dimensionality of the variable, and the names of + * the dimensions of the variable. Which properties of the variable to return + * (type, dimensionality, or dimension names) is indicated by the status of + * the pointers for the corresponding properties: if the pointer is a non-NULL + * pointer, the property will be set upon successful completion of this routine. + * + * If the names of a variable's dimensions are requested (by providing a non-NULL + * actual argument for dimnames), the size of the dimnames array must be at least + * the number of dimensions in the variable, and each character string pointed + * to by an element of dimnames must be large enough to accommodate the corresponding + * dimension name. + * + ********************************************************************************/ +int SMIOL_inquire_var(struct SMIOL_file *file, const char *varname, int *vartype, int *ndims, char **dimnames) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int *dimids; + int varidp = 0; + int ierr; + int i; + int xtypep; + int ndimsp = 0; +#endif + + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that variable name is valid + */ + if (varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * If all output arguments are NULL, we can return early + */ + if (vartype == NULL && ndims == NULL && dimnames == NULL) { + return SMIOL_SUCCESS; + } + + /* + * Provide default values for output arguments in case + * no library-specific below is active + */ + if (vartype != NULL) { + *vartype = SMIOL_UNKNOWN_VAR_TYPE; + } + if (ndims != NULL) { + *ndims = 0; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * Get variable ID + */ + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + /* + * If requested, inquire about variable type + */ + if (vartype != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_vartype(file->ncidp, varidp, &xtypep); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + MPI_Bcast(&xtypep, 1, MPI_INT, 0, io_group_comm); + + /* Convert parallel-netCDF variable type to SMIOL variable type */ + switch (xtypep) { + case NC_FLOAT: + *vartype = SMIOL_REAL32; + break; + case NC_DOUBLE: + *vartype = SMIOL_REAL64; + break; + case NC_INT: + *vartype = SMIOL_INT32; + break; + case NC_CHAR: + *vartype = SMIOL_CHAR; + break; + default: + *vartype = SMIOL_UNKNOWN_VAR_TYPE; + } + } + + /* + * All remaining properties will require the number of dimensions + */ + if (ndims != NULL || dimnames != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_varndims(file->ncidp, varidp, &ndimsp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + MPI_Bcast(&ndimsp, 1, MPI_INT, 0, io_group_comm); + } + + /* + * If requested, inquire about dimensionality + */ + if (ndims != NULL) { + *ndims = ndimsp; + } + + /* + * If requested, inquire about dimension names + */ + if (dimnames != NULL) { + dimids = (int *)malloc(sizeof(int) * (size_t)ndimsp); + if (dimids == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + if (file->io_task) { + ierr = ncmpi_inq_vardimid(file->ncidp, varidp, dimids); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + free(dimids); + return SMIOL_LIBRARY_ERROR; + } + + for (i = 0; i < ndimsp; i++) { + int len; + + if (dimnames[i] == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + if (file->io_task) { + ierr = ncmpi_inq_dimname(file->ncidp, dimids[i], + dimnames[i]); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + free(dimids); + return SMIOL_LIBRARY_ERROR; + } + + if (file->io_task) { + len = (int)strnlen(dimnames[i], + (size_t)NC_MAX_NAME); + len++; /* Include the terminating '\0' character */ + } + MPI_Bcast(&len, 1, MPI_INT, 0, io_group_comm); + MPI_Bcast(dimnames[i], len, MPI_CHAR, 0, io_group_comm); + } + + free(dimids); + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_put_var + * + * Writes a variable to a file. + * + * Given a pointer to a SMIOL file that was previously opened with write access + * and the name of a variable previously defined in the file with a call to + * SMIOL_define_var, this routine will write the contents of buf to the variable + * according to the decomposition described by decomp. + * + * If decomp is not NULL, the variable is assumed to be decomposed across MPI + * ranks, and all ranks with non-zero-sized partitions of the variable must + * provide a valid buffer. For decomposed variables, all MPI ranks must provide + * a non-NULL decomp, regardless of whether a rank has a non-zero-sized + * partition of the variable. + * + * If the variable is not decomposed -- that is, all ranks store identical + * values for the entire variable -- all MPI ranks must provide a NULL pointer + * for the decomp argument. As currently implemented, this routine will write + * the buffer for MPI rank 0 to the variable; however, this behavior should not + * be relied on. + * + * If the variable has been successfully written to the file, SMIOL_SUCCESS will + * be returned. Otherwise, an error code indicating the nature of the failure + * will be returned. + * + ********************************************************************************/ +int SMIOL_put_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, const void *buf) +{ + int ierr; + int ndims; + size_t element_size; + size_t basic_size; + int has_unlimited_dim; + void *out_buf = NULL; + size_t *start; + size_t *count; + + void *agg_buf = NULL; + const void *agg_buf_cnst = NULL; + + + /* + * Basic checks on arguments + */ + if (file == NULL || varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Work out the start[] and count[] arrays for writing this variable + * in parallel + */ + ierr = build_start_count(file, varname, decomp, + START_COUNT_WRITE, &element_size, &basic_size, &ndims, + &has_unlimited_dim, + &start, &count); + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + + /* + * Communicate elements of this field from MPI ranks that compute those + * elements to MPI ranks that write those elements. This only needs to + * be done for decomposed variables. + */ + if (decomp) { + out_buf = malloc(element_size * decomp->io_count); + if (out_buf == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + + if (decomp->agg_factor != 1) { + MPI_Datatype dtype; + MPI_Comm agg_comm; + + ierr = MPI_Type_contiguous((int)element_size, + MPI_UINT8_T, &dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_contiguous failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Type_commit(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_commit failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + agg_buf = malloc(element_size * decomp->n_compute_agg); + if (agg_buf == NULL && decomp->n_compute_agg > 0) { + return SMIOL_MALLOC_FAILURE; + } + + agg_comm = MPI_Comm_f2c(decomp->agg_comm); + + ierr = MPI_Gatherv((const void *)buf, + (int)decomp->n_compute, dtype, + (void *)agg_buf, + (const int *)decomp->counts, + (const int *)decomp->displs, + dtype, 0, agg_comm); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Gatherv failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Type_free(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_free failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + agg_buf_cnst = agg_buf; + } else { + agg_buf_cnst = buf; + } + + ierr = transfer_field(decomp, SMIOL_COMP_TO_IO, + element_size, agg_buf_cnst, out_buf); + if (ierr != SMIOL_SUCCESS) { + free(start); + free(count); + free(out_buf); + return ierr; + } + + if (decomp->agg_factor != 1) { + free(agg_buf); + } + } + +/* TO DO: could check that out_buf has size zero if not file->io_task */ + + /* + * Write out_buf + */ +#ifdef SMIOL_PNETCDF + { + int j; + int varidp = 0; + const void *buf_p; + MPI_Offset *mpi_start; + MPI_Offset *mpi_count; + MPI_Comm io_group_comm; + MPI_Comm io_file_comm; + + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + io_file_comm = MPI_Comm_f2c(file->io_file_comm); + + if (file->state == PNETCDF_DEFINE_MODE) { + if (file->io_task) { + ierr = ncmpi_enddef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(out_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DATA_MODE; + } + + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(out_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + + if (decomp) { + buf_p = out_buf; + } else { + buf_p = buf; + } + + mpi_start = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_start == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + + mpi_count = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_count == NULL) { + free(start); + free(count); + free(mpi_start); + + return SMIOL_MALLOC_FAILURE; + } + + for (j = 0; j < ndims; j++) { + mpi_start[j] = (MPI_Offset)start[j]; + mpi_count[j] = (MPI_Offset)count[j]; + } + + if (file->io_task) { + ierr = write_chunk_pnetcdf(file, + varidp, + ndims, + has_unlimited_dim, + basic_size, + io_file_comm, + buf_p, + mpi_start, + mpi_count + ); + } + + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + + free(mpi_start); + free(mpi_count); + + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(out_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + } +#endif + + /* + * Free up memory before returning + */ + if (decomp) { + free(out_buf); + } + + free(start); + free(count); + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_get_var + * + * Reads a variable from a file. + * + * Given a pointer to a SMIOL file and the name of a variable previously defined + * in the file, this routine will read the contents of the variable into buf + * according to the decomposition described by decomp. + * + * If decomp is not NULL, the variable is assumed to be decomposed across MPI + * ranks, and all ranks with non-zero-sized partitions of the variable must + * provide a valid buffer. For decomposed variables, all MPI ranks must provide + * a non-NULL decomp, regardless of whether a rank has a non-zero-sized + * partition of the variable. + * + * If the variable is not decomposed -- that is, all ranks load identical + * values for the entire variable -- all MPI ranks must provide a NULL pointer + * for the decomp argument. + * + * If the variable has been successfully read from the file, SMIOL_SUCCESS will + * be returned. Otherwise, an error code indicating the nature of the failure + * will be returned. + * + ********************************************************************************/ +int SMIOL_get_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, void *buf) +{ + int ierr; + int ndims; + size_t element_size; + size_t basic_size; + int has_unlimited_dim; + void *in_buf = NULL; + size_t *start; + size_t *count; + + void *agg_buf = NULL; + + MPI_Comm io_group_comm; + MPI_Comm io_file_comm; + + + /* + * Basic checks on arguments + */ + if (file == NULL || varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + io_file_comm = MPI_Comm_f2c(file->io_file_comm); + + /* + * Work out the start[] and count[] arrays for reading this variable + * in parallel + */ + ierr = build_start_count(file, varname, decomp, + START_COUNT_READ, &element_size, &basic_size, &ndims, + &has_unlimited_dim, + &start, &count); + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + + /* + * If this variable is decomposed, allocate a buffer into which + * the variable will be read using the I/O decomposition; later, + * elements this buffer will be transferred to MPI ranks that compute + * on those elements + */ + if (decomp) { + in_buf = malloc(element_size * decomp->io_count); + if (in_buf == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + +#ifndef SMIOL_PNETCDF + /* + * If no file library provides values for the memory pointed to + * by in_buf, the transfer_field call later will transfer + * garbage to the output buffer; to avoid returning + * non-deterministic values to the caller in this case, + * initialize in_buf. + */ + memset(in_buf, 0, element_size * decomp->io_count); + +#endif + } + +/* MGD TO DO: could verify that if not file->io_task, then size of in_buf is zero */ + + /* + * Read in_buf + */ +#ifdef SMIOL_PNETCDF + { + int j; + int varidp = 0; + void *buf_p; + MPI_Offset *mpi_start; + MPI_Offset *mpi_count; + + if (file->state == PNETCDF_DEFINE_MODE) { + if (file->io_task) { + ierr = ncmpi_enddef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(in_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DATA_MODE; + } + + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(in_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + + if (decomp) { + buf_p = in_buf; + } else { + buf_p = buf; + } + + mpi_start = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_start == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + + mpi_count = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_count == NULL) { + free(start); + free(count); + free(mpi_start); + + return SMIOL_MALLOC_FAILURE; + } + + for (j = 0; j < ndims; j++) { + mpi_start[j] = (MPI_Offset)start[j]; + mpi_count[j] = (MPI_Offset)count[j]; + } + + ierr = NC_NOERR; + if (file->io_task) { + /* + * Finish and flush any pending writes to this file + * before reading back a variable + */ + if (file->n_reqs > 0) { + int statuses[MAX_REQS]; + + ierr = ncmpi_wait_all(file->ncidp, file->n_reqs, + file->reqs, statuses); + file->n_reqs = 0; + + if (ierr == NC_NOERR) { + ierr = ncmpi_sync(file->ncidp); + } + } + if (ierr == NC_NOERR) { + ierr = read_chunk_pnetcdf(file, + varidp, + ndims, + has_unlimited_dim, + basic_size, + io_file_comm, + buf_p, + mpi_start, + mpi_count + ); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + + free(mpi_start); + free(mpi_count); + + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(in_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + } +#endif + + /* + * Free start/count arrays + */ + free(start); + free(count); + + /* + * Communicate elements of this field from MPI ranks that read those + * elements to MPI ranks that compute those elements. This only needs to + * be done for decomposed variables. + */ + if (decomp) { + if (decomp->agg_factor != 1) { + agg_buf = malloc(element_size * decomp->n_compute_agg); + if (agg_buf == NULL && decomp->n_compute_agg > 0) { + return SMIOL_MALLOC_FAILURE; + } + } else { + agg_buf = buf; + } + + ierr = transfer_field(decomp, SMIOL_IO_TO_COMP, + element_size, in_buf, agg_buf); + + if (decomp->agg_factor != 1) { + MPI_Datatype dtype = MPI_DATATYPE_NULL; + MPI_Comm agg_comm; + + ierr = MPI_Type_contiguous((int)element_size, + MPI_UINT8_T, &dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_contiguous failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Type_commit(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_commit failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + agg_comm = MPI_Comm_f2c(decomp->agg_comm); + + ierr = MPI_Scatterv((const void *)agg_buf, + (const int*)decomp->counts, + (const int *)decomp->displs, + dtype, (void *)buf, + (int)decomp->n_compute, + dtype, 0, agg_comm); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Scatterv failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + free(agg_buf); + + ierr = MPI_Type_free(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_free failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + } + + free(in_buf); + + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + } else { + /* + * For non-decomposed variables, broadcast from I/O tasks + * to other tasks in each I/O group + */ + MPI_Bcast(buf, (int)element_size, MPI_CHAR, 0, io_group_comm); + } + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_define_att + * + * Defines a new attribute in a file. + * + * Defines a new attribute for a variable if varname is not NULL, + * or a global attribute otherwise. The type of the attribute must be one + * of SMIOL_REAL32, SMIOL_REAL64, SMIOL_INT32, or SMIOL_CHAR. + * + * If the attribute has been successfully defined for the variable or file, + * SMIOL_SUCCESS is returned. + * + ********************************************************************************/ +int SMIOL_define_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int att_type, const void *att) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int ierr; + int varidp = 0; + nc_type xtype; +#endif + + /* + * Check validity of arguments + */ + if (file == NULL || att_name == NULL || att == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Checks for valid attribute type are handled in library-specific + * code, below + */ + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * If varname was provided, get the variable ID; else, the attribute + * is a global attribute not associated with a specific variable + */ + if (varname != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } else { + varidp = NC_GLOBAL; + } + + /* + * Translate SMIOL variable type to parallel-netcdf type + */ + switch (att_type) { + case SMIOL_REAL32: + xtype = NC_FLOAT; + break; + case SMIOL_REAL64: + xtype = NC_DOUBLE; + break; + case SMIOL_INT32: + xtype = NC_INT; + break; + case SMIOL_CHAR: + xtype = NC_CHAR; + break; + default: + return SMIOL_INVALID_ARGUMENT; + } + + /* + * If the file is in data mode, then switch it to define mode + */ + if (file->state == PNETCDF_DATA_MODE) { + if (file->io_task) { + ierr = ncmpi_redef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DEFINE_MODE; + } + + /* + * Add the attribute to the file + */ + if (file->io_task) { + if (att_type == SMIOL_CHAR) { + ierr = ncmpi_put_att(file->ncidp, varidp, att_name, + xtype, (MPI_Offset)strlen(att), + (const char *)att); + } else { + ierr = ncmpi_put_att(file->ncidp, varidp, att_name, + xtype, (MPI_Offset)1, + (const char *)att); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire_att + * + * Inquires about an attribute in a file. + * + * Inquires about a variable attribute if varname is not NULL, or a global + * attribute otherwise. + * + * If the requested attribute is found, SMIOL_SUCCESS is returned and the memory + * pointed to by the att argument will contain the attribute value. + * + * For character string attributes, no bytes beyond the length of the attribute + * in the file will be modified in the att argument, and no '\0' character will + * be added. Therefore, calling code may benefit from initializing character + * strings before calling this routine. + * + * If SMIOL was not compiled with support for any file library, the att_type + * output argument will always be set to SMIOL_UNKNOWN_VAR_TYPE, and the att_len + * output argument will always be set to -1; the value of the att output + * argument will be unchanged. + * + ********************************************************************************/ +int SMIOL_inquire_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int *att_type, + SMIOL_Offset *att_len, void *att) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int ierr; + int varidp = 0; + nc_type xtypep = 0; + MPI_Offset lenp = 0; +#endif + + /* + * Check validity of arguments + */ + if (file == NULL || att_name == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Set output arguments in case no library sets them later + */ + if (att_len != NULL) { + *att_len = (SMIOL_Offset)-1; + } + + if (att_type != NULL) { + *att_type = SMIOL_UNKNOWN_VAR_TYPE; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * If varname was provided, get the variable ID; else, the inquiry is + * is for a global attribute not associated with a specific variable + */ + if (varname != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } else { + varidp = NC_GLOBAL; + } + + /* + * Inquire about attribute type and length + */ + if (att != NULL || att_type != NULL || att_len != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_att(file->ncidp, varidp, att_name, + &xtypep, &lenp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + MPI_Bcast(&lenp, sizeof(MPI_Offset), MPI_BYTE, 0, + io_group_comm); + MPI_Bcast(&xtypep, sizeof(nc_type), MPI_BYTE, 0, + io_group_comm); + + if (att_type != NULL) { + /* Convert parallel-netCDF type to SMIOL type */ + switch (xtypep) { + case NC_FLOAT: + *att_type = SMIOL_REAL32; + break; + case NC_DOUBLE: + *att_type = SMIOL_REAL64; + break; + case NC_INT: + *att_type = SMIOL_INT32; + break; + case NC_CHAR: + *att_type = SMIOL_CHAR; + break; + default: + *att_type = SMIOL_UNKNOWN_VAR_TYPE; + } + } + + if (att_len != NULL) { + *att_len = lenp; + } + } + + + /* + * Inquire about attribute value if requested + */ + if (att != NULL) { + if (file->io_task) { + ierr = ncmpi_get_att(file->ncidp, varidp, att_name, + att); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + switch (xtypep) { + case NC_FLOAT: + ierr = MPI_Bcast(att, 1, MPI_FLOAT, 0, io_group_comm); + break; + case NC_DOUBLE: + ierr = MPI_Bcast(att, 1, MPI_DOUBLE, 0, io_group_comm); + break; + case NC_INT: + ierr = MPI_Bcast(att, 1, MPI_INT, 0, io_group_comm); + break; + case NC_CHAR: + ierr = MPI_Bcast(att, (int)lenp, MPI_CHAR, 0, + io_group_comm); + break; + } + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_sync_file + * + * Forces all in-memory data to be flushed to disk. + * + * Upon success, all in-memory data for the file associatd with the file + * handle will be flushed to the file system and SMIOL_SUCCESS will be + * returned; otherwise, an error code is returned. + * + ********************************************************************************/ +int SMIOL_sync_file(struct SMIOL_file *file) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int ierr; +#endif + + /* + * Check that file is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * If the file is in define mode then switch it into data mode + */ + if (file->state == PNETCDF_DEFINE_MODE) { + if (file->io_task) { + ierr = ncmpi_enddef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DATA_MODE; + } + + if (file->io_task) { + ierr = NC_NOERR; + + if (file->n_reqs > 0) { + int statuses[MAX_REQS]; + + ierr = ncmpi_wait_all(file->ncidp, file->n_reqs, + file->reqs, statuses); + file->n_reqs = 0; + } + + if (ierr == NC_NOERR) { + ierr = ncmpi_sync(file->ncidp); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_error_string + * + * Returns an error string for a specified error code. + * + * Returns an error string corresponding to a SMIOL error code. If the error code is + * SMIOL_LIBRARY_ERROR and a valid SMIOL context is available, the SMIOL_lib_error_string + * function should be called instead. The error string is null-terminated, but it + * does not contain a newline character. + * + ********************************************************************************/ +const char *SMIOL_error_string(int errno) +{ + switch (errno) { + case SMIOL_SUCCESS: + return "Success!"; + case SMIOL_MALLOC_FAILURE: + return "malloc returned a null pointer"; + case SMIOL_INVALID_ARGUMENT: + return "invalid subroutine argument"; + case SMIOL_MPI_ERROR: + return "internal MPI call failed"; + case SMIOL_FORTRAN_ERROR: + return "Fortran wrapper detected an inconsistency in C return values"; + case SMIOL_LIBRARY_ERROR: + return "bad return code from a library call"; + case SMIOL_WRONG_ARG_TYPE: + return "argument is of the wrong type"; + case SMIOL_INSUFFICIENT_ARG: + return "argument is of insufficient size"; + default: + return "Unknown error"; + } +} + + +/******************************************************************************** + * + * SMIOL_lib_error_string + * + * Returns an error string for a third-party library called by SMIOL. + * + * Returns an error string corresponding to an error that was generated by + * a third-party library that was called by SMIOL. The library that was the source + * of the error, as well as the library-specific error code, are retrieved from + * a SMIOL context. If successive library calls resulted in errors, only the error + * string for the last of these errors will be returned. The error string is + * null-terminated, but it does not contain a newline character. + * + ********************************************************************************/ +const char *SMIOL_lib_error_string(struct SMIOL_context *context) +{ + if (context == NULL) { + return "SMIOL_context argument is a NULL pointer"; + } + + switch (context->lib_type) { +#ifdef SMIOL_PNETCDF + case SMIOL_LIBRARY_PNETCDF: + return ncmpi_strerror(context->lib_ierr); +#endif + default: + return "Could not find matching library for the source of the error"; + } +} + + +/******************************************************************************** + * + * SMIOL_set_option + * + * Sets an option for the SMIOL library. + * + * Detailed description. + * + ********************************************************************************/ +int SMIOL_set_option(void) +{ + return SMIOL_SUCCESS; +} + +/******************************************************************************** + * + * SMIOL_set_frame + * + * Set the frame for the unlimited dimension for an open file + * + * For an open SMIOL file handle, set the frame for the unlimited dimension. + * After setting the frame for a file, writing to a variable that is + * dimensioned by the unlimited dimension will write to the last set frame, + * overwriting any current data that maybe present in that frame. + * + * SMIOL_SUCCESS will be returned if the frame is successfully set otherwise an + * error will return. + * + ********************************************************************************/ +int SMIOL_set_frame(struct SMIOL_file *file, SMIOL_Offset frame) +{ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + file->frame = frame; + return SMIOL_SUCCESS; +} + +/******************************************************************************** + * + * SMIOL_get_frame + * + * Return the current frame of an open file + * + * Get the current frame of an open file. Upon success, SMIOL_SUCCESS will be + * returned, otherwise an error will be returned. + * + ********************************************************************************/ +int SMIOL_get_frame(struct SMIOL_file *file, SMIOL_Offset *frame) +{ + if (file == NULL || frame == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + *frame = file->frame; + return SMIOL_SUCCESS; +} + + +/******************************************************************************* + * + * SMIOL_create_decomp + * + * Creates a mapping between compute elements and I/O elements. + * + * Given arrays of global element IDs that each task computes, this routine + * works out a mapping of elements between compute and I/O tasks. + * + * The aggregation factor is used to indicate the size of subsets of ranks + * that will gather fields onto a single rank in each subset before transferring + * that field from compute to output tasks; in a symmetric way, it also + * indicates the size of subsets over which fields will be scattered after they + * are transferred from input tasks to a single compute tasks in each subset. + * + * An aggregation factor of 0 indicates that the implementation should choose + * a suitable aggregation factor (usually matching the size of shared-memory + * domains), while a positive integer specifies a specific size for task groups + * to be used for aggregation. + * + * If all input arguments are determined to be valid and if the routine is + * successful in working out a mapping, the decomp pointer is allocated and + * given valid contents, and SMIOL_SUCCESS is returned; otherwise a non-success + * error code is returned and the decomp pointer is NULL. + * + *******************************************************************************/ +int SMIOL_create_decomp(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + int aggregation_factor, + struct SMIOL_decomp **decomp) +{ + size_t i; + size_t n_io_elements, n_io_elements_global; + size_t io_start, io_count; + SMIOL_Offset *io_elements; + MPI_Comm comm; + MPI_Datatype dtype; + int ierr; + + size_t n_compute_elements_agg; + SMIOL_Offset *compute_elements_agg = NULL; + MPI_Comm agg_comm = MPI_COMM_NULL; + int *counts = NULL; + int *displs = NULL; + int actual_agg_factor; + + + /* + * Minimal check on the validity of arguments + */ + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + if (compute_elements == NULL && n_compute_elements != 0) { + return SMIOL_INVALID_ARGUMENT; + } + + if (aggregation_factor < 0) { + return SMIOL_INVALID_ARGUMENT; + } + + comm = MPI_Comm_f2c(context->fcomm); + + /* + * Figure out MPI_Datatype for size_t... there must be a better way... + */ + switch (sizeof(size_t)) { + case sizeof(uint64_t): + dtype = MPI_UINT64_T; + break; + case sizeof(uint32_t): + dtype = MPI_UINT32_T; + break; + case sizeof(uint16_t): + dtype = MPI_UINT16_T; + break; + default: + return SMIOL_MPI_ERROR; + } + + /* + * Based on the number of compute elements for each task, determine + * the total number of elements across all tasks for I/O. The assumption + * is that the number of elements to read/write is equal to the size of + * the set of compute elements. + */ + n_io_elements = n_compute_elements; + if (MPI_SUCCESS != MPI_Allreduce((const void *)&n_io_elements, + (void *)&n_io_elements_global, + 1, dtype, MPI_SUM, comm)) { + return SMIOL_MPI_ERROR; + } + + /* + * Determine the contiguous range of elements to be read/written by + * this MPI task + */ + ierr = get_io_elements(context->comm_rank, + context->num_io_tasks, context->io_stride, + n_io_elements_global, &io_start, &io_count); + + /* + * Fill in io_elements from io_start through io_start + io_count - 1 + */ + io_elements = NULL; + if (io_count > 0) { + io_elements = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) + * n_io_elements_global); + if (io_elements == NULL) { + return SMIOL_MALLOC_FAILURE; + } + for (i = 0; i < io_count; i++) { + io_elements[i] = (SMIOL_Offset)(io_start + i); + } + } + + /* + * If aggregation_factor != 1, aggregate the list of compute_elements + * before building the mapping + */ + if (aggregation_factor != 1) { + int comm_rank = context->comm_rank; + + /* + * Create intracommunicators for aggregation + */ + if (aggregation_factor == 0) { + ierr = MPI_Comm_split_type(comm, MPI_COMM_TYPE_SHARED, + comm_rank, MPI_INFO_NULL, + &agg_comm); + } else { + ierr = MPI_Comm_split(comm, + (comm_rank / aggregation_factor), + comm_rank, + &agg_comm); + } + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_split failed with code %i\n", + ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Comm_size(agg_comm, &actual_agg_factor); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_size failed with code %i\n", + ierr); + return SMIOL_MPI_ERROR; + } + + /* + * Create aggregated compute_elements list if the actual + * aggregation factor is > 1 + */ + if (actual_agg_factor > 1) { + aggregate_list(agg_comm, 0, n_compute_elements, + compute_elements, + &n_compute_elements_agg, + &compute_elements_agg, &counts, &displs); + } else { + MPI_Comm_free(&agg_comm); + n_compute_elements_agg = n_compute_elements; + compute_elements_agg = compute_elements; + } + } else { + actual_agg_factor = 1; + n_compute_elements_agg = n_compute_elements; + compute_elements_agg = compute_elements; + } + + /* + * Build the mapping between compute tasks and I/O tasks + */ + ierr = build_exchange(context, + n_compute_elements_agg, compute_elements_agg, + io_count, io_elements, + decomp); + + free(io_elements); + + if (actual_agg_factor > 1) { + (*decomp)->agg_factor = actual_agg_factor; + (*decomp)->agg_comm = MPI_Comm_c2f(agg_comm); + (*decomp)->n_compute = n_compute_elements; + (*decomp)->n_compute_agg = n_compute_elements_agg; + (*decomp)->counts = counts; + (*decomp)->displs = displs; + + free(compute_elements_agg); + } + + /* + * If decomp was successfully created, add io_start and io_count values + * to the decomp before returning + */ + if (ierr == SMIOL_SUCCESS) { + (*decomp)->io_start = io_start; + (*decomp)->io_count = io_count; + } + + return ierr; +} + + +/******************************************************************************** + * + * SMIOL_free_decomp + * + * Frees a mapping between compute elements and I/O elements. + * + * Free all memory of a SMIOL_decomp and returns SMIOL_SUCCESS. If decomp + * points to NULL, then do nothing and return SMIOL_SUCCESS. After this routine + * is called, no other SMIOL routines should use the freed SMIOL_decomp. + * + ********************************************************************************/ +int SMIOL_free_decomp(struct SMIOL_decomp **decomp) +{ + MPI_Comm comm; + + if ((*decomp) == NULL) { + return SMIOL_SUCCESS; + } + + free((*decomp)->comp_list); + free((*decomp)->io_list); + + comm = MPI_Comm_f2c((*decomp)->agg_comm); + if (comm != MPI_COMM_NULL) { + MPI_Comm_free(&comm); + } + if ((*decomp)->counts != NULL) { + free((*decomp)->counts); + } + if ((*decomp)->displs != NULL) { + free((*decomp)->displs); + } + + free((*decomp)); + *decomp = NULL; + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * build_start_count + * + * Constructs start[] and count[] arrays for parallel I/O operations + * + * Given a pointer to a SMIOL file that was previously opened, the name of + * a variable in that file, and a SMIOL decomp, this function returns several + * items that may be used when reading or writing the variable in parallel: + * + * 1) The size of each "element" of the variable, where an element is defined as + * a contiguous memory range associated with the slowest-varying, non-record + * dimension of the variable; for example, a variable + * float foo[nCells][nVertLevels] would have an element size of + * sizeof(float) * nVertLevels if nCells were a decomposed dimension. + * + * For non-decomposed variables, the element size is the size of one record + * of the entire variable. + * + * 2) The size of the fundamental datatype for the variable; for example, a + * float variable would yield sizeof(float). + * + * 3) The number of dimensions for the variable, including any unlimited/record + * dimension. + * + * 4) Whether the variable has a record (unlimited) dimension. + * + * 5) The start[] and count[] arrays (each with size ndims) to be read or written + * by an MPI rank using the I/O decomposition described in decomp. + * + * If the decomp argument is NULL, the variable is to be read or written as + * a non-decomposed variable; typically, only MPI rank 0 will write + * the non-decomposed variable, and all MPI ranks will read the non-decomposed + * variable. + * + * Depending on the value of the write_or_read argument -- either START_COUNT_READ + * or START_COUNT_WRITE -- the count[] values will be set so that all ranks will + * read the variable, or only rank 0 will write the variable if the variable is + * not decomposed. + * + ********************************************************************************/ +int build_start_count(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, + int write_or_read, size_t *element_size, + size_t *basic_type_size, int *ndims, + int *has_unlimited_dim, + size_t **start, size_t **count) +{ + int i; + int ierr; + int vartype; + char **dimnames; + SMIOL_Offset *dimsizes; + +/* TO DO - define maximum string size, currently assumed to be 64 chars */ + + /* + * Figure out type of the variable, as well as its dimensions + */ + ierr = SMIOL_inquire_var(file, varname, &vartype, ndims, NULL); + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + + dimnames = malloc(sizeof(char *) * (size_t)(*ndims)); + if (dimnames == NULL) { + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + for (i = 0; i < *ndims; i++) { + dimnames[i] = malloc(sizeof(char) * (size_t)64); + if (dimnames[i] == NULL) { + int j; + + for (j = 0; j < i; j++) { + free(dimnames[j]); + } + free(dimnames); + + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + } + + ierr = SMIOL_inquire_var(file, varname, NULL, NULL, dimnames); + if (ierr != SMIOL_SUCCESS) { + for (i = 0; i < *ndims; i++) { + free(dimnames[i]); + } + free(dimnames); + return ierr; + } + + dimsizes = malloc(sizeof(SMIOL_Offset) * (size_t)(*ndims)); + if (dimsizes == NULL) { + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + /* + * It is assumed that only the first dimension can be an unlimited + * dimension, so by inquiring about dimensions from last to first, we + * can be guaranteed that has_unlimited_dim will be set correctly at + * the end of the loop over dimensions + */ + *has_unlimited_dim = 0; + for (i = (*ndims-1); i >= 0; i--) { + ierr = SMIOL_inquire_dim(file, dimnames[i], &dimsizes[i], + has_unlimited_dim); + if (ierr != SMIOL_SUCCESS) { + for (i = 0; i < *ndims; i++) { + free(dimnames[i]); + } + free(dimnames); + free(dimsizes); + + return ierr; + } + } + + for (i = 0; i < *ndims; i++) { + free(dimnames[i]); + } + free(dimnames); + + /* + * Set basic size of each element in the field + */ + *element_size = 1; + switch (vartype) { + case SMIOL_REAL32: + *basic_type_size = sizeof(float); + break; + case SMIOL_REAL64: + *basic_type_size = sizeof(double); + break; + case SMIOL_INT32: + *basic_type_size = sizeof(int); + break; + case SMIOL_CHAR: + *basic_type_size = sizeof(char); + break; + } + *element_size = *basic_type_size; + + *start = malloc(sizeof(size_t) * (size_t)(*ndims)); + if (*start == NULL) { + free(dimsizes); + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + *count = malloc(sizeof(size_t) * (size_t)(*ndims)); + if (*count == NULL) { + free(dimsizes); + free(start); + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + /* + * Build start/count description of the part of the variable to be + * read or written. Simultaneously, compute the product of all + * non-unlimited, non-decomposed dimension sizes, scaled by the basic + * element size to get the effective size of each element to be read or + * written + */ + for (i = 0; i < *ndims; i++) { + (*start)[i] = (size_t)0; + (*count)[i] = (size_t)dimsizes[i]; + + /* + * If variable has an unlimited dimension, set start to current + * frame and count to one + */ + if (*has_unlimited_dim && i == 0) { + (*start)[i] = (size_t)file->frame; + (*count)[i] = (size_t)1; + } + + /* + * If variable is decomposed, set the slowest-varying, + * non-record dimension start and count based on values from + * the decomp structure + */ + if (decomp) { + if ((!*has_unlimited_dim && i == 0) || + (*has_unlimited_dim && i == 1)) { + (*start)[i] = decomp->io_start; + (*count)[i] = decomp->io_count; + } else { + *element_size *= (*count)[i]; + } + } else { + *element_size *= (*count)[i]; + } + + if (write_or_read == START_COUNT_WRITE) { + /* + * If the variable is not decomposed, only MPI rank 0 + * will have non-zero count values so that all MPI ranks + * do no try to write the same offsets + */ + if (!decomp && file->context->comm_rank != 0) { + (*count)[i] = 0; + } + } + } + + free(dimsizes); + + return SMIOL_SUCCESS; +} + + +#ifdef SMIOL_PNETCDF +/******************************************************************************** + * + * write_chunk_pnetcdf + * + * Write a chunk of a variable to a file using the Parallel-NetCDF library + * + * Given a file and information about a variable in the file, write a chunk of + * memory to the variable according to start/count arrays. If the size of the + * chunk to be written will fit within any buffer attached to the file, the + * chunk is written using the Parallel-NetCDF buffered non-blocking interface; + * otherwise, the chunk is written using the blocking write interface, ensuring + * that not more than 2 GiB is written in any single call to ncmpi_put_vara_all. + * + * The return value from this function will be NC_NOERR in case no errors + * occurred in calls to the Parallel-NetCDF library, or a Parallel-NetCDF error + * code otherwise. + * + * Within this function, return error codes from MPI calls are ignored. + * + ********************************************************************************/ +int write_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + const void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ) +{ + int ierr = NC_NOERR; + long lusage; + long max_usage; + size_t element_size; + int iter_idx; + int i; + + /* + * For scalar variables (with or without an unlimited dimension), + * just write with a single call to the blocking write interface. + */ + if (ndims == 0 || (has_unlimited_dim && ndims == 1)) { + ierr = ncmpi_bput_vara(file->ncidp, + varidp, + mpi_start, mpi_count, + buf_p, + 0, MPI_DATATYPE_NULL, + &(file->reqs[(file->n_reqs++)])); + return ierr; + } + + /* + * Set iter_idx to be the slowest-varying non-record (non-unlimited) + * dimension for the variable + */ + iter_idx = 0; + if (has_unlimited_dim) iter_idx++; + + /* + * Let element_size be the product of the fastest-varying dimension + * sizes beyond the iter_idx dimension multiplied by the basic type + * size for this variable. + */ + element_size = basic_type_size; + for (i = iter_idx + 1; i < ndims; i++) { + element_size *= mpi_count[i]; + } + + /* + * Compute the maximum total number of bytes to be written by any MPI + * task for their chunks of the variable + */ + lusage = (long)element_size * mpi_count[iter_idx]; + MPI_Allreduce(&lusage, &max_usage, 1, MPI_LONG, + MPI_MAX, io_file_comm); + + /* + * If the maximum size of a chunk of data to be written is larger than + * the buffer size, just write through the non-buffered interface; + * otherwise, the ncmpi_bput_vara call will fail. + */ + if (max_usage > file->bufsize || max_usage > ((MPI_Offset)INT_MAX)) { + MPI_Offset remaining_count; + MPI_Offset max_count; + long done, global_done; + size_t buf_offset; + + max_count = ((MPI_Offset)INT_MAX) / element_size; + remaining_count = mpi_count[iter_idx]; + + /* + * Bound the number of values to be written along the slowest- + * varying non-record dimension to ensure that not more than + * 2 GiB are written in the call to ncmpi_put_vara_all + */ + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + remaining_count -= mpi_count[iter_idx]; + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + global_done = 0; + buf_offset = 0; + + /* + * Keep calling ncmpi_put_vara_all on all I/O tasks as long as + * at least one task still has data to be written, writing at + * most 2 GiB at a time + */ + while (!global_done) { + ierr = ncmpi_put_vara_all(file->ncidp, + varidp, + mpi_start, mpi_count, + &((uint8_t *)buf_p)[buf_offset], + 0, MPI_DATATYPE_NULL); + + /* + * Update start/count values for slowest non-record + * dimension, and determine whether this task still has + * data to be written + */ + if (!done) { + buf_offset += (size_t)mpi_count[iter_idx] + * element_size; + mpi_start[iter_idx] += mpi_count[iter_idx]; + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + remaining_count -= mpi_count[iter_idx]; + + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + } + + if (ierr != NC_NOERR) { + done = -1; + } + + /* + * Get done status across all I/O tasks + */ + MPI_Allreduce(&done, &global_done, 1, MPI_LONG, MPI_MIN, + MPI_Comm_f2c(file->io_file_comm)); + }; + + } else { + /* + * If executing this else branch, assume bufsize > 0 and + * that a buffer has therefore been attached to file. + */ + + MPI_Offset usage; + + /* + * Check how many bytes have been used in buffer on this task + */ + ierr = ncmpi_inq_buffer_usage(file->ncidp, + &usage); + lusage = usage + + (long)element_size * mpi_count[iter_idx]; + + MPI_Allreduce(&lusage, &max_usage, 1, + MPI_LONG, MPI_MAX, + io_file_comm); + + /* + * If making a buffered write would cause the remaining buffer + * size to be exceeded on any task, wait for non-blocking + * writes to complete + */ + if ((size_t)max_usage > file->bufsize + || file->n_reqs == MAX_REQS) { + ierr = ncmpi_wait_all(file->ncidp, file->n_reqs, + file->reqs, NULL); /* statuses */ + file->n_reqs = 0; + } + + if (ierr == NC_NOERR) { + ierr = ncmpi_bput_vara(file->ncidp, + varidp, + mpi_start, mpi_count, + buf_p, + 0, MPI_DATATYPE_NULL, + &(file->reqs[(file->n_reqs++)])); + } + } + + return ierr; +} + + +/******************************************************************************** + * + * read_chunk_pnetcdf + * + * Read a chunk of a variable from a file using the Parallel-NetCDF library + * + * Given a file and information about a variable in the file, read a chunk of + * memory from the variable according to start/count arrays. The chunk is always + * read using the blocking read interface while ensuring that not more than 2 + * GiB is read in any single call to ncmpi_get_vara_all. + * + * The return value from this function will be NC_NOERR in case no errors + * occurred in calls to the Parallel-NetCDF library, or a Parallel-NetCDF error + * code otherwise. + * + * Within this function, return error codes from MPI calls are ignored. + * + ********************************************************************************/ +int read_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ) +{ + int ierr = NC_NOERR; + int iter_idx; + MPI_Offset remaining_count; + MPI_Offset max_count; + long done, global_done; + size_t element_size; + size_t buf_offset; + int i; + + /* + * For scalar variables (with or without an unlimited dimension), + * just read with a single call to the blocking read interface. + */ + if (ndims == 0 || (has_unlimited_dim && ndims == 1)) { + ierr = ncmpi_get_vara_all(file->ncidp, + varidp, + mpi_start, mpi_count, + buf_p, + 0, MPI_DATATYPE_NULL); + return ierr; + } + + /* + * Set iter_idx to be the slowest-varying non-record (non-unlimited) + * dimension for the variable + */ + iter_idx = 0; + if (has_unlimited_dim) iter_idx++; + + /* + * Let element_size be the product of the fastest-varying dimension + * sizes beyond the iter_idx dimension multiplied by the basic type + * size for this variable. + */ + element_size = basic_type_size; + for (i = iter_idx + 1; i < ndims; i++) { + element_size *= mpi_count[i]; + } + + max_count = ((MPI_Offset)INT_MAX) / element_size; + remaining_count = mpi_count[iter_idx]; + + /* + * Bound the number of values to be read along the slowest-varying + * non-record dimension to ensure that not more than 2 GiB are read + * in the call to ncmpi_get_vara_all + */ + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + + remaining_count -= mpi_count[iter_idx]; + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + global_done = 0; + buf_offset = 0; + + /* + * Keep calling ncmpi_get_vara_all on all I/O tasks as long as at least + * one task still has data to be read, reading at most 2 GiB at a time + */ + while (!global_done) { + ierr = ncmpi_get_vara_all(file->ncidp, + varidp, + mpi_start, mpi_count, + &((uint8_t *)buf_p)[buf_offset], + 0, MPI_DATATYPE_NULL); + + /* + * Update start/count values for slowest non-record dimension, + * and determine whether this task still has data to be read + */ + if (!done) { + buf_offset += (size_t)mpi_count[iter_idx] * element_size; + mpi_start[iter_idx] += mpi_count[iter_idx]; + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + remaining_count -= mpi_count[iter_idx]; + + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + } + + if (ierr != NC_NOERR) { + done = -1; + } + + /* + * Get done status across all I/O tasks + */ + MPI_Allreduce(&done, &global_done, 1, MPI_LONG, MPI_MIN, + io_file_comm); + }; + + return ierr; +} +#endif diff --git a/src/external/SMIOL/smiol.h b/src/external/SMIOL/smiol.h new file mode 100644 index 0000000000..42589d9797 --- /dev/null +++ b/src/external/SMIOL/smiol.h @@ -0,0 +1,73 @@ +/******************************************************************************* + * SMIOL -- The Simple MPAS I/O Library + *******************************************************************************/ +#ifndef SMIOL_H +#define SMIOL_H + +#include "smiol_types.h" + + +/* + * Library methods + */ +int SMIOL_fortran_init(MPI_Fint comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context); +int SMIOL_init(MPI_Comm comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context); +int SMIOL_finalize(struct SMIOL_context **context); +int SMIOL_inquire(void); + +/* + * File methods + */ +int SMIOL_open_file(struct SMIOL_context *context, const char *filename, + int mode, struct SMIOL_file **file, size_t bufsize); +int SMIOL_close_file(struct SMIOL_file **file); + +/* + * Dimension methods + */ +int SMIOL_define_dim(struct SMIOL_file *file, const char *dimname, SMIOL_Offset dimsize); +int SMIOL_inquire_dim(struct SMIOL_file *file, const char *dimname, + SMIOL_Offset *dimsize, int *is_unlimited); + +/* + * Variable methods + */ +int SMIOL_define_var(struct SMIOL_file *file, const char *varname, int vartype, int ndims, const char **dimnames); +int SMIOL_inquire_var(struct SMIOL_file *file, const char *varname, int *vartype, int *ndims, char **dimnames); +int SMIOL_put_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, const void *buf); +int SMIOL_get_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, void *buf); + +/* + * Attribute methods + */ +int SMIOL_define_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int att_type, const void *att); + +int SMIOL_inquire_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int *att_type, + SMIOL_Offset *att_len, void *att); + +/* + * Control methods + */ +int SMIOL_sync_file(struct SMIOL_file *file); +const char *SMIOL_error_string(int errno); +const char *SMIOL_lib_error_string(struct SMIOL_context *context); +int SMIOL_set_option(void); +int SMIOL_set_frame(struct SMIOL_file *file, SMIOL_Offset frame); +int SMIOL_get_frame(struct SMIOL_file *file, SMIOL_Offset *frame); + +/* + * Decomposition methods + */ +int SMIOL_create_decomp(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + int aggregation_factor, + struct SMIOL_decomp **decomp); +int SMIOL_free_decomp(struct SMIOL_decomp **decomp); + +#endif diff --git a/src/external/SMIOL/smiol_codes.inc b/src/external/SMIOL/smiol_codes.inc new file mode 100644 index 0000000000..456bcc7bed --- /dev/null +++ b/src/external/SMIOL/smiol_codes.inc @@ -0,0 +1,21 @@ +#define SMIOL_SUCCESS (0) +#define SMIOL_MALLOC_FAILURE (-1) +#define SMIOL_INVALID_ARGUMENT (-2) +#define SMIOL_MPI_ERROR (-3) +#define SMIOL_FORTRAN_ERROR (-4) +#define SMIOL_LIBRARY_ERROR (-5) +#define SMIOL_WRONG_ARG_TYPE (-6) +#define SMIOL_INSUFFICIENT_ARG (-7) + +#define SMIOL_FILE_CREATE (1) +#define SMIOL_FILE_READ (2) +#define SMIOL_FILE_WRITE (4) + +#define SMIOL_LIBRARY_UNKNOWN (1000) +#define SMIOL_LIBRARY_PNETCDF (1001) + +#define SMIOL_REAL32 (2000) +#define SMIOL_REAL64 (2001) +#define SMIOL_INT32 (2002) +#define SMIOL_CHAR (2003) +#define SMIOL_UNKNOWN_VAR_TYPE (2004) diff --git a/src/external/SMIOL/smiol_types.h b/src/external/SMIOL/smiol_types.h new file mode 100644 index 0000000000..015faebef5 --- /dev/null +++ b/src/external/SMIOL/smiol_types.h @@ -0,0 +1,85 @@ +/******************************************************************************* + * SMIOL -- The Simple MPAS I/O Library + *******************************************************************************/ +#ifndef SMIOL_TYPES_H +#define SMIOL_TYPES_H + +#include +#include "mpi.h" + + +/* If SMIOL_Offset is redefined, interoperable Fortran types and interfaces must also be updated */ +typedef int64_t SMIOL_Offset; + + +#define TRIPLET_SIZE ((size_t)3) + + +/* + * Types + */ +struct SMIOL_context { + MPI_Fint fcomm; /* Fortran handle to MPI communicator */ + int comm_size; /* Size of MPI communicator */ + int comm_rank; /* Rank within MPI communicator */ + + int num_io_tasks; /* The number of I/O tasks */ + int io_stride; /* The stride between I/O tasks in the communicator */ + + int lib_ierr; /* Library-specific error code */ + int lib_type; /* From which library the error code originated */ +}; + +struct SMIOL_file { + struct SMIOL_context *context; /* Context for this file */ + SMIOL_Offset frame; /* Current frame of the file */ +#ifdef SMIOL_PNETCDF + int state; /* parallel-netCDF file state (i.e. Define or data mode) */ + int ncidp; /* parallel-netCDF file handle */ + size_t bufsize; /* Size of buffer attached to this file */ + int n_reqs; /* Number of pending non-blocking requests */ + int *reqs; /* Array of pending non-blocking request handles */ +#endif + int io_task; /* 1 = this task performs I/O calls + 0 = no I/O calls on this task */ + MPI_Fint io_file_comm; /* Communicator shared by all tasks with + io_task == 1 */ + MPI_Fint io_group_comm; /* Communicator shared by tasks associated with + an I/O task, usually 1 I/O task and N-1 + non-I/O tasks, where N is the I/O stride */ +}; + +struct SMIOL_decomp { + /* + * The lists below are structured as follows: + * list[0] - the number of neighbors for which a task sends/recvs + * | + * list[n] - neighbor task ID | repeated for + * list[n+1] - number of elements, m, to send/recv to/from the neighbor | each neighbor + * list[n+2 .. n+2+m] - local element IDs to send/recv to/from the neighbor | + * | + */ + SMIOL_Offset *comp_list; /* Elements to be sent/received from/on a compute task */ + SMIOL_Offset *io_list; /* Elements to be sent/received from/on an I/O task */ + + struct SMIOL_context *context; /* Context for this decomp */ + + size_t io_start; /* The starting offset on disk for I/O by a task */ + size_t io_count; /* The number of elements for I/O by a task */ + + int agg_factor; /* Aggregation factor, or size of aggregation group */ + MPI_Fint agg_comm; /* Communicator for aggregation/deaggregation operations */ + size_t n_compute; /* Number of un-aggregated compute elements on the task */ + size_t n_compute_agg; /* Number of aggregated compute elements on the task */ + int *counts; /* Compute element counts for tasks in aggregation group */ + int *displs; /* Displacements in aggregated list of elements for tasks */ + /* in aggregation group */ +}; + + +/* + * Return error codes + */ +#include "smiol_codes.inc" + +#endif diff --git a/src/external/SMIOL/smiol_utils.c b/src/external/SMIOL/smiol_utils.c new file mode 100644 index 0000000000..9a9b35282a --- /dev/null +++ b/src/external/SMIOL/smiol_utils.c @@ -0,0 +1,1263 @@ +#include +#include +#include "smiol_utils.h" + +/* + * Prototypes for functions used only internally by SMIOL utilities + */ +static int comp_sort_0(const void *a, const void *b); +static int comp_sort_1(const void *a, const void *b); +static int comp_sort_2(const void *a, const void *b); +static int comp_search_0(const void *a, const void *b); +static int comp_search_1(const void *a, const void *b); +static int comp_search_2(const void *a, const void *b); + + +/******************************************************************************* + * + * sort_triplet_array + * + * Sorts an array of triplets of SMIOL_Offset values in ascending order + * + * Given a pointer to an array of SMIOL_Offset triplets, sorts the array in + * ascending order on the specified entry: 0 sorts on the first value in + * the triplets, 1 sorts on the second value, and 2 sorts on the third. + * + * If the sort_entry is 1 or 2, the relative position of two triplets whose + * values in that entry match will be determined by their values in the first + * entry. + * + * The sort is not guaranteed to be stable. + * + *******************************************************************************/ +void sort_triplet_array(size_t n_arr, SMIOL_Offset *arr, int sort_entry) +{ + size_t width = sizeof(SMIOL_Offset) * TRIPLET_SIZE; + + switch (sort_entry) { + case 0: + qsort((void *)arr, n_arr, width, comp_sort_0); + break; + case 1: + qsort((void *)arr, n_arr, width, comp_sort_1); + break; + case 2: + qsort((void *)arr, n_arr, width, comp_sort_2); + break; + } +} + + +/******************************************************************************* + * + * search_triplet_array + * + * Searches a sorted array of triplets of SMIOL_Offset values + * + * Given a pointer to a sorted array of SMIOL_Offset triplets, searches + * the array on the specified entry for the key value. A search_entry value of + * 0 searches for the key in the first entry of each triplet, 1 searches in + * the second entry, and 2 searches in the third. + * + * If the key is found, the address of the triplet will be returned; otherwise, + * a NULL pointer is returned. + * + * If the key occurs in more than one triplet at the specified entry, there is + * no guarantee as to which triplet's address will be returned. + * + *******************************************************************************/ +SMIOL_Offset *search_triplet_array(SMIOL_Offset key, + size_t n_arr, SMIOL_Offset *arr, + int search_entry) +{ + SMIOL_Offset *res; + SMIOL_Offset key3[TRIPLET_SIZE]; + size_t width = sizeof(SMIOL_Offset) * TRIPLET_SIZE; + + key3[search_entry] = key; + + switch (search_entry) { + case 0: + res = (SMIOL_Offset *)bsearch((const void *)&key3, + (const void *)arr, n_arr, + width, comp_search_0); + break; + case 1: + res = (SMIOL_Offset *)bsearch((const void *)&key3, + (const void *)arr, n_arr, + width, comp_search_1); + break; + case 2: + res = (SMIOL_Offset *)bsearch((const void *)&key3, + (const void *)arr, n_arr, + width, comp_search_2); + break; + default: + res = NULL; + } + + return res; +} + + +/******************************************************************************* + * + * transfer_field + * + * Transfers a field between compute and I/O tasks + * + * Given a SMIOL_decomp and a direction, which determines whether the input + * field is transferred from compute tasks to I/O tasks or from I/O tasks to + * compute tasks, this function transfers the input field to the output field. + * + * The size in bytes of the elements in the field to be transferred is given by + * element_size; for example, a single-precision field would set element_size + * to sizeof(float). + * + * The caller must have already allocated the out_field argument with sufficient + * space to contain the field. + * + * If no errors are detected in the input arguments or in the transfer of + * the input field to the output field, SMIOL_SUCCESS is returned. + * + *******************************************************************************/ +int transfer_field(const struct SMIOL_decomp *decomp, int dir, + size_t element_size, const void *in_field, void *out_field) +{ + MPI_Comm comm; + int comm_rank; + + SMIOL_Offset *sendlist = NULL; + SMIOL_Offset *recvlist = NULL; + + MPI_Request *send_reqs = NULL; + MPI_Request *recv_reqs = NULL; + + uint8_t **send_bufs = NULL; + uint8_t **recv_bufs = NULL; + uint8_t *in_bytes = NULL; + uint8_t *out_bytes = NULL; + + size_t ii, kk; + size_t n_neighbors_send; + size_t n_neighbors_recv; + int64_t pos; + int64_t pos_src = -1; + int64_t pos_dst = -1; + + /* + * The following are ints because they correspond to MPI arguments + * that are ints, or they iterate over an int bound + */ + int taskid; + int n_send, n_recv; + int j; + + + if (decomp == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + comm = MPI_Comm_f2c(decomp->context->fcomm); + comm_rank = decomp->context->comm_rank; + + /* + * Throughout this function, operate on the fields as arrays of bytes + */ + in_bytes = (uint8_t *)in_field; + out_bytes = (uint8_t *)out_field; + + /* + * Set send and recv lists based on exchange direction + */ + if (dir == SMIOL_COMP_TO_IO) { + sendlist = decomp->comp_list; + recvlist = decomp->io_list; + } else if (dir == SMIOL_IO_TO_COMP) { + sendlist = decomp->io_list; + recvlist = decomp->comp_list; + } else { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Determine how many other MPI tasks to communicate with, and allocate + * request lists and buffer pointers + */ + n_neighbors_send = (size_t)(sendlist[0]); + n_neighbors_recv = (size_t)(recvlist[0]); + + /* + * Check that we have non-NULL in_field and out_field arguments + * in agreement with the number of neighbors to send/recv to/from + */ + if ((in_field == NULL && n_neighbors_send != 0) + || (out_field == NULL && n_neighbors_recv != 0)) { + return SMIOL_INVALID_ARGUMENT; + } + + send_reqs = (MPI_Request *)malloc(sizeof(MPI_Request) + * n_neighbors_send); + recv_reqs = (MPI_Request *)malloc(sizeof(MPI_Request) + * n_neighbors_recv); + + send_bufs = (uint8_t **)malloc(sizeof(uint8_t *) * n_neighbors_send); + recv_bufs = (uint8_t **)malloc(sizeof(uint8_t *) * n_neighbors_recv); + + /* + * Post receives + */ + pos = 1; + for (ii = 0; ii < n_neighbors_recv; ii++) { + taskid = (int)recvlist[pos++]; + n_recv = (int)recvlist[pos++]; + if (taskid != comm_rank) { + recv_bufs[ii] = (uint8_t *)malloc(sizeof(uint8_t) + * element_size + * (size_t)n_recv); + + MPI_Irecv((void *)recv_bufs[ii], + n_recv * (int)element_size, + MPI_BYTE, taskid, comm_rank, comm, + &recv_reqs[ii]); + } + else { + /* + * This is a receive from ourself - save position in + * recvlist for local copy, below + */ + pos_dst = pos - 1; /* Offset of n_recv */ + recv_bufs[ii] = NULL; + } + pos += n_recv; + } + + /* + * Post sends + */ + pos = 1; + for (ii = 0; ii < n_neighbors_send; ii++) { + taskid = (int)sendlist[pos++]; + n_send = (int)sendlist[pos++]; + if (taskid != comm_rank) { + send_bufs[ii] = (uint8_t *)malloc(sizeof(uint8_t) + * element_size + * (size_t)n_send); + + /* Pack send buffer */ + for (j = 0; j < n_send; j++) { + size_t out_idx = (size_t)j + * element_size; + size_t in_idx = (size_t)sendlist[pos] + * element_size; + + for (kk = 0; kk < element_size; kk++) { + send_bufs[ii][out_idx + kk] = in_bytes[in_idx + kk]; + } + pos++; + } + + MPI_Isend((void *)send_bufs[ii], + n_send * (int)element_size, + MPI_BYTE, taskid, taskid, comm, + &send_reqs[ii]); + } + else { + /* + * This is a send to ourself - save position in + * sendlist for local copy, below + */ + pos_src = pos - 1; /* Offset of n_send */ + send_bufs[ii] = NULL; + pos += n_send; + } + } + + /* + * Handle local copies + */ + if (pos_src >= 0 && pos_dst >= 0) { + + /* n_send and n_recv should actually be identical */ + n_send = (int)sendlist[pos_src++]; + n_recv = (int)recvlist[pos_dst++]; + + for (j = 0; j < n_send; j++) { + size_t out_idx = (size_t)recvlist[pos_dst] + * element_size; + size_t in_idx = (size_t)sendlist[pos_src] + * element_size; + + for (kk = 0; kk < element_size; kk++) { + out_bytes[out_idx + kk] = in_bytes[in_idx + kk]; + } + pos_dst++; + pos_src++; + } + } + + /* + * Wait on receives + */ + pos = 1; + for (ii = 0; ii < n_neighbors_recv; ii++) { + taskid = (int)recvlist[pos++]; + n_recv = (int)recvlist[pos++]; + if (taskid != comm_rank) { + MPI_Wait(&recv_reqs[ii], MPI_STATUS_IGNORE); + + /* Unpack receive buffer */ + for (j = 0; j < n_recv; j++) { + size_t out_idx = (size_t)recvlist[pos] + * element_size; + size_t in_idx = (size_t)j + * element_size; + + for (kk = 0; kk < element_size; kk++) { + out_bytes[out_idx + kk] = recv_bufs[ii][in_idx + kk]; + } + pos++; + } + } + else { + /* + * A receive from ourself - just skip to next neighbor + * in the recvlist + */ + pos += n_recv; + } + + /* + * The receive buffer for the current neighbor can now be freed + */ + if (recv_bufs[ii] != NULL) { + free(recv_bufs[ii]); + } + } + + /* + * Wait on sends + */ + pos = 1; + for (ii = 0; ii < n_neighbors_send; ii++) { + taskid = (int)sendlist[pos++]; + n_send = (int)sendlist[pos++]; + if (taskid != comm_rank) { + MPI_Wait(&send_reqs[ii], MPI_STATUS_IGNORE); + } + + /* + * The send buffer for the current neighbor can now be freed + */ + if (send_bufs[ii] != NULL) { + free(send_bufs[ii]); + } + + pos += n_send; + } + + /* + * Free request lists and buffer pointers + */ + free(send_reqs); + free(recv_reqs); + free(send_bufs); + free(recv_bufs); + + return SMIOL_SUCCESS; +} + + +/******************************************************************************* + * + * aggregate_list + * + * Aggregates lists of elements from across all ranks onto a chosen root rank + * + * On entry, each MPI rank supplies a list of SMIOL_Offset values as well as the + * size of that input list. The input list may be zero size. + * + * Upon successful return, for the root rank, the out_list argument will point + * to an allocated array containing the aggregated elements from all MPI ranks + * in the communicator, and n_out will specify the number of elements in the + * output array. On all other ranks, n_out will be zero, and out_list will be a + * NULL pointer. + * + * Also on the root rank, the counts and displs arrays will be allocated with + * size equal to the size of the communicator, and they will contain the number + * of elements in the aggregated list from each MPI rank as well as the + * beginning offset in the aggregated list of elements from each rank. On all + * non-root ranks, counts and displs will be returned as NULL pointers. + * + * Although the number of elements in each input list is given by a size_t, + * the number of elements must not exceed the maximum representable value of + * a signed integer due to restrictions imposed by MPI argument types. + * Similarly, it must be ensured that the number of output elements does not + * exceed the maximum representable value of a signed integer. + * + * If no errors occurred, 0 is returned. Otherwise, a value of 1 is returned. + * + *******************************************************************************/ +int aggregate_list(MPI_Comm comm, int root, size_t n_in, SMIOL_Offset *in_list, + size_t *n_out, SMIOL_Offset **out_list, + int **counts, int **displs) +{ + int comm_size; + int comm_rank; + int err; + int i; + int n_in_i; + + + *n_out = 0; + *out_list = NULL; + + *counts = NULL; + *displs = NULL; + + n_in_i = (int)n_in; + + if (MPI_Comm_size(comm, &comm_size) != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_size failed in aggregate_list\n"); + return 1; + } + + if (MPI_Comm_rank(comm, &comm_rank) != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_rank failed in aggregate_list\n"); + return 1; + } + + if (comm_rank == root) { + *counts = (int *)malloc(sizeof(int) * (size_t)(comm_size)); + *displs = (int *)malloc(sizeof(int) * (size_t)(comm_size)); + } + + /* + * Gather the number of input elements from all tasks onto root rank + */ + err = MPI_Gather((const void *)&n_in_i, 1, MPI_INT, + (void *)(*counts), 1, MPI_INT, root, comm); + if (err != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Gather failed in aggregate_list\n"); + return 1; + } + + /* + * Perform a scan of counts to get displs, and compute the number of + * output elements on root rank as the sum of the number of input + * elements across all tasks in the communicator + */ + if (comm_rank == root) { + (*displs)[0] = 0; + *n_out = (size_t)(*counts)[0]; + for (i = 1; i < comm_size; i++) { + (*displs)[i] = (*displs)[i-1] + (*counts)[i-1]; + *n_out += (size_t)(*counts)[i]; + } + + *out_list = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) + * (*n_out)); + } + + /* TO DO: Find an MPI type that is guaranteed to match SMIOL_Offset */ + /* For now, just return an error if MPI_LONG isn't appropriate */ + if (sizeof(long) != sizeof(SMIOL_Offset)) { + fprintf(stderr, "Error: sizeof(long) != sizeof(SMIOL_Offset)\n"); + return 1; + } + + err = MPI_Gatherv((const void *)in_list, n_in_i, MPI_LONG, + (void *)(*out_list), (*counts), (*displs), MPI_LONG, + root, comm); + if (err != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Gatherv failed in aggregate_list\n"); + return 1; + } + + return 0; +} + + +/******************************************************************************* + * + * get_io_elements + * + * Returns a contiguous range of I/O elements for an MPI task + * + * Given the rank of a task, a description of the I/O task arrangement -- + * the number of I/O tasks and the stride between I/O tasks -- as well as the + * total number of elements to read or write, compute the offset of the first + * I/O element as well as the number of elements to read or write for the task. + * + * If this routine is successful in producing a valid io_start and io_count, + * a value of 0 is returned; otherwise, a non-zero value is returned. + * + *******************************************************************************/ +int get_io_elements(int comm_rank, int num_io_tasks, int io_stride, + size_t n_io_elements, size_t *io_start, size_t *io_count) +{ + if (io_start == NULL || io_count == NULL) { + return 1; + } + + *io_start = 0; + *io_count = 0; + + if (comm_rank % io_stride == 0) { + size_t io_rank = (size_t)(comm_rank / io_stride); + size_t elems_per_task = (n_io_elements / (size_t)num_io_tasks); + + if (io_rank >= num_io_tasks) { + return 0; + } + + *io_start = io_rank * elems_per_task; + *io_count = elems_per_task; + + if (io_rank + 1 == (size_t)num_io_tasks) { + size_t remainder = n_io_elements + - (size_t)num_io_tasks * elems_per_task; + *io_count += remainder; + } + } + + return 0; +} + + +/******************************************************************************* + * + * build_exchange + * + * Builds a mapping between compute elements and I/O elements. + * + * Given arrays of global element IDs that each task computes and global element + * IDs that each task reads/writes, this routine works out a mapping of elements + * between compute and I/O tasks. + * + * If all input arguments are determined to be valid and if the routine is + * successful in working out a mapping, the decomp pointer is allocated and + * given valid contents, and SMIOL_SUCCESS is returned; otherwise a non-success + * error code is returned and the decomp pointer is NULL. + * + *******************************************************************************/ +int build_exchange(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + size_t n_io_elements, SMIOL_Offset *io_elements, + struct SMIOL_decomp **decomp) +{ + MPI_Comm comm; + int comm_size; + int comm_rank; + int ierr; + int i, j; + int count; + int nbuf_in, nbuf_out; + SMIOL_Offset *compute_ids; + SMIOL_Offset *io_ids; + SMIOL_Offset *buf_in, *buf_out; + SMIOL_Offset *io_list, *comp_list; + SMIOL_Offset neighbor; + MPI_Request req_in, req_out; + size_t ii; + size_t idx; + size_t n_neighbors; + size_t n_xfer; + size_t n_xfer_total; + size_t n_list; + + const SMIOL_Offset UNKNOWN_TASK = (SMIOL_Offset)(-1); + + + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + if (compute_elements == NULL && n_compute_elements != 0) { + return SMIOL_INVALID_ARGUMENT; + } + + if (io_elements == NULL && n_io_elements != 0) { + return SMIOL_INVALID_ARGUMENT; + } + + + comm = MPI_Comm_f2c(context->fcomm); + comm_size = context->comm_size; + comm_rank = context->comm_rank; + + + /* + * Because the count argument to MPI_Isend and MPI_Irecv is an int, at + * most 2^31-1 elements can be transmitted at a time. In this routine, + * arrays of pairs of SMIOL_Offset values will be transmitted as arrays + * of bytes, so n_compute_elements and n_io_elements can be at most + * 2^31-1 / sizeof(SMIOL_Offset) / 2. + */ + i = 0; + if (n_compute_elements > (((size_t)1 << 31) - 1) + / sizeof(SMIOL_Offset) + / (size_t)2) { + i = 1; + } + if (n_io_elements > (((size_t)1 << 31) - 1) + / sizeof(SMIOL_Offset) + / (size_t)2) { + i = 1; + } + + ierr = MPI_Allreduce((const void *)&i, (void *)&j, 1, MPI_INT, MPI_MAX, + comm); + if (j > 0) { + return SMIOL_INVALID_ARGUMENT; + } else if (ierr != MPI_SUCCESS) { + return SMIOL_MPI_ERROR; + } + + + /* + * Allocate an array, compute_ids, with three entries for each compute + * element + * [0] - element global ID + * [1] - element local ID + * [2] - I/O task that reads/writes this element + */ + compute_ids = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * TRIPLET_SIZE + * n_compute_elements); + if (compute_ids == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Fill in compute_ids array with global and local IDs; rank of I/O task + * is not yet known + */ + for (ii = 0; ii < n_compute_elements; ii++) { + compute_ids[TRIPLET_SIZE*ii] = compute_elements[ii]; /* global ID */ + compute_ids[TRIPLET_SIZE*ii+1] = (SMIOL_Offset)ii; /* local ID */ + compute_ids[TRIPLET_SIZE*ii+2] = UNKNOWN_TASK; /* I/O task rank */ + } + + /* + * Sort the compute_ids array on global element ID + * (first entry for each element) + */ + sort_triplet_array(n_compute_elements, compute_ids, 0); + + /* + * Allocate buffer with two entries for each I/O element + * [0] - I/O element global ID + * [1] - task that computes this element + */ + nbuf_out = (int)n_io_elements; + buf_out = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * (size_t)2 + * (size_t)nbuf_out); + if (buf_out == NULL) { + free(compute_ids); + return SMIOL_MALLOC_FAILURE; + } + + /* + * Fill buffer with I/O element IDs; compute task is not yet known + */ + for (ii = 0; ii < n_io_elements; ii++) { + buf_out[2*ii] = io_elements[ii]; + buf_out[2*ii+1] = UNKNOWN_TASK; + } + + /* + * Iterate through all ranks in the communicator, receiving from "left" + * neighbor and sending to "right" neighbor in each iteration. + * The objective is to identify, for each I/O element, which MPI rank + * computes that element. At the end of iteration, each rank will have + * seen the I/O element list from all other ranks. + */ + for (i = 0; i < comm_size; i++) { + /* + * Compute the rank whose buffer will be received this iteration + */ + SMIOL_Offset src_rank = (comm_rank - 1 - i + comm_size) + % comm_size; + + /* + * Initiate send of outgoing buffer size and receive of incoming + * buffer size + */ + ierr = MPI_Irecv((void *)&nbuf_in, 1, MPI_INT, + (comm_rank - 1 + comm_size) % comm_size, + (comm_rank + i), comm, &req_in); + + ierr = MPI_Isend((const void *)&nbuf_out, 1, MPI_INT, + (comm_rank + 1) % comm_size, + ((comm_rank + 1) % comm_size + i), comm, + &req_out); + + /* + * Wait until the incoming buffer size has been received + */ + ierr = MPI_Wait(&req_in, MPI_STATUS_IGNORE); + + /* + * Allocate incoming buffer + */ + buf_in = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * (size_t)2 + * (size_t)nbuf_in); + + /* + * Initiate receive of incoming buffer + */ + count = 2 * nbuf_in; + count *= (int)sizeof(SMIOL_Offset); + ierr = MPI_Irecv((void *)buf_in, count, MPI_BYTE, + (comm_rank - 1 + comm_size) % comm_size, + (comm_rank + i), comm, &req_in); + + /* + * Wait until the outgoing buffer size has been sent + */ + ierr = MPI_Wait(&req_out, MPI_STATUS_IGNORE); + + /* + * Initiate send of outgoing buffer + */ + count = 2 * nbuf_out; + count *= (int)sizeof(SMIOL_Offset); + ierr = MPI_Isend((const void *)buf_out, count, MPI_BYTE, + (comm_rank + 1) % comm_size, + ((comm_rank + 1) % comm_size + i), comm, + &req_out); + + /* + * Wait until the incoming buffer has been received + */ + ierr = MPI_Wait(&req_in, MPI_STATUS_IGNORE); + + /* + * Loop through the incoming buffer, marking all elements that + * are computed on this task + */ + for (j = 0; j < nbuf_in; j++) { + /* + * If I/O element does not yet have a computing task... + */ + if (buf_in[2*j+1] == UNKNOWN_TASK) { + SMIOL_Offset *elem; + + /* + * and if this element is computed on this task... + */ + elem = search_triplet_array(buf_in[2*j], + n_compute_elements, + compute_ids, 0); + if (elem != NULL) { + /* + * then mark the element as being + * computed on this task + */ + buf_in[2*j+1] = (SMIOL_Offset)comm_rank; + + /* + * and note locally which task will + * read/write this element + */ + elem[2] = src_rank; + } + } + } + + /* + * Wait until we have sent the outgoing buffer + */ + ierr = MPI_Wait(&req_out, MPI_STATUS_IGNORE); + + /* + * Free outgoing buffer and make the input buffer into + * the output buffer for next iteration + */ + free(buf_out); + buf_out = buf_in; + nbuf_out = nbuf_in; + } + + /* + * The output buffer is now the initial buffer with the compute tasks + * for each I/O element identified + */ + + /* + * Allocate an array, io_ids, with three entries for each I/O element + * [0] - element global ID + * [1] - element local ID + * [2] - compute task that operates on this element + */ + io_ids = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * TRIPLET_SIZE + * n_io_elements); + if (io_ids == NULL) { + free(compute_ids); + free(buf_out); + return SMIOL_MALLOC_FAILURE; + } + + /* + * Fill in io_ids array with global and local IDs, plus the rank of + * the task that computes each element + */ + for (ii = 0; ii < n_io_elements; ii++) { + io_ids[TRIPLET_SIZE*ii] = buf_out[2*ii+0]; /* global ID */ + io_ids[TRIPLET_SIZE*ii+1] = (SMIOL_Offset)ii; /* local ID */ + io_ids[TRIPLET_SIZE*ii+2] = buf_out[2*ii+1]; /* computing task rank */ + } + + free(buf_out); + + /* + * Sort io_ids array on task ID (third entry for each element) + */ + sort_triplet_array(n_io_elements, io_ids, 2); + + *decomp = (struct SMIOL_decomp *)malloc(sizeof(struct SMIOL_decomp)); + if ((*decomp) == NULL) { + free(compute_ids); + free(io_ids); + return SMIOL_MALLOC_FAILURE; + } + + /* + * Initialize the SMIOL_decomp struct + */ + (*decomp)->context = context; + (*decomp)->comp_list = NULL; + (*decomp)->io_list = NULL; + (*decomp)->io_start = 0; + (*decomp)->io_count = 0; + (*decomp)->agg_factor = 1; /* Group with 1 task -> no aggregation */ + (*decomp)->agg_comm = MPI_Comm_c2f(MPI_COMM_NULL); + (*decomp)->n_compute = 0; + (*decomp)->n_compute_agg = 0; + (*decomp)->counts = NULL; + (*decomp)->displs = NULL; + + + /* + * Scan through io_ids to determine number of unique neighbors that + * compute elements read/written on this task, and also determine + * the total number of elements + * computed on other tasks that are read/written on this task + */ + ii = 0; + n_neighbors = 0; + n_xfer_total = 0; + while (ii < n_io_elements) { + /* Task that computes this element */ + neighbor = io_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to read/write for neighbor */ + n_xfer = 0; + + /* + * Since io_ids is sorted on task, as long as task is unchanged, + * increment n_xfer + */ + while (ii < n_io_elements + && io_ids[TRIPLET_SIZE*ii+2] == neighbor) { + n_xfer++; + ii++; + } + if (neighbor != UNKNOWN_TASK) { + n_neighbors++; + n_xfer_total += n_xfer; + } + } + + /* + * Based on number of neighbors and total number of elements to transfer + * allocate the io_list + */ + n_list = sizeof(SMIOL_Offset) * ((size_t)1 + + (size_t)2 * n_neighbors + + n_xfer_total); + (*decomp)->io_list = (SMIOL_Offset *)malloc(n_list); + if ((*decomp)->io_list == NULL) { + free(compute_ids); + free(io_ids); + free(*decomp); + *decomp = NULL; + return SMIOL_MALLOC_FAILURE; + } + io_list = (*decomp)->io_list; + + /* + * Scan through io_ids a second time, filling in the io_list + */ + io_list[0] = (SMIOL_Offset)n_neighbors; + idx = 1; /* Index in io_list where neighbor ID will be written, followed + by number of elements and element local IDs */ + + ii = 0; + while (ii < n_io_elements) { + /* Task that computes this element */ + neighbor = io_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to read/write for neighbor */ + n_xfer = 0; + + /* + * Since io_ids is sorted on task, as long as task is unchanged, + * increment n_xfer + */ + while (ii < n_io_elements + && io_ids[TRIPLET_SIZE*ii+2] == neighbor) { + if (neighbor != UNKNOWN_TASK) { + /* Save local element ID in list */ + io_list[idx+2+n_xfer] = io_ids[TRIPLET_SIZE*ii+1]; + n_xfer++; + } + ii++; + } + if (neighbor != UNKNOWN_TASK) { + io_list[idx] = neighbor; + io_list[idx+1] = (SMIOL_Offset)n_xfer; + idx += (2 + n_xfer); + } + } + + free(io_ids); + + /* + * Sort compute_ids array on task ID (third entry for each element) + */ + sort_triplet_array(n_compute_elements, compute_ids, 2); + + /* + * Scan through compute_ids to determine number of unique neighbors that + * read/write elements computed on this task, and also determine + * the total number of elements read/written on other tasks that are + * computed on this task + */ + ii = 0; + n_neighbors = 0; + n_xfer_total = 0; + while (ii < n_compute_elements) { + /* Task that reads/writes this element */ + neighbor = compute_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to compute for neighbor */ + n_xfer = 0; + + /* + * Since compute_ids is sorted on task, as long as task is + * unchanged, increment n_xfer + */ + while (ii < n_compute_elements + && compute_ids[TRIPLET_SIZE*ii+2] == neighbor) { + n_xfer++; + ii++; + } + if (neighbor != UNKNOWN_TASK) { + n_neighbors++; + n_xfer_total += n_xfer; + } + } + + /* + * Based on number of neighbors and total number of elements to transfer + * allocate the comp_list + */ + n_list = sizeof(SMIOL_Offset) * ((size_t)1 + + (size_t)2 * n_neighbors + + n_xfer_total); + (*decomp)->comp_list = (SMIOL_Offset *)malloc(n_list); + if ((*decomp)->comp_list == NULL) { + free(compute_ids); + free((*decomp)->io_list); + free(*decomp); + *decomp = NULL; + return SMIOL_MALLOC_FAILURE; + } + comp_list = (*decomp)->comp_list; + + /* + * Scan through compute_ids a second time, filling in the comp_list + */ + comp_list[0] = (SMIOL_Offset)n_neighbors; + idx = 1; /* Index in compute_list where neighbor ID will be written, + followed by number of elements and element local IDs */ + + ii = 0; + while (ii < n_compute_elements) { + /* Task that reads/writes this element */ + neighbor = compute_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to compute for neighbor */ + n_xfer = 0; + + /* + * Since compute_ids is sorted on task, as long as task is + * unchanged, increment n_xfer + */ + while (ii < n_compute_elements + && compute_ids[TRIPLET_SIZE*ii+2] == neighbor) { + if (neighbor != UNKNOWN_TASK) { + /* Save local element ID in list */ + comp_list[idx+2+n_xfer] = compute_ids[TRIPLET_SIZE*ii+1]; + n_xfer++; + } + ii++; + } + if (neighbor != UNKNOWN_TASK) { + comp_list[idx] = neighbor; + comp_list[idx+1] = (SMIOL_Offset)n_xfer; + idx += (2 + n_xfer); + } + } + + free(compute_ids); + + return SMIOL_SUCCESS; +} + + +/******************************************************************************* + * + * print_lists + * + * Writes the contents of comp_list and io_list arrays to a text file + * + * Given pointers to the comp_list and io_list arrays from a SMIOL_decomp + * structure, writes the contents of these arrays to a text file in a human- + * readable format. + * + * Because the comp_list and io_list arrays are unique to each MPI task, this + * routine takes as an argument the MPI rank of the calling task. The output + * text file is named list.NNNN.txt, where NNNN is the rank of the task. + * + *******************************************************************************/ +void print_lists(int comm_rank, SMIOL_Offset *comp_list, SMIOL_Offset *io_list) +{ + char filename[14]; + FILE *f; + SMIOL_Offset n_neighbors; + SMIOL_Offset n_elems, neighbor; + int i, j, k; + + snprintf(filename, 14, "list.%4.4i.txt", comm_rank); + + f = fopen(filename, "w"); + + /* + * The lists below are structured as follows: + * list[0] - the number of neighbors for which a task sends/recvs + * | + * list[n] - neighbor task ID | repeated for + * list[n+1] - number of elements, m, to send/recv to/from the neighbor | each neighbor + * list[n+2 .. n+2+m] - local element IDs to send/recv to/from the neighbor | + * | + */ + + fprintf(f, "===== comp_list for MPI rank %i =====\n", comm_rank); + fprintf(f, "Our compute elements are read/written on %i tasks\n", + (int)comp_list[0]); + j = 0; + n_neighbors = comp_list[j++]; + for (i = 0; i < n_neighbors; i++) { + neighbor = comp_list[j++]; + n_elems = comp_list[j++]; + if (neighbor == comm_rank) { + fprintf(f, "----- copy %i elements -----\n", + (int)n_elems); + } else { + fprintf(f, "----- send %i elements to %i -----\n", + (int)n_elems, (int)neighbor); + } + for (k = 0; k < n_elems; k++) { + fprintf(f, " %i\n", (int)comp_list[j+k]); + } + j += n_elems; + } + + fprintf(f, "\n\n"); + fprintf(f, "===== io_list for MPI rank %i =====\n", comm_rank); + fprintf(f, "Our I/O elements are computed on %i tasks\n", + (int)io_list[0]); + j = 0; + n_neighbors = io_list[j++]; + for (i = 0; i < n_neighbors; i++) { + neighbor = io_list[j++]; + n_elems = io_list[j++]; + if (neighbor == comm_rank) { + fprintf(f, "----- copy %i elements -----\n", + (int)n_elems); + } else { + fprintf(f, "----- recv %i elements from %i -----\n", + (int)n_elems, (int)neighbor); + } + for (k = 0; k < n_elems; k++) { + fprintf(f, " %i\n", (int)io_list[j+k]); + } + j += n_elems; + } + fprintf(f, "\n\n"); + + + fprintf(f, "SMIOL_Offset comp_list_correct[] = { "); + j = 0; + n_neighbors = comp_list[j++]; + fprintf(f, "%i", (int)n_neighbors); + + for (i = 0; i < n_neighbors; i++) { + neighbor = comp_list[j++]; + fprintf(f, ", %i", (int)neighbor); + + n_elems = comp_list[j++]; + fprintf(f, ", %i", (int)n_elems); + + for (k = 0; k < n_elems; k++) { + fprintf(f, ", %i", (int)comp_list[j+k]); + } + j += n_elems; + } + fprintf(f, " };\n"); + + fprintf(f, "SMIOL_Offset io_list_correct[] = { "); + j = 0; + n_neighbors = io_list[j++]; + fprintf(f, "%i", (int)n_neighbors); + + for (i = 0; i < n_neighbors; i++) { + neighbor = io_list[j++]; + fprintf(f, ", %i", (int)neighbor); + + n_elems = io_list[j++]; + fprintf(f, ", %i", (int)n_elems); + + for (k = 0; k < n_elems; k++) { + fprintf(f, ", %i", (int)io_list[j+k]); + } + j += n_elems; + } + fprintf(f, " };\n"); + + fclose(f); +} + + +/******************************************************************************* + * + * comp_sort_0 + * + * Compares two SMIOL_Offset triplets based on their first entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_sort_0(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); +} + + +/******************************************************************************* + * + * comp_sort_1 + * + * Compares two SMIOL_Offset triplets based on their second entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + * If the triplets a and b have equal values in their second entry, the values + * in their first entry will be used to determine the result of the comparison. + * + *******************************************************************************/ +static int comp_sort_1(const void *a, const void *b) +{ + int res; + + res = (((const SMIOL_Offset *)a)[1] > ((const SMIOL_Offset *)b)[1]) + - (((const SMIOL_Offset *)a)[1] < ((const SMIOL_Offset *)b)[1]); + if (res == 0) { + res = (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); + } + return res; +} + + +/******************************************************************************* + * + * comp_sort_2 + * + * Compares two SMIOL_Offset triplets based on their third entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + * If the triplets a and b have equal values in their third entry, the values + * in their first entry will be used to determine the result of the comparison. + * + *******************************************************************************/ +static int comp_sort_2(const void *a, const void *b) +{ + int res; + + res = (((const SMIOL_Offset *)a)[2] > ((const SMIOL_Offset *)b)[2]) + - (((const SMIOL_Offset *)a)[2] < ((const SMIOL_Offset *)b)[2]); + if (res == 0) { + res = (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); + } + return res; +} + + +/******************************************************************************* + * + * comp_search_0 + * + * Compares two SMIOL_Offset triplets based on their first entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_search_0(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); +} + + +/******************************************************************************* + * + * comp_search_1 + * + * Compares two SMIOL_Offset triplets based on their second entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_search_1(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[1] > ((const SMIOL_Offset *)b)[1]) + - (((const SMIOL_Offset *)a)[1] < ((const SMIOL_Offset *)b)[1]); +} + + +/******************************************************************************* + * + * comp_search_2 + * + * Compares two SMIOL_Offset triplets based on their third entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_search_2(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[2] > ((const SMIOL_Offset *)b)[2]) + - (((const SMIOL_Offset *)a)[2] < ((const SMIOL_Offset *)b)[2]); +} diff --git a/src/external/SMIOL/smiol_utils.h b/src/external/SMIOL/smiol_utils.h new file mode 100644 index 0000000000..6cdc2e7687 --- /dev/null +++ b/src/external/SMIOL/smiol_utils.h @@ -0,0 +1,47 @@ +/******************************************************************************* + * Utilities and helper functions for SMIOL + *******************************************************************************/ +#ifndef SMIOL_UTILS_H +#define SMIOL_UTILS_H + +#include "smiol_types.h" + +#define SMIOL_COMP_TO_IO 1 +#define SMIOL_IO_TO_COMP 2 + + +/* + * Searching and sorting + */ +void sort_triplet_array(size_t n_arr, SMIOL_Offset *arr, int sort_entry); +SMIOL_Offset *search_triplet_array(SMIOL_Offset key, + size_t n_arr, SMIOL_Offset *arr, + int search_entry); + +/* + * Communication + */ +int transfer_field(const struct SMIOL_decomp *decomp, int dir, + size_t element_size, const void *in_field, void *out_field); + +int aggregate_list(MPI_Comm comm, int root, size_t n_in, SMIOL_Offset *in_list, + size_t *n_out, SMIOL_Offset **out_list, + int **counts, int **displs); + +/* + * Field decomposition + */ +int get_io_elements(int comm_rank, int num_io_tasks, int io_stride, + size_t n_io_elements, size_t *io_start, size_t *io_count); + +int build_exchange(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + size_t n_io_elements, SMIOL_Offset *io_elements, + struct SMIOL_decomp **decomp); + +/* + * Debugging + */ +void print_lists(int comm_rank, SMIOL_Offset *comp_list, SMIOL_Offset *io_list); + +#endif diff --git a/src/external/SMIOL/smiolf.F90 b/src/external/SMIOL/smiolf.F90 new file mode 100644 index 0000000000..bf001c848a --- /dev/null +++ b/src/external/SMIOL/smiolf.F90 @@ -0,0 +1,2057 @@ +#include "smiol_codes.inc" + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! SMIOL -- The Simple MPAS I/O Library +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module SMIOLf + + use iso_c_binding, only : c_int, c_size_t, c_int64_t, c_ptr + + private + + public :: SMIOLf_context, & + SMIOLf_decomp, & + SMIOLf_file + + public :: SMIOL_offset_kind + + public :: SMIOLf_init, & + SMIOLf_finalize, & + SMIOLf_inquire, & + SMIOLf_open_file, & + SMIOLf_close_file, & + SMIOLf_define_dim, & + SMIOLf_inquire_dim, & + SMIOLf_define_var, & + SMIOLf_inquire_var, & + SMIOLf_put_var, & + SMIOLf_get_var, & + SMIOLf_define_att, & + SMIOLf_inquire_att, & + SMIOLf_sync_file, & + SMIOLf_error_string, & + SMIOLf_lib_error_string, & + SMIOLf_set_option, & + SMIOLf_create_decomp, & + SMIOLf_free_decomp, & + SMIOLf_set_frame, & + SMIOLf_get_frame, & + SMIOLf_f_to_c_string + + + integer, parameter :: SMIOL_offset_kind = c_int64_t ! Must match SMIOL_Offset in smiol_types.h + + + type, bind(C) :: SMIOLf_context + integer :: fcomm ! Fortran handle to MPI communicator; MPI_Fint on the C side, which is supposed to match + ! a Fortran integer + + integer(c_int) :: comm_size ! Size of MPI communicator + integer(c_int) :: comm_rank ! Rank within MPI communicator + + integer(c_int) :: num_io_tasks ! The number of I/O tasks + integer(c_int) :: io_stride ! The stride between I/O tasks in the communicator + + integer(c_int) :: lib_ierr ! Library-specific error code + integer(c_int) :: lib_type ! From which library the error code originated + end type SMIOLf_context + + type, bind(C) :: SMIOLf_file + type (c_ptr) :: context ! Pointer to (struct SMIOL_context); the context within which the file was opened + integer(kind=SMIOL_offset_kind) :: frame ! Current frame of the file +#ifdef SMIOL_PNETCDF + integer(c_int) :: state ! parallel-netCDF file state (i.e. Define or data mode) + integer(c_int) :: ncidp ! parallel-netCDF file handle + integer(c_size_t) :: bufsize ! Size of buffer attached to this file + integer(c_int) :: n_reqs ! Number of pending non-blocking requests + type (c_ptr) :: reqs ! Array of pending non-blocking request handles +#endif + integer(c_int) :: io_task ! 1 = this task performs I/O calls; 0 = no I/O calls on this task + integer :: io_file_comm ! Communicator shared by all tasks with io_task == 1 + integer :: io_group_comm ! Communicator shared by tasks associated with an I/O task, usually 1 I/O task + ! and N-1 non-I/O tasks, where N is the I/O stride + end type SMIOLf_file + + type, bind(C) :: SMIOLf_decomp + ! + ! The lists below are structured (in C) as follows: + ! list[0] - the number of neighbors for which a task sends/recvs + ! | + ! list[n] - neighbor task ID | repeated for + ! list[n+1] - number of elements, m, to send/recv to/from the neighbor | each neighbor + ! list[n+2 .. n+2+m] - local element IDs to send/recv to/from the neighbor | + ! | + ! + type(c_ptr) :: comp_list ! Elements to be sent/received from/on a compute task + type(c_ptr) :: io_list ! Elements to be send/received from/on an I/O task + + type (c_ptr) :: context ! Pointer to (struct SMIOL_context); the context for this decomp + + integer(c_size_t) :: io_start; ! The starting offset on disk for I/O by a task + integer(c_size_t) :: io_count; ! The number of elements for I/O by a task + + integer(c_int) :: agg_factor ! Aggregation factor, or size of aggregation group + integer :: agg_comm ! Communicator for aggregation/deaggregation operations + integer(c_size_t) :: n_compute ! Number of un-aggregated compute elements on the task + integer(c_size_t) :: n_compute_agg ! Number of aggregated compute elements on the task + type (c_ptr) :: counts ! Compute element counts for tasks in aggregation group + type (c_ptr) :: displs ! Displacements in aggregated list of elements for tasks + ! in aggregation group + end type SMIOLf_decomp + + interface SMIOLf_define_att + module procedure SMIOLf_define_att_int + module procedure SMIOLf_define_att_float + module procedure SMIOLf_define_att_double + module procedure SMIOLf_define_att_text + end interface + + interface SMIOLf_inquire_att + module procedure SMIOLf_inquire_att_int + module procedure SMIOLf_inquire_att_float + module procedure SMIOLf_inquire_att_double + module procedure SMIOLf_inquire_att_text + end interface + + ! + ! Note: The implementations of the specific SMIOLf_put_var routines + ! are found in the file smiolf_put_get_var.inc, which is included + ! in this module with a pre-processor directive + ! + interface SMIOLf_put_var + module procedure SMIOLf_put_var_0d_char + module procedure SMIOLf_put_var_0d_int32 + module procedure SMIOLf_put_var_0d_real32 + module procedure SMIOLf_put_var_0d_real64 + module procedure SMIOLf_put_var_1d_int32 + module procedure SMIOLf_put_var_1d_real32 + module procedure SMIOLf_put_var_1d_real64 + module procedure SMIOLf_put_var_2d_int32 + module procedure SMIOLf_put_var_2d_real32 + module procedure SMIOLf_put_var_2d_real64 + module procedure SMIOLf_put_var_3d_int32 + module procedure SMIOLf_put_var_3d_real32 + module procedure SMIOLf_put_var_3d_real64 + module procedure SMIOLf_put_var_4d_int32 + module procedure SMIOLf_put_var_4d_real32 + module procedure SMIOLf_put_var_4d_real64 + module procedure SMIOLf_put_var_5d_real32 + module procedure SMIOLf_put_var_5d_real64 + end interface SMIOLf_put_var + + ! + ! Note: The implementations of the specific SMIOLf_get_var routines + ! are found in the file smiolf_put_get_var.inc, which is included + ! in this module with a pre-processor directive + ! + interface SMIOLf_get_var + module procedure SMIOLf_get_var_0d_char + module procedure SMIOLf_get_var_0d_int32 + module procedure SMIOLf_get_var_0d_real32 + module procedure SMIOLf_get_var_0d_real64 + module procedure SMIOLf_get_var_1d_int32 + module procedure SMIOLf_get_var_1d_real32 + module procedure SMIOLf_get_var_1d_real64 + module procedure SMIOLf_get_var_2d_int32 + module procedure SMIOLf_get_var_2d_real32 + module procedure SMIOLf_get_var_2d_real64 + module procedure SMIOLf_get_var_3d_int32 + module procedure SMIOLf_get_var_3d_real32 + module procedure SMIOLf_get_var_3d_real64 + module procedure SMIOLf_get_var_4d_int32 + module procedure SMIOLf_get_var_4d_real32 + module procedure SMIOLf_get_var_4d_real64 + module procedure SMIOLf_get_var_5d_real32 + module procedure SMIOLf_get_var_5d_real64 + end interface SMIOLf_get_var + + ! C interface definitions used in multiple routines + interface + function SMIOL_define_att(file, varname, att_name, att_type, att) result(ierr) bind(C, name='SMIOL_define_att') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + type (c_ptr), value :: varname + character(kind=c_char), dimension(*) :: att_name + integer(kind=c_int), value :: att_type + type (c_ptr), value :: att + integer(kind=c_int) :: ierr + end function + + function SMIOL_inquire_att(file, varname, att_name, att_type, att_len, att) result(ierr) bind(C, name='SMIOL_inquire_att') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + type (c_ptr), value :: varname + character(kind=c_char), dimension(*) :: att_name + type (c_ptr), value :: att_type + type (c_ptr), value :: att_len + type (c_ptr), value :: att + integer(kind=c_int) :: ierr + end function + + function SMIOL_put_var(file, varname, decomp, buf) result(ierr) bind(C, name='SMIOL_put_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character (kind=c_char), dimension(*) :: varname + type (c_ptr), value :: decomp + type (c_ptr), value :: buf + integer (kind=c_int) :: ierr + end function + + function SMIOL_get_var(file, varname, decomp, buf) result(ierr) bind(C, name='SMIOL_get_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character (kind=c_char), dimension(*) :: varname + type (c_ptr), value :: decomp + type (c_ptr), value :: buf + integer (kind=c_int) :: ierr + end function + end interface + + +contains + + + ! + ! Library methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_init + ! + !> \brief Initialize a SMIOL context + !> \details + !> Initializes a SMIOL context, within which decompositions may be defined and + !> files may be read and written. The input argument comm is an MPI communicator, + !> and the input arguments num_io_tasks and io_stride provide the total number + !> of I/O tasks and the stride between those I/O tasks within the communicator. + !> + !> Upon successful return the context argument points to a valid SMIOL context; + !> otherwise, it is NULL and an error code other than MPI_SUCCESS is returned. + !> + !> Note: It is assumed that MPI_Init has been called prior to this routine, so + !> that any use of the provided MPI communicator will be valid. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_init(comm, num_io_tasks, io_stride, context) result(ierr) + + use iso_c_binding, only : c_ptr, c_f_pointer, c_null_ptr, c_associated + + implicit none + + integer, intent(in) :: comm + integer, intent(in) :: num_io_tasks + integer, intent(in) :: io_stride + type (SMIOLf_context), pointer :: context + + type (c_ptr) :: c_context = c_null_ptr + + ! C interface definitions + interface + function SMIOL_fortran_init(comm, num_io_tasks, io_stride, context) result(ierr) bind(C, name='SMIOL_fortran_init') + use iso_c_binding, only : c_int, c_ptr + integer, value :: comm ! MPI_Fint on the C side, which is supposed to match a Fortran integer + integer(c_int), value :: num_io_tasks + integer(c_int), value :: io_stride + type (c_ptr) :: context + integer(kind=c_int) :: ierr + end function + end interface + + ierr = SMIOL_fortran_init(comm, num_io_tasks, io_stride, c_context) + + if (ierr == SMIOL_SUCCESS) then + if (.not. c_associated(c_context)) then + nullify(context) + ierr = SMIOL_FORTRAN_ERROR + else + call c_f_pointer(c_context, context) + end if + else + if (.not. c_associated(c_context)) then + nullify(context) + else + ierr = SMIOL_FORTRAN_ERROR + end if + end if + + end function SMIOLf_init + + + !----------------------------------------------------------------------- + ! routine SMIOLf_finalize + ! + !> \brief Finalize a SMIOL context + !> \details + !> Finalizes a SMIOL context and frees all memory in the SMIOL_context instance. + !> After this routine is called, no other SMIOL routines that make reference to + !> the finalized context should be called. + !> + !> Upon return, the context argument will be unassociated if no errors occurred. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_finalize(context) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc, c_associated, c_null_ptr + + implicit none + + type (SMIOLf_context), pointer :: context + + type (c_ptr) :: c_context = c_null_ptr + + ! C interface definitions + interface + function SMIOL_finalize(context) result(ierr) bind(C, name='SMIOL_finalize') + use iso_c_binding, only : c_int, c_ptr + type (c_ptr) :: context + integer(kind=c_int) :: ierr + end function + end interface + + if (associated(context)) then + c_context = c_loc(context) + end if + + ierr = SMIOL_finalize(c_context) + + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_context)) then + ierr = SMIOL_FORTRAN_ERROR + else + nullify(context) + end if + else + if (.not. c_associated(c_context)) then + nullify(context) + end if + end if + + end function SMIOLf_finalize + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire + ! + !> \brief Inquire about a SMIOL context + !> \details + !> Detailed description of what this routine does. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire() result(ierr) + + implicit none + + ierr = 0 + + end function SMIOLf_inquire + + + ! + ! File methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_open_file + ! + !> \brief Opens a file within a SMIOL context + !> \details + !> Depending on the specified file mode, creates or opens the file specified + !> by filename within the provided SMIOL context. + !> + !> The optional bufsize argument specifies the size in bytes of the buffer + !> to be attached to the file by I/O tasks; at present this buffer is only + !> used by the Parallel-NetCDF library if the file is opened with a mode of + !> SMIOL_FILE_CREATE or SMIOL_FILE_WRITE. A bufsize of 0 will force the use of + !> the Parallel-NetCDF blocking write interface, while a nonzero value enables + !> the use of the non-blocking, buffered interface for writing. If the bufsize + !> argument is not present, a default buffer size of 128 MiB is used. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned, and the file handle argument + !> will point to a valid file handle. Otherwise, the file handle is not associated + !> and an error code other than SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_open_file(context, filename, mode, file, bufsize) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr, c_null_ptr, c_char, c_size_t, c_associated, c_f_pointer + + implicit none + + type (SMIOLf_context), pointer :: context + character(len=*), intent(in) :: filename + integer, intent(in) :: mode + type (SMIOLf_file), pointer :: file + integer(kind=c_size_t), intent(in), optional :: bufsize + + ! Default buffer size to use if optional bufsize argument is not provided + integer (kind=c_size_t), parameter :: default_bufsize = int(128*1024*1024, kind=c_size_t) + + type (c_ptr) :: c_context = c_null_ptr + type (c_ptr) :: c_file = c_null_ptr + integer(kind=c_int) :: c_mode + character(kind=c_char), dimension(:), pointer :: c_filename + + ! C interface definitions + interface + function SMIOL_open_file(context, filename, mode, file, bufsize) result(ierr) bind(C, name='SMIOL_open_file') + use iso_c_binding, only : c_char, c_ptr, c_int, c_size_t + type (c_ptr), value :: context + character(kind=c_char), dimension(*) :: filename + integer(kind=c_int), value :: mode + type (c_ptr) :: file + integer(kind=c_size_t), value :: bufsize + integer(kind=c_int) :: ierr + end function + end interface + + if (associated(context)) then + c_context = c_loc(context) + end if + + ! + ! Convert Fortran string to C character array + ! + allocate(c_filename(len_trim(filename) + 1)) + call SMIOLf_f_to_c_string(filename, c_filename) + + c_mode = mode + + if (present(bufsize)) then + ierr = SMIOL_open_file(c_context, c_filename, c_mode, c_file, & + bufsize) + else + ierr = SMIOL_open_file(c_context, c_filename, c_mode, c_file, & + default_bufsize) + end if + + deallocate(c_filename) + + if (ierr == SMIOL_SUCCESS) then + if (.not. c_associated(c_file)) then + nullify(file) + ierr = SMIOL_FORTRAN_ERROR + else + call c_f_pointer(c_file, file) + end if + else + if (.not. c_associated(c_file)) then + nullify(file) + else + ierr = SMIOL_FORTRAN_ERROR + end if + end if + + end function SMIOLf_open_file + + + !----------------------------------------------------------------------- + ! routine SMIOLf_close_file + ! + !> \brief Closes a file within a SMIOL context + !> \details + !> Closes the file associated with the provided file handle. Upon successful + !> completion, SMIOL_SUCCESS is returned, the file will be closed, and all memory + !> that is uniquely associated with the file handle will be deallocated. + !> Otherwise, an error code other than SMIOL_SUCCESS will be returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_close_file(file) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr, c_null_ptr, c_associated + + implicit none + + type (SMIOLf_file), pointer :: file + + type (c_ptr) :: c_file = c_null_ptr + + ! C interface definitions + interface + function SMIOL_close_file(file) result(ierr) bind(C, name='SMIOL_close_file') + use iso_c_binding, only : c_ptr, c_int + type (c_ptr) :: file + integer(kind=c_int) :: ierr + end function + end interface + + if (associated(file)) then + c_file = c_loc(file) + end if + + ierr = SMIOL_close_file(c_file) + + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_file)) then + ierr = SMIOL_FORTRAN_ERROR + else + nullify(file) + end if + else + if (.not. c_associated(c_file)) then + nullify(file) + end if + end if + + end function SMIOLf_close_file + + + ! + ! Dimension methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_dim + ! + !> \brief Defines a new dimension in a file + !> \details + !> Defines a dimension with the specified name and size in the file associated + !> with the file handle. If a negative value is provided for the size argument, + !> the dimension will be defined as an unlimited or record dimension. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + !> code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_dim(file, dimname, dimsize) result(ierr) + + use iso_c_binding, only : c_char, c_loc, c_ptr + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: dimname + integer(kind=SMIOL_offset_kind), intent(in) :: dimsize + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_dimname + + ! C interface definitions + interface + function SMIOL_define_dim(file, dimname, dimsize) result(ierr) bind(C, name='SMIOL_define_dim') + use iso_c_binding, only : c_ptr, c_char, c_int + import SMIOL_offset_kind + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: dimname + integer(kind=SMIOL_offset_kind), value :: dimsize + integer(kind=c_int) :: ierr + end function + end interface + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + allocate(c_dimname(len_trim(dimname) + 1)) + call SMIOLf_f_to_c_string(dimname, c_dimname) + + ierr = SMIOL_define_dim(c_file, c_dimname, dimsize) + + deallocate(c_dimname) + + end function SMIOLf_define_dim + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_dim + ! + !> \brief Inquires about an existing dimension in a file + !> \details + !> Inquire about an existing dimension's size or if a dimension is the + !> unlimited dimension or not. If dimsize is present, the size of the dimension + !> will be returned in it; likewise, if is_unlimited is present, is_unlimited + !> will return either .true. or .false. depending on whether or not the dimension + !> is the unlimited dimension or not. + !> + !> For unlimited dimensions, the current size of the dimension is returned; + !> future writes of additional records to a file can lead to different return + !> sizes for unlimited dimensions. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + !> code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_dim(file, dimname, dimsize, is_unlimited) result(ierr) + + use iso_c_binding, only : c_char, c_loc, c_ptr, c_null_ptr + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: dimname + integer(kind=SMIOL_offset_kind), intent(out), optional :: dimsize + logical, intent(out), optional :: is_unlimited + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_dimname + integer (kind=SMIOL_offset_kind), target :: c_dimsize + integer (kind=c_int), target :: c_is_unlimited + type (c_ptr) :: c_dimsize_ptr + type (c_ptr) :: c_is_unlimited_ptr + + + ! C interface definitions + interface + function SMIOL_inquire_dim(file, dimname, dimsize, is_unlimited) result(ierr) bind(C, name='SMIOL_inquire_dim') + use iso_c_binding, only : c_ptr, c_char, c_int + import SMIOL_offset_kind + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: dimname + type (c_ptr), value :: dimsize + type (c_ptr), value :: is_unlimited + integer(kind=c_int) :: ierr + end function + end interface + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + allocate(c_dimname(len_trim(dimname) + 1)) + call SMIOLf_f_to_c_string(dimname, c_dimname) + + ! + ! Set C dimsize + ! + if (present(dimsize)) then + c_dimsize_ptr = c_loc(c_dimsize) + else + c_dimsize_ptr = c_null_ptr + endif + + ! + ! Set C pointer for unlimited dimension inquiry argument + ! + if (present(is_unlimited)) then + c_is_unlimited_ptr = c_loc(c_is_unlimited) + else + c_is_unlimited_ptr = c_null_ptr + end if + + ierr = SMIOL_inquire_dim(c_file, c_dimname, c_dimsize_ptr, c_is_unlimited_ptr) + + if (present(dimsize)) then + dimsize = c_dimsize + end if + + if (present(is_unlimited)) then + if (c_is_unlimited == 1) then + is_unlimited = .true. + else + is_unlimited = .false. + end if + end if + + deallocate(c_dimname) + + end function SMIOLf_inquire_dim + + + ! + ! Variable methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_var + ! + !> \brief Defines a new variable in a file + !> \details + !> Defines a variable with the specified name, type, and dimensions in an open + !> file pointed to by the file argument. The varname and dimnames arguments + !> are expected to be null-terminated strings, except if the variable has + !> zero dimensions, in which case the dimnames argument is ignored. + !> + !> Unlike the C SMIOL_define_var function, this routine assumes that + !> dimnames provides the dimension names in their natural Fortran order, + !> with the fastest-varying dimension given first and any unlimited + !> dimension given last. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + !> code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_var(file, varname, vartype, ndims, dimnames) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_null_char, c_ptr, c_loc, c_null_ptr + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + integer, intent(in) :: vartype + integer, intent(in) :: ndims + character(len=*), dimension(:), intent(in) :: dimnames + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_varname + integer(kind=c_int) :: c_vartype + integer(kind=c_int) :: c_ndims + + type (c_ptr) :: c_dimnames_ptr + type (c_ptr), dimension(:), allocatable, target :: c_dimnames + + integer :: i, j + + ! C interface definitions + interface + function SMIOL_define_var(file, varname, vartype, ndims, dimnames) result(ierr) bind(C, name='SMIOL_define_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: varname + integer(kind=c_int), value :: vartype + integer(kind=c_int), value :: ndims + type (c_ptr), value :: dimnames + integer(kind=c_int) :: ierr + end function + end interface + + ! Used to store an array of pointers to character arrays + type string_ptr + character(kind=c_char), dimension(:), allocatable :: str + end type string_ptr + + type (string_ptr), dimension(:), allocatable, target :: strings + + ! + ! Check that the 'dimnames' array has at least ndims elements + ! + if (size(dimnames) < ndims) then + ierr = SMIOL_FORTRAN_ERROR + return + end if + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + allocate(c_varname(len_trim(varname) + 1)) + call SMIOLf_f_to_c_string(varname, c_varname) + + ! + ! Convert vartype and ndims + ! + c_vartype = vartype + c_ndims = ndims + + ! + ! Convert dimnames, reversing their order + ! + allocate(c_dimnames(ndims)) + allocate(strings(ndims)) + + do j=1,ndims + allocate(strings(j) % str(len_trim(dimnames(ndims-j+1))+1)) + + do i=1,len_trim(dimnames(ndims-j+1)) + strings(j) % str(i) = dimnames(ndims-j+1)(i:i) + end do + strings(j) % str(i) = c_null_char + c_dimnames(j) = c_loc(strings(j) % str) + end do + + if (ndims > 0) then + c_dimnames_ptr = c_loc(c_dimnames) + else + c_dimnames_ptr = c_null_ptr + end if + + ierr = SMIOL_define_var(c_file, c_varname, c_vartype, c_ndims, c_dimnames_ptr) + + do j=1,ndims + deallocate(strings(j) % str) + end do + + deallocate(c_varname) + deallocate(strings) + deallocate(c_dimnames) + + end function SMIOLf_define_var + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_var + ! + !> \brief Inquires about an existing variable in a file + !> \details + !> Inquires about a variable in a file, and optionally returns the type + !> of the variable, the dimensionality of the variable, and the names of + !> the dimensions of the variable. + !> + !> If the names of a variable's dimensions are requested (by providing an + !> actual argument for dimnames), the size of the dimnames array must be at + !> least the number of dimensions in the variable, and each character string + !> in the dimnames array must be large enough to accommodate the corresponding + !> dimension name. + !> + !> Unlike the C SMIOL_inquire_var function, this routine returns the list of + !> dimension names in its natural Fortran order, with the fastest-varying + !> dimension given first and any unlimited dimension given last. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_var(file, varname, vartype, ndims, dimnames) result(ierr) + + use iso_c_binding, only : c_char, c_null_char, c_loc, c_ptr, c_null_ptr, c_int + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + integer, intent(out), optional :: vartype + integer, intent(out), optional :: ndims + character(len=*), dimension(:), intent(out), optional :: dimnames + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_varname + integer(kind=c_int), target :: c_vartype + integer(kind=c_int), target :: c_ndims + type (c_ptr), dimension(:), allocatable, target :: c_dimnames + + type (c_ptr) :: c_vartype_ptr + type (c_ptr) :: c_ndims_ptr + type (c_ptr) :: c_dimnames_ptr + + integer :: i, j, ndims_in + + ! C interface definitions + interface + function SMIOL_inquire_var(file, varname, vartype, ndims, dimnames) result(ierr) bind(C, name='SMIOL_inquire_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: varname + type (c_ptr), value :: vartype + type (c_ptr), value :: ndims + type (c_ptr), value :: dimnames + integer(kind=c_int) :: ierr + end function + end interface + + ! Used to store an array of pointers to character arrays + type string_ptr + character(kind=c_char), dimension(:), allocatable :: str + end type string_ptr + + type (string_ptr), dimension(:), allocatable, target :: strings + + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + call SMIOLf_f_to_c_string(varname, c_varname) + + ! + ! Set C pointer for variable type + ! + if (present(vartype)) then + c_vartype_ptr = c_loc(c_vartype) + else + c_vartype_ptr = c_null_ptr + end if + + ! + ! Set C pointer for number of dimensions + ! This is done even if dimnames is requested but ndims is not, + ! since c_ndims may be used later on when copying out strings + ! to dimnames. + ! + if (present(ndims) .or. present(dimnames)) then + c_ndims_ptr = c_loc(c_ndims) + else + c_ndims_ptr = c_null_ptr + end if + + ! + ! Set C pointers for dimension names in C order + ! + if (present(dimnames)) then + ndims_in = size(dimnames) + allocate(c_dimnames(ndims_in)) + allocate(strings(ndims_in)) + + do j=1,ndims_in + allocate(strings(j) % str(len(dimnames(ndims_in-j+1))+1)) + c_dimnames(j) = c_loc(strings(j) % str) + end do + c_dimnames_ptr = c_loc(c_dimnames) + else + c_dimnames_ptr = c_null_ptr + end if + + + ierr = SMIOL_inquire_var(c_file, c_varname, c_vartype_ptr, c_ndims_ptr, c_dimnames_ptr) + + deallocate(c_varname) + + if (ierr /= SMIOL_SUCCESS) then + return + end if + + ! + ! Copy variable type to output argument + ! + if (present(vartype)) then + vartype = c_vartype + end if + + ! + ! Copy number of dimensions to output argument + ! + if (present(ndims)) then + ndims = c_ndims + end if + + ! + ! Copy dimension names to output argument, reversing their order + ! + if (present(dimnames)) then + do j=1,c_ndims + do i=1,len(dimnames(c_ndims-j+1)) + if (strings(j) % str(i) == c_null_char) exit + end do + + i = i - 1 + + dimnames(c_ndims-j+1)(1:i) = transfer(strings(j) % str(1:i), dimnames(c_ndims-j+1)) + dimnames(c_ndims-j+1) = dimnames(c_ndims-j+1)(1:i) + end do + + do j=1,ndims_in + deallocate(strings(j) % str) + end do + deallocate(strings) + deallocate(c_dimnames) + end if + + end function SMIOLf_inquire_var + + +#include "smiolf_put_get_var.inc" + + + ! + ! Attribute methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_int + ! + !> \brief Defines a new integer attribute + !> \details + !> Defines a new integer attribute for a variable if varname is not + !> an empty string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_int(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_int, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + integer(kind=c_int), intent(in), target :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + att_ptr = c_loc(att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_INT32, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_define_att_int + + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_float + ! + !> \brief Defines a new float attribute + !> \details + !> Defines a new float attribute for a variable if varname is not an empty + !> string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_float(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_float, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_float), intent(in), target :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + att_ptr = c_loc(att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_REAL32, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_define_att_float + + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_double + ! + !> \brief Defines a new double attribute + !> \details + !> Defines a new double attribute for a variable if varname is not an empty + !> string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_double(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_double, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_double), intent(in), target :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + att_ptr = c_loc(att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_REAL64, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_define_att_double + + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_text + ! + !> \brief Defines a new text attribute + !> \details + !> Defines a new text attribute for a variable if varname is not an empty + !> string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_text(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + character(len=*), intent(in) :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + character(kind=c_char), dimension(:), allocatable, target :: c_att + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + allocate(c_att(len_trim(att) + 1)) + do i=1,len_trim(att) + c_att(i) = att(i:i) + end do + c_att(i) = c_null_char + + att_ptr = c_loc(c_att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_CHAR, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + deallocate(c_att) + + end function SMIOLf_define_att_text + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_int + ! + !> \brief Inquires about an integer attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, and if it is integer-valued, then + !> SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not an integer + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_int(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_int, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + integer(kind=c_int), intent(out), target :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, c_null_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_INT32) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + att_ptr = c_loc(att) + + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_inquire_att_int + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_float + ! + !> \brief Inquires about a float attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, and if it is float-valued, then + !> SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not a float + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_float(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_float, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_float), intent(out), target :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, c_null_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_REAL32) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + att_ptr = c_loc(att) + + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_inquire_att_float + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_double + ! + !> \brief Inquires about a double attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, and if it is double-valued, then + !> SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not a double + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_double(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_double, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_double), intent(out), target :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, c_null_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_REAL64) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + att_ptr = c_loc(att) + + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_inquire_att_double + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_text + ! + !> \brief Inquires about a text attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, if it is character-valued, and if + !> the att output argument is long enough to contain the attribute value, + !> then SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not a character + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. If the attribute was found, and it is a character attribute, + !> but the att output argument is not long enough to contain the attribute + !> value, then SMIOL_INSUFFICIENT_ARG is returned, and the contents of att + !> are undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_text(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_int, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + character(len=*), intent(out) :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + integer(kind=SMIOL_offset_kind), target :: att_len + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + character(kind=c_char), dimension(:), allocatable, target :: c_att + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: att_len_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + att_len_ptr = c_loc(att_len) + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type and length + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, att_len_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_CHAR) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + if (len(att) < att_len) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + ierr = SMIOL_INSUFFICIENT_ARG + return + end if + + ! + ! Next, allocate a local c_char array + ! + allocate(c_att(att_len)) + att_ptr = c_loc(c_att) + + ! + ! Finally, inquire about the attribute itself + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + ! + ! Copy c_char array to Fortran string + ! + att(1:att_len) = transfer(c_att(1:att_len), att) + att = att(1:att_len) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + deallocate(c_att) + + end function SMIOLf_inquire_att_text + + + ! + ! Control methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_sync_file + ! + !> \brief Forces all in-memory data to be flushed to disk + !> \details + !> Upon success, all in-memory data for the file associatd with the file + !> handle will be flushed to the file system and SMIOL_SUCCESS will be + !> returned; otherwise, an error code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_sync_file(file) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc, c_null_ptr + + implicit none + + type (SMIOLf_file), pointer :: file + type (c_ptr) :: c_file + + interface + function SMIOL_sync_file(file) result(ierr) bind(C, name='SMIOL_sync_file') + use iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: file + integer(kind=c_int) :: ierr + end function + end interface + + c_file = c_null_ptr + + if (associated(file)) then + c_file = c_loc(file) + end if + + ierr = SMIOL_sync_file(c_file) + + end function SMIOLf_sync_file + + + !----------------------------------------------------------------------- + ! routine SMIOLf_error_string + ! + !> \brief Returns an error string for a specified error code + !> \details + !> Returns an error string corresponding to a SMIOL error code. If the error code is + !> SMIOL_LIBRARY_ERROR and a valid SMIOL context is available, the SMIOLf_lib_error_string + !> function should be called instead. + !> + !> The error string is always of length 128, and so it is recommended to trim + !> the string before it is printed. + ! + !----------------------------------------------------------------------- + character(len=128) function SMIOLf_error_string(ierrno) result(err_mesg) + + use iso_c_binding, only : c_ptr, c_char, c_null_char, c_f_pointer + + implicit none + + integer, intent(in) :: ierrno + + type (c_ptr) :: c_mesg_ptr + character(kind=c_char), dimension(:), pointer :: c_mesg + integer :: i + + ! C interface definitions + interface + function SMIOL_error_string(errno) result(err_mesg) bind(C, name='SMIOL_error_string') + use iso_c_binding, only : c_int, c_ptr + integer(kind=c_int), value :: errno + type (c_ptr) :: err_mesg + end function + end interface + + c_mesg_ptr = SMIOL_error_string(ierrno) + call c_f_pointer(c_mesg_ptr, c_mesg, shape=[len(err_mesg)]) + + do i=1,len(err_mesg) + if (c_mesg(i) == c_null_char) exit + end do + + i = i - 1 + + err_mesg(1:i) = transfer(c_mesg(1:i), err_mesg) + err_mesg = err_mesg(1:i) + + end function SMIOLf_error_string + + + !----------------------------------------------------------------------- + ! routine SMIOLf_lib_error_string + ! + !> \brief Returns an error string for a third-party library called by SMIOL + !> \details + !> Returns an error string corresponding to an error that was generated by + !> a third-party library that was called by SMIOL. The library that was the source + !> of the error, as well as the library-specific error code, are retrieved from + !> a SMIOL context. If successive library calls resulted in errors, only the error + !> string for the last of these errors will be returned. + !> + !> The error string is always of length 128, and so it is recommended to trim + !> the string before it is printed. + ! + !----------------------------------------------------------------------- + character(len=128) function SMIOLf_lib_error_string(context) result(err_mesg) + + use iso_c_binding, only : c_ptr, c_null_ptr, c_char, c_null_char, c_f_pointer, c_loc + + implicit none + + type (SMIOLf_context), target :: context + + type (c_ptr) :: c_context = c_null_ptr + type (c_ptr) :: c_mesg_ptr = c_null_ptr + character(kind=c_char), dimension(:), pointer :: c_mesg => null() + integer :: i + + ! C interface definitions + interface + function SMIOL_lib_error_string(context) result(err_mesg) bind(C, name='SMIOL_lib_error_string') + use iso_c_binding, only : c_ptr + type(c_ptr), value :: context + type (c_ptr) :: err_mesg + end function + end interface + + c_context = c_loc(context) + + c_mesg_ptr = SMIOL_lib_error_string(c_context) + call c_f_pointer(c_mesg_ptr, c_mesg, shape=[len(err_mesg)]) + + do i=1,len(err_mesg) + if (c_mesg(i) == c_null_char) exit + end do + + i = i - 1 + + err_mesg(1:i) = transfer(c_mesg(1:i), err_mesg) + err_mesg = err_mesg(1:i) + + end function SMIOLf_lib_error_string + + + !----------------------------------------------------------------------- + ! routine SMIOLf_set_option + ! + !> \brief Sets an option for the SMIOL library + !> \details + !> Detailed description of what this routine does. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_set_option() result(ierr) + + implicit none + + ierr = 0 + + end function SMIOLf_set_option + + !----------------------------------------------------------------------- + ! routine SMIOLf_set_frame + ! + !> \brief Set the frame of an open file + !> \details + !> For an open SMIOL file handle, set the frame for the unlimited dimension. + !> After setting the frame for a file, writing to a variable that is + !> dimensioned by the unlimited dimension will write to the last set frame, + !> overwriting any current data that maybe present in that frame. + !> + !> SMIOL_SUCCESS will be returned if the frame is successfully set otherwise an + !> error will return. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_set_frame(file, frame) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr + + implicit none + + type (SMIOLf_file), target :: file + integer (kind=SMIOL_offset_kind), value, intent(in) :: frame + + type (c_ptr) :: c_file + + ! C interface definitions + interface + function SMIOL_set_frame(file, frame) result(ierr) bind(C, name='SMIOL_set_frame') + use iso_c_binding, only : c_ptr, c_int + import SMIOL_offset_kind + type (c_ptr), value :: file + integer (kind=SMIOL_offset_kind), value :: frame + integer (kind=c_int) :: ierr + end function + end interface + + c_file = c_loc(file) + ierr = SMIOL_set_frame(c_file, frame) + + end function SMIOLf_set_frame + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_frame + ! + !> \brief Get the frame of an open file + !> \details + !> Get the current frame of an open file. Upon success, SMIOL_SUCCESS will be + !> returned, otherwise an error will be returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_get_frame(file, frame) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc + + implicit none + + type (SMIOLf_file), target, intent(in) :: file + integer (kind=SMIOL_offset_kind), target, intent(out) :: frame + + type (c_ptr) :: c_file + type (c_ptr) :: c_frame + + ! C interface definitions + interface + function SMIOL_get_frame(file, frame) result(ierr) bind(C, name='SMIOL_get_frame') + use iso_c_binding, only : c_ptr, c_int + type (c_ptr), value :: file + type (c_ptr), value :: frame + integer (kind=c_int) :: ierr + end function + end interface + + c_file = c_loc(file) + c_frame = c_loc(frame) + ierr = SMIOL_get_frame(c_file, c_frame) + + end function SMIOLf_get_frame + + + !----------------------------------------------------------------------- + ! routine SMIOLf_create_decomp + ! + !> \brief Creates a mapping between compute elements and I/O elements + !> \details + !> Given arrays of global element IDs that each task computes, this routine + !> works out a mapping of elements between compute and I/O tasks. + !> + !> The aggregation factor is used to indicate the size of subsets of ranks + !> that will gather fields onto a single rank in each subset before transferring + !> that field from compute to output tasks; in a symmetric way, it also + !> indicates the size of subsets over which fields will be scattered after they + !> are transferred from input tasks to a single compute tasks in each subset. + !> + !> An aggregation factor of 0 indicates that the implementation should choose + !> a suitable aggregation factor (usually matching the size of shared-memory + !> domains), while a positive integer specifies a specific size for task groups + !> to be used for aggregation. + !> + !> If the optional aggregation_factor argument is not given, it defaults to + !> a value of 0. + !> + !> If all input arguments are determined to be valid and if the routine is + !> successful in working out a mapping, the decomp pointer is allocated + !> and given valid contents, and SMIOL_SUCCESS is returned; otherwise + !> a non-success error code is returned and the decomp pointer is unassociated. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_create_decomp(context, n_compute_elements, compute_elements, decomp, & + aggregation_factor) result(ierr) + + use iso_c_binding, only : c_int, c_size_t, c_ptr, c_null_ptr, c_loc, c_f_pointer, c_associated + + implicit none + + ! Arguments + type (SMIOLf_context), target, intent(in) :: context + integer(kind=c_size_t), intent(in) :: n_compute_elements + integer(kind=SMIOL_offset_kind), dimension(n_compute_elements), target, intent(in) :: compute_elements + type (SMIOLf_decomp), pointer, intent(inout) :: decomp + integer, intent(in), optional :: aggregation_factor + + ! Local variables + type (c_ptr) :: c_context + type (c_ptr) :: c_decomp + type (c_ptr) :: c_compute_elements + integer(kind=c_int) :: c_agg_factor + + interface + function SMIOL_create_decomp(context, n_compute_elements, compute_elements, aggregation_factor, decomp) & + result(ierr) bind(C, name='SMIOL_create_decomp') + use iso_c_binding, only : c_size_t, c_ptr, c_int + type (c_ptr), value :: context + integer(c_size_t), value :: n_compute_elements + type (c_ptr), value :: compute_elements + integer(kind=c_int), value :: aggregation_factor + integer(kind=c_int) :: ierr + type (c_ptr) :: decomp + end function + end interface + + + if (present(aggregation_factor)) then + c_agg_factor = aggregation_factor + else + c_agg_factor = 0 ! Let SMIOL choose its own aggregation factor + end if + + ! Get C pointers to Fortran types + c_context = c_loc(context) + if (size(compute_elements) > 0) then + c_compute_elements = c_loc(compute_elements) + else + c_compute_elements = c_null_ptr + end if + + c_decomp = c_null_ptr + + ierr = SMIOL_create_decomp(c_context, n_compute_elements, c_compute_elements, c_agg_factor, c_decomp) + + ! Error check and translate c_decomp pointer into a Fortran SMIOLf_decomp pointer + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_decomp)) then + call c_f_pointer(c_decomp, decomp) + else + nullify(decomp) + ierr = SMIOL_FORTRAN_ERROR + end if + else + nullify(decomp) + if (c_associated(c_decomp)) then + ierr = SMIOL_FORTRAN_ERROR + endif + end if + + end function SMIOLf_create_decomp + + + !----------------------------------------------------------------------- + ! routine SMIOLf_free_decomp + ! + !> \brief Frees a mapping between compute elements and I/O elements + !> \details + !> Frees all memory of a SMIOLf_decomp and returns SMIOL_SUCCESS. If + !> decomp is unassociated, nothing will be done and SMIOL_SUCCESS will + !> be returned. After this function has been called, no other SMIOL + !> routines should use the freed SMIOL_decomp. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_free_decomp(decomp) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc, c_associated, c_null_ptr + + implicit none + + type(SMIOLF_decomp), pointer, intent(inout) :: decomp + type(c_ptr) :: c_decomp = c_null_ptr + + interface + function SMIOL_free_decomp(decomp) result(ierr) bind(C, name='SMIOL_free_decomp') + use iso_c_binding, only : c_ptr, c_int + type(c_ptr) :: decomp + integer(kind=c_int) :: ierr + end function + end interface + + ierr = SMIOL_SUCCESS + + if (associated(decomp)) then + c_decomp = c_loc(decomp) + endif + ierr = SMIOL_free_decomp(c_decomp) + + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_decomp)) then + ierr = SMIOL_FORTRAN_ERROR + else + nullify(decomp) + end if + else + if (.not. c_associated(c_decomp)) then + nullify(decomp) + end if + end if + + end function SMIOLf_free_decomp + + !----------------------------------------------------------------------- + ! routine SMIOLf_f_to_c_string + ! + !> \brief Convert a Fortran string to a C null-terminated character array + !> \details + !> Converts a Fortran string to a C null-terminated character array. + !> The cstring output argument must be large enough to contain the trimmed + !> Fortran string plus at least one c_null_char character. Any characters + !> beyond len_trim(fstring) of cstring will be filled with c_null_char + !> characters. If the size of cstring is less than len_trim(fstring)+1, + !> then only size(cstring)-1 characters from fstring will be copied into + !> cstring before the final c_null_char character is added. + ! + !----------------------------------------------------------------------- + subroutine SMIOLf_f_to_c_string(fstring, cstring) + + use iso_c_binding, only : c_char, c_null_char + + implicit none + + character(len=*), intent(in) :: fstring + character(kind=c_char), dimension(:), intent(out) :: cstring + + integer :: i + integer :: nchar + + if (size(cstring) <= 0) then + return + end if + + nchar = min(size(cstring)-1, len_trim(fstring)) + + do i = 1, nchar + cstring(i) = fstring(i:i) + end do + cstring(nchar+1:size(cstring)) = c_null_char + + end subroutine SMIOLf_f_to_c_string + +end module SMIOLf diff --git a/src/external/SMIOL/smiolf_put_get_var.inc b/src/external/SMIOL/smiolf_put_get_var.inc new file mode 100644 index 0000000000..1ad9e744ed --- /dev/null +++ b/src/external/SMIOL/smiolf_put_get_var.inc @@ -0,0 +1,3994 @@ + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_char + ! + !> \brief Writes a 0-d char variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_char(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_char, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + character(len=:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + character(kind=c_char), dimension(:), allocatable, target :: char_buf + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + allocate(char_buf(len(buf))) + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do + c_buf = c_loc(char_buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + if (associated(buf)) then + deallocate(char_buf) + end if + deallocate(c_varname) + + end function SMIOLf_put_var_0d_char + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_char + ! + !> \brief Reads a 0-d char variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_char(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_char, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + character(len=:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + character(kind=c_char), dimension(:), allocatable, target :: char_buf + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + allocate(char_buf(len(buf))) + + ! In case buf contains more characters than will be read from the file, + ! initialize char_buf with the contents of buf to preserve un-read + ! characters during the copy of char_buf back into buf later on + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do + c_buf = c_loc(char_buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + if (associated(buf)) then + do i=1,len(buf) + buf(i:i) = char_buf(i) + end do + + deallocate(char_buf) + end if + deallocate(c_varname) + + end function SMIOLf_get_var_0d_char + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_real32 + ! + !> \brief Writes a 0-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_0d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_real32 + ! + !> \brief Reads a 0-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_0d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_real64 + ! + !> \brief Writes a 0-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_0d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_real64 + ! + !> \brief Reads a 0-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_0d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_int32 + ! + !> \brief Writes a 0-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_0d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_int32 + ! + !> \brief Reads a 0-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_0d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_1d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_1d_real32(a, d1) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1 + real(kind=c_float), dimension(d1), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_1d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d1_real32 + ! + !> \brief Writes a 1-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_1d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_1d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d1_real32 + ! + !> \brief Reads a 1-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_1d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_1d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_1d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_1d_real64(a, d1) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1 + real(kind=c_double), dimension(d1), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_1d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d1_real64 + ! + !> \brief Writes a 1-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_1d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real64(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_1d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d1_real64 + ! + !> \brief Reads a 1-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_1d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real64(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_1d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_1d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_1d_int32(a, d1) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1 + integer(kind=c_int), dimension(d1), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_1d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d1_int32 + ! + !> \brief Writes a 1-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_1d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_int32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_1d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d1_int32 + ! + !> \brief Reads a 1-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_1d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_int32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_1d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_2d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_2d_real32(a, d1, d2) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2 + real(kind=c_float), dimension(d1,d2), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_2d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d2_real32 + ! + !> \brief Writes a 2-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_2d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_2d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d2_real32 + ! + !> \brief Reads a 2-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_2d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_2d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_2d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_2d_real64(a, d1, d2) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2 + real(kind=c_double), dimension(d1,d2), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_2d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d2_real64 + ! + !> \brief Writes a 2-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_2d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real64(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_2d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d2_real64 + ! + !> \brief Reads a 2-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_2d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real64(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_2d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_2d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_2d_int32(a, d1, d2) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2 + integer(kind=c_int), dimension(d1,d2), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_2d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d2_int32 + ! + !> \brief Writes a 2-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_2d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_int32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_2d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d2_int32 + ! + !> \brief Reads a 2-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_2d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_int32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_2d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_3d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_3d_real32(a, d1, d2, d3) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3 + real(kind=c_float), dimension(d1,d2,d3), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_3d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d3_real32 + ! + !> \brief Writes a 3-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_3d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_3d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d3_real32 + ! + !> \brief Reads a 3-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_3d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_3d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_3d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_3d_real64(a, d1, d2, d3) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3 + real(kind=c_double), dimension(d1,d2,d3), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_3d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d3_real64 + ! + !> \brief Writes a 3-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_3d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_3d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d3_real64 + ! + !> \brief Reads a 3-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_3d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_3d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_3d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_3d_int32(a, d1, d2, d3) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3 + integer(kind=c_int), dimension(d1,d2,d3), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_3d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d3_int32 + ! + !> \brief Writes a 3-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_3d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_3d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d3_int32 + ! + !> \brief Reads a 3-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_3d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_3d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_4d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_4d_real32(a, d1, d2, d3, d4) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4 + real(kind=c_float), dimension(d1,d2,d3,d4), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_4d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d4_real32 + ! + !> \brief Writes a 4-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_4d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_4d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d4_real32 + ! + !> \brief Reads a 4-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_4d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_4d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_4d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_4d_real64(a, d1, d2, d3, d4) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4 + real(kind=c_double), dimension(d1,d2,d3,d4), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_4d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d4_real64 + ! + !> \brief Writes a 4-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_4d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_4d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d4_real64 + ! + !> \brief Reads a 4-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_4d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_4d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_4d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_4d_int32(a, d1, d2, d3, d4) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4 + integer(kind=c_int), dimension(d1,d2,d3,d4), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_4d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d4_int32 + ! + !> \brief Writes a 4-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_4d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_4d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d4_int32 + ! + !> \brief Reads a 4-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_4d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_4d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_5d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_5d_real32(a, d1, d2, d3, d4, d5) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4, d5 + real(kind=c_float), dimension(d1,d2,d3,d4,d5), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_5d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d5_real32 + ! + !> \brief Writes a 5-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_5d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_5d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d5_real32 + ! + !> \brief Reads a 5-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_5d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_5d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_5d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_5d_real64(a, d1, d2, d3, d4, d5) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4, d5 + real(kind=c_double), dimension(d1,d2,d3,d4,d5), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_5d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d5_real64 + ! + !> \brief Writes a 5-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_5d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_5d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d5_real64 + ! + !> \brief Reads a 5-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_5d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_5d_real64 + + diff --git a/src/external/esmf_time_f90/ESMF_BaseMod.F90 b/src/external/esmf_time_f90/ESMF_BaseMod.F90 index 435ca8d02a..3e1294c0cb 100644 --- a/src/external/esmf_time_f90/ESMF_BaseMod.F90 +++ b/src/external/esmf_time_f90/ESMF_BaseMod.F90 @@ -68,11 +68,23 @@ module ESMF_BaseMod ESMF_STATE_BUSY = ESMF_Status(5), & ESMF_STATE_INVALID = ESMF_Status(6) +!------------------------------------------------------------------------------ +! + integer, parameter :: & + ESMF_KIND_I1 = selected_int_kind(2), & + ESMF_KIND_I2 = selected_int_kind(4), & + ESMF_KIND_I4 = selected_int_kind(9), & + ESMF_KIND_I8 = selected_int_kind(18), & + ESMF_KIND_R4 = selected_real_kind(3,25), & + ESMF_KIND_R8 = selected_real_kind(6,45), & + ESMF_KIND_C8 = selected_real_kind(3,25), & + ESMF_KIND_C16 = selected_real_kind(6,45) + !------------------------------------------------------------------------------ ! type ESMF_Pointer private - integer*8 :: ptr + integer(kind=ESMF_KIND_I8) :: ptr end type type(ESMF_Pointer), parameter :: ESMF_NULL_POINTER = ESMF_Pointer(0), & @@ -95,18 +107,6 @@ module ESMF_BaseMod ESMF_DATA_LOGICAL = ESMF_DataType(3), & ESMF_DATA_CHARACTER = ESMF_DataType(4) -!------------------------------------------------------------------------------ - - integer, parameter :: & - ESMF_KIND_I1 = selected_int_kind(2), & - ESMF_KIND_I2 = selected_int_kind(4), & - ESMF_KIND_I4 = selected_int_kind(9), & - ESMF_KIND_I8 = selected_int_kind(18), & - ESMF_KIND_R4 = selected_real_kind(3,25), & - ESMF_KIND_R8 = selected_real_kind(6,45), & - ESMF_KIND_C8 = selected_real_kind(3,25), & - ESMF_KIND_C16 = selected_real_kind(6,45) - !------------------------------------------------------------------------------ type ESMF_DataValue @@ -160,7 +160,7 @@ module ESMF_BaseMod ! type ESMF_BasePointer private - integer*8 :: base_ptr + integer(kind=ESMF_KIND_I8) :: base_ptr end type integer :: global_count = 0 @@ -950,7 +950,7 @@ subroutine ESMF_SetPointer(ptype, contents, rc) ! ! !ARGUMENTS: type(ESMF_Pointer) :: ptype - integer*8, intent(in) :: contents + integer(kind=ESMF_KIND_I8), intent(in) :: contents integer, intent(out), optional :: rc ! @@ -985,7 +985,7 @@ subroutine ESMF_SetNullPointer(ptype, rc) ! !EOP ! !REQUIREMENTS: - integer*8, parameter :: nullp = 0 + integer(kind=ESMF_KIND_I8), parameter :: nullp = 0 ptype%ptr = nullp if (present(rc)) rc = ESMF_SUCCESS @@ -999,7 +999,7 @@ end subroutine ESMF_SetNullPointer function ESMF_GetPointer(ptype, rc) ! ! !RETURN VALUE: - integer*8 :: ESMF_GetPointer + integer(kind=ESMF_KIND_I8) :: ESMF_GetPointer ! !ARGUMENTS: type(ESMF_Pointer), intent(in) :: ptype diff --git a/src/framework/Makefile b/src/framework/Makefile index d19cd78677..564dcfd5ac 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -33,8 +33,8 @@ OBJS = mpas_kind_types.o \ mpas_pool_routines.o \ xml_stream_parser.o \ regex_matching.o \ - mpas_field_accessor.o \ - mpas_log.o + mpas_log.o \ + mpas_halo.o all: framework $(DEPS) @@ -107,7 +107,7 @@ mpas_c_interfacing.o: xml_stream_parser.o: xml_stream_parser.c $(CC) $(CFLAGS) $(CPPFLAGS) $(CPPINCLUDES) -I../external/ezxml -c xml_stream_parser.c -mpas_field_accessor.o: mpas_derived_types.o mpas_kind_types.o mpas_pool_routines.o mpas_log.o +mpas_halo.o: mpas_derived_types.o mpas_pool_routines.o mpas_log.o clean: $(RM) *.o *.mod *.f90 libframework.a diff --git a/src/framework/framework.cmake b/src/framework/framework.cmake new file mode 100644 index 0000000000..f74747fb4f --- /dev/null +++ b/src/framework/framework.cmake @@ -0,0 +1,35 @@ +# framework +list(APPEND COMMON_RAW_SOURCES + framework/mpas_kind_types.F + framework/mpas_framework.F + framework/mpas_timer.F + framework/mpas_timekeeping.F + framework/mpas_constants.F + framework/mpas_attlist.F + framework/mpas_hash.F + framework/mpas_sort.F + framework/mpas_block_decomp.F + framework/mpas_block_creator.F + framework/mpas_dmpar.F + framework/mpas_abort.F + framework/mpas_decomp.F + framework/mpas_threading.F + framework/mpas_io.F + framework/mpas_io_streams.F + framework/mpas_bootstrapping.F + framework/mpas_io_units.F + framework/mpas_stream_manager.F + framework/mpas_stream_list.F + framework/mpas_forcing.F + framework/mpas_c_interfacing.F + framework/random_id.c + framework/pool_hash.c + framework/mpas_derived_types.F + framework/mpas_domain_routines.F + framework/mpas_field_routines.F + framework/mpas_pool_routines.F + framework/xml_stream_parser.c + framework/regex_matching.c + framework/mpas_field_accessor.F + framework/mpas_log.F +) diff --git a/src/framework/mpas_attlist_types.inc b/src/framework/mpas_attlist_types.inc index 8c664bdcbe..b69768833a 100644 --- a/src/framework/mpas_attlist_types.inc +++ b/src/framework/mpas_attlist_types.inc @@ -11,7 +11,7 @@ ! Derived type for holding field attributes type att_list_type character (len=StrKIND) :: attName = '' - integer :: attType = -1 + integer :: attType = -1 ! Should not match any of MPAS_ATT_INT, MPAS_ATT_REAL, etc. integer :: attValueInt integer, dimension(:), pointer :: attValueIntA => null() real (kind=RKIND) :: attValueReal diff --git a/src/framework/mpas_block_creator.F b/src/framework/mpas_block_creator.F index 488beef2b0..42070c04b8 100644 --- a/src/framework/mpas_block_creator.F +++ b/src/framework/mpas_block_creator.F @@ -20,6 +20,9 @@ ! !----------------------------------------------------------------------- +#define REPORT_FIELD_ALLOCATION(F,B) ! call field_allocate_mesg(F, B) +#define REPORT_TOTAL_ALLOCATION(B) ! call total_allocated_mesg(B) + module mpas_block_creator use mpas_dmpar @@ -1228,6 +1231,10 @@ subroutine mpas_block_creator_finalize_block_phase2(stream_manager, blocklist, r integer, pointer :: dim0d integer, dimension(:), pointer :: dim1d + integer(kind=I8KIND) :: allocated_bytes + integer :: total_allocated_mb + + domain => blocklist % domain ! Loop over blocks @@ -1266,7 +1273,22 @@ subroutine mpas_block_creator_finalize_block_phase2(stream_manager, blocklist, r call mpas_log_write('Derived dimension setup failed for core ' // trim(block_ptr % domain % core % coreName), MPAS_LOG_CRIT) end if - call mpas_block_creator_allocate_pool_fields(block_ptr % structs, block_ptr % dimensions) + + call mpas_log_write('Allocating fields ...') + allocated_bytes = 0_I8KIND + + call mpas_block_creator_allocate_pool_fields(block_ptr % structs, block_ptr % dimensions, allocated_bytes, ierr) + if (ierr /= 0) then + call mpas_log_write('Allocation of fields failed for core ' // trim(block_ptr % domain % core % coreName), MPAS_LOG_CRIT) + end if + + call mpas_log_write(' $i MB allocated for fields on this task', intArgs=[int(allocated_bytes / 1000000_I8KIND)]) + if (domain % dminfo % nprocs > 1) then + call mpas_dmpar_sum_int(domain % dminfo, int(allocated_bytes / 1000000_I8KIND), total_allocated_mb) + call mpas_log_write(' $i MB total allocated for fields across all tasks', intArgs=[total_allocated_mb]) + end if + call mpas_log_write(' ----- done allocating fields -----') + call mpas_log_write('') err_level = mpas_pool_get_error_level() call mpas_pool_set_error_level(MPAS_POOL_SILENT) @@ -1534,9 +1556,20 @@ end subroutine mpas_block_creator_reindex_block_fields!}}} !> This routine also copies all dimensions from dimensionPool to currentPool ! !----------------------------------------------------------------------- - recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimensionPool)!{{{ + recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimensionPool, allocated_bytes, ierr)!{{{ + type (mpas_pool_type), pointer :: currentPool !< Input: Current pool to allocate and copy dimensions. type (mpas_pool_type), pointer :: dimensionPool !< Input: Pool of dimensions for the current block + integer(kind=I8KIND), intent(inout) :: allocated_bytes !< Input/Output: The total number of bytes allocated for fields + integer, intent(out) :: ierr !< Output: Return status code, 0 = success + +#ifdef SINGLE_PRECISION + integer(kind=I8KIND), parameter :: real_size = 4_I8KIND +#else + integer(kind=I8KIND), parameter :: real_size = 8_I8KIND +#endif + integer(kind=I8KIND), parameter :: int_size = 4_I8KIND + type (mpas_pool_type), pointer :: subPool type (mpas_pool_iterator_type) :: poolItr @@ -1555,6 +1588,11 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens integer, dimension(:), pointer :: tempDim1D integer :: dimSize integer :: localErr + integer :: ierr_alloc + + integer(kind=I8KIND) :: field_bytes + + ierr = 0 call mpas_pool_begin_iteration(dimensionPool) do while( mpas_pool_get_next_member(dimensionPool, poolItr) ) @@ -1573,7 +1611,11 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens do while ( mpas_pool_get_next_member(currentPool, poolItr) ) if ( poolItr % memberType == MPAS_POOL_SUBPOOL ) then call mpas_pool_get_subpool(currentPool, poolItr % memberName, subPool) - call mpas_block_creator_allocate_pool_fields(subPool, dimensionPool) + call mpas_block_creator_allocate_pool_fields(subPool, dimensionPool, allocated_bytes, ierr) + if (ierr /= 0) then + call mpas_log_write('failed to allocate fields in pool '//trim(poolItr % memberName), messageType=MPAS_LOG_ERR) + return + end if else if ( poolItr % memberType == MPAS_POOL_FIELD ) then if ( poolItr % dataType == MPAS_POOL_REAL ) then if ( poolItr % nDims == 1 ) then @@ -1592,7 +1634,16 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real1DField % isPersistent ) then - allocate(real1DField % array(real1DField % dimSizes(1))) + field_bytes = int(real1DField % dimSizes(1), kind=I8KIND) * real_size + REPORT_FIELD_ALLOCATION(real1DField % fieldName, field_bytes) + allocate(real1DField % array(real1DField % dimSizes(1)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real1DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real1DField % array(:) = real1DField % defaultValue end if end if @@ -1612,7 +1663,18 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real2DField % isPersistent ) then - allocate(real2DField % array(real2DField % dimSizes(1), real2DField % dimSizes(2))) + field_bytes = int(real2DField % dimSizes(1), kind=I8KIND) & + * int(real2DField % dimSizes(2), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real2DField % fieldName, field_bytes) + allocate(real2DField % array(real2DField % dimSizes(1), real2DField % dimSizes(2)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real2DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real2DField % array(:,:) = real2DField % defaultValue end if end if @@ -1632,7 +1694,20 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real3DField % isPersistent ) then - allocate(real3DField % array(real3DField % dimSizes(1), real3DField % dimSizes(2), real3DField % dimSizes(3))) + field_bytes = int(real3DField % dimSizes(1), kind=I8KIND) & + * int(real3DField % dimSizes(2), kind=I8KIND) & + * int(real3DField % dimSizes(3), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real3DField % fieldName, field_bytes) + allocate(real3DField % array(real3DField % dimSizes(1), real3DField % dimSizes(2), & + real3DField % dimSizes(3)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real3DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real3DField % array(:,:,:) = real3DField % defaultValue end if end if @@ -1652,8 +1727,22 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real4DField % isPersistent ) then + field_bytes = int(real4DField % dimSizes(1), kind=I8KIND) & + * int(real4DField % dimSizes(2), kind=I8KIND) & + * int(real4DField % dimSizes(3), kind=I8KIND) & + * int(real4DField % dimSizes(4), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real4DField % fieldName, field_bytes) allocate(real4DField % array(real4DField % dimSizes(1), real4DField % dimSizes(2), & - real4DField % dimSizes(3), real4DField % dimSizes(4))) + real4DField % dimSizes(3), real4DField % dimSizes(4)), & + stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real4DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real4DField % array(:,:,:,:) = real4DField % defaultValue end if end if @@ -1673,9 +1762,23 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real5DField % isPersistent ) then + field_bytes = int(real5DField % dimSizes(1), kind=I8KIND) & + * int(real5DField % dimSizes(2), kind=I8KIND) & + * int(real5DField % dimSizes(3), kind=I8KIND) & + * int(real5DField % dimSizes(4), kind=I8KIND) & + * int(real5DField % dimSizes(5), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real5DField % fieldName, field_bytes) allocate(real5DField % array(real5DField % dimSizes(1), real5DField % dimSizes(2), & real5DField % dimSizes(3), real5DField % dimSizes(4), & - real5DField % dimSizes(5))) + real5DField % dimSizes(5)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real5DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real5DField % array(:,:,:,:,:) = real5DField % defaultValue end if end if @@ -1697,7 +1800,16 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( int1DField % isPersistent ) then - allocate(int1DField % array(int1DField % dimSizes(1))) + field_bytes = int(int1DField % dimSizes(1), kind=I8KIND) * int_size + REPORT_FIELD_ALLOCATION(int1DField % fieldName, field_bytes) + allocate(int1DField % array(int1DField % dimSizes(1)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(int1DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) int1DField % array(:) = int1DField % defaultValue end if end if @@ -1717,7 +1829,18 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( int2DField % isPersistent ) then - allocate(int2DField % array(int2DField % dimSizes(1), int2DField % dimSizes(2))) + field_bytes = int(int2DField % dimSizes(1), kind=I8KIND) & + * int(int2DField % dimSizes(2), kind=I8KIND) & + * int_size + REPORT_FIELD_ALLOCATION(int2DField % fieldName, field_bytes) + allocate(int2DField % array(int2DField % dimSizes(1), int2DField % dimSizes(2)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(int2DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) int2DField % array(:,:) = int2DField % defaultValue end if end if @@ -1737,7 +1860,20 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( int3DField % isPersistent ) then - allocate(int3DField % array(int3DField % dimSizes(1), int3DField % dimSizes(2), int3DField % dimSizes(3))) + field_bytes = int(int3DField % dimSizes(1), kind=I8KIND) & + * int(int3DField % dimSizes(2), kind=I8KIND) & + * int(int3DField % dimSizes(3), kind=I8KIND) & + * int_size + REPORT_FIELD_ALLOCATION(int3DField % fieldName, field_bytes) + allocate(int3DField % array(int3DField % dimSizes(1), int3DField % dimSizes(2), & + int3DField % dimSizes(3)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(int3DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) int3DField % array(:,:,:) = int3DField % defaultValue end if end if @@ -1759,7 +1895,16 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( char1DField % isPersistent ) then - allocate(char1DField % array(char1DField % dimSizes(1))) + field_bytes = char1DField % dimSizes(1) + REPORT_FIELD_ALLOCATION(char1DField % fieldName, field_bytes) + allocate(char1DField % array(char1DField % dimSizes(1)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(char1DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) char1DField % array(:) = char1DField % defaultValue end if end if @@ -1785,4 +1930,50 @@ subroutine missing_dim_abort(dimName, fieldName) end subroutine missing_dim_abort + +!*********************************************************************** +! +! routine field_allocate_mesg +! +!> \brief Adds message to log file about memory to be allocated for a field +!> \author Michael Duda +!> \date 8 February 2022 +!> \details +!> Given the name of a field and the number of bytes to be allocated for that +!> field, write a message to the log file indicating that the specified number +!> of bytes will be allocated for the field. +! +!----------------------------------------------------------------------- + subroutine field_allocate_mesg(fieldName, field_bytes) + + character(len=*), intent(in) :: fieldName + integer(kind=I8KIND), intent(in) :: field_bytes + + call mpas_log_write(' allocating $i bytes for '//trim(fieldName), intArgs=[int(field_bytes)]) + + end subroutine field_allocate_mesg + + +!*********************************************************************** +! +! routine total_allocated_mesg +! +!> \brief Adds message to log file about total memory allocated for fields +!> \author Michael Duda +!> \date 8 February 2022 +!> \details +!> Given the the total number of bytes allocated as of the call to this routine, +!> write a message to the log file indicating the total number of kB that have +!> been allocated for fields. The allocated_bytes argument is measured in bytes, +!> and this value is internally converted to kB by this routine. +! +!----------------------------------------------------------------------- + subroutine total_allocated_mesg(allocated_bytes) + + integer(kind=I8KIND), intent(in) :: allocated_bytes + + call mpas_log_write(' total $i kB allocated on this task', intArgs=[int(allocated_bytes / 1000_I8KIND)]) + + end subroutine total_allocated_mesg + end module mpas_block_creator diff --git a/src/framework/mpas_block_decomp.F b/src/framework/mpas_block_decomp.F index 8a5c75ce9c..4f3d197d5d 100644 --- a/src/framework/mpas_block_decomp.F +++ b/src/framework/mpas_block_decomp.F @@ -98,7 +98,6 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l if (dminfo % my_proc_id == IO_NODE) then - iunit = 50 + dminfo % my_proc_id if (dminfo % total_blocks < 10) then write(filename,'(a,i1)') trim(blockFilePrefix), dminfo % total_blocks else if (dminfo % total_blocks < 100) then @@ -117,6 +116,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l write(filename,'(a,i8)') trim(blockFilePrefix), dminfo % total_blocks end if + call mpas_new_unit(iunit) open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus) if (istatus /= 0) then @@ -194,6 +194,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l global_start, local_nvertices, global_list, local_block_list) close(unit=iunit) + call mpas_release_unit(iunit) else @@ -661,7 +662,6 @@ subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ allocate(block_counter(dminfo % nProcs)) block_counter = 0 - iounit = 51 + dminfo % my_proc_id if (dminfo % nProcs < 10) then write(filename,'(a,i1)') trim(procFilePrefix), dminfo % nProcs else if (dminfo % nProcs < 100) then @@ -678,6 +678,7 @@ subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ write(filename,'(a,i7)') trim(procFilePrefix), dminfo % nProcs end if + call mpas_new_unit(iounit) open(unit=iounit, file=trim(filename), form='formatted', status='old', iostat=istatus) do i=1,dminfo % total_blocks @@ -690,6 +691,7 @@ subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ end do close(unit=iounit) + call mpas_release_unit(iounit) deallocate(block_counter) call mpas_dmpar_bcast_ints(dminfo, dminfo % total_blocks, dminfo % block_proc_list) call mpas_dmpar_bcast_ints(dminfo, dminfo % total_blocks, dminfo % block_local_id_list) diff --git a/src/framework/mpas_bootstrapping.F b/src/framework/mpas_bootstrapping.F index e87dadc077..b931bd6d95 100644 --- a/src/framework/mpas_bootstrapping.F +++ b/src/framework/mpas_bootstrapping.F @@ -76,13 +76,22 @@ module mpas_bootstrapping !> mpas_initialize_vectors() ! !----------------------------------------------------------------------- - subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype) !{{{ + subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype, pio_file_desc) !{{{ + +#ifdef MPAS_PIO_SUPPORT + use pio, only : file_desc_t +#endif implicit none type (domain_type), pointer :: domain character(len=*), intent(in) :: mesh_filename integer, intent(in) :: mesh_iotype +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, intent(inout), optional :: pio_file_desc +#endif type (block_type), pointer :: readingBlock @@ -147,7 +156,8 @@ subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype) ! nHalos = config_num_halos - inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, mesh_iotype, domain % ioContext, ierr=ierr) + inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, mesh_iotype, domain % ioContext, & + pio_file_desc=pio_file_desc, ierr=ierr) if (ierr /= MPAS_IO_NOERR) then call mpas_log_write('Could not open input file '''//trim(mesh_filename)//''' to read mesh fields', MPAS_LOG_CRIT) else @@ -437,14 +447,22 @@ end subroutine mpas_bootstrap_framework_phase1 !}}} !> and allocating all fields and structs. ! !----------------------------------------------------------------------- - subroutine mpas_bootstrap_framework_phase2(domain) !{{{ + subroutine mpas_bootstrap_framework_phase2(domain, pio_file_desc) !{{{ use mpas_stream_manager use mpas_stream_list +#ifdef MPAS_PIO_SUPPORT + use pio, only : file_desc_t +#endif implicit none type (domain_type), pointer :: domain +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, intent(inout), optional :: pio_file_desc +#endif type (mpas_pool_type), pointer :: readableDimensions type (mpas_pool_type), pointer :: streamDimensions @@ -474,105 +492,182 @@ subroutine mpas_bootstrap_framework_phase2(domain) !{{{ call mpas_log_write(' ') call mpas_log_write(' ') - ! Reading dimensions from streams - call mpas_log_write('Reading dimensions from input streams ...') - call mpas_stream_mgr_begin_iteration(domain % streamManager) - do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamID = streamName, directionProperty = streamDirection, & - activeProperty = streamActive) ) + if (present(pio_file_desc)) then + call mpas_log_write('Reading dimensions from external PIO file handle ...') + + ! Build stream dimension pool from the list of fields + call mpas_pool_create_pool(streamDimensions) - if ( streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + call mpas_pool_begin_iteration(domain % blocklist % allFields) + do while ( mpas_pool_get_next_member(domain % blocklist % allFields, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_FIELD ) then + call get_dimlist_for_field(domain % blocklist % allFields, poolItr % memberName, dimNames) + do i=1,size(dimNames) + call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) + if ( .not. associated(dimValue) ) then + call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) + end if + end do + end if + end do - call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=streamName) + ioType = MPAS_IO_NETCDF ! ioType is not actually used when an external PIO file_desc_t is provided to MPAS_io_open + inputHandle = MPAS_io_open('FILENAME_NOT_USED', MPAS_IO_READ, ioType, domain % ioContext, pio_file_desc = pio_file_desc, ierr = err_local) - ! Build stream dimension pool from the list of fields - call mpas_pool_create_pool(streamDimensions) + ! If to determine if file was opened or not. + if ( err_local == MPAS_IO_NOERR ) then - do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamName, fieldName, isActive=fieldActive) ) + call mpas_log_write(' ') - if (fieldActive) then - call get_dimlist_for_field(domain % blocklist % allFields, fieldName, dimNames) + ! Iterate over list of dimensions we determined we need from the above loop + call mpas_pool_begin_iteration(streamDimensions) + do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then + ! Try to read the dimension + call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + + ! Check to see if the dimension has already been defined + call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + + ! If to see if dimension was read or not + if ( err_local == MPAS_IO_NOERR ) then + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) - do i=1,size(dimNames) - call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) if ( .not. associated(dimValue) ) then - call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) + call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) + else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then + dimValue = tempDim + else if ( dimValue /= tempDim ) then + call mpas_log_write('Dimension ' // trim(poolItr % membername) & + // ' was read with an inconsistent value.', MPAS_LOG_CRIT) end if - end do - deallocate(dimNames) - end if + else + call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') + end if + end if end do - ! Determine stream filename - call mpas_get_stream_filename(domain % streamManager, streamID = streamName, filename = streamFilename, ierr = err_local) + ! Close file + call MPAS_io_close(inputHandle) - ! Determine stream io_type - call MPAS_stream_mgr_get_property(domain % streamManager, streamName, & - MPAS_STREAM_PROPERTY_IOTYPE, ioType, ierr = err_local) + end if - ! Try to open file - inputHandle = MPAS_io_open(trim(streamFilename), MPAS_IO_READ, ioType, domain % ioContext, ierr = err_local) + ! Destroy pool that contains list of streams dimensions + call mpas_pool_destroy_pool(streamDimensions) - ! If to determine if file was opened or not. - if ( err_local == MPAS_IO_NOERR ) then + else - call mpas_log_write(' ') - call mpas_log_write('----- reading dimensions from stream '''//trim(streamName)//''' using file ' & - //trim(streamFilename) ) + ! Reading dimensions from streams + call mpas_log_write('Reading dimensions from input streams ...') + call mpas_stream_mgr_begin_iteration(domain % streamManager) + do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamID = streamName, directionProperty = streamDirection, & + activeProperty = streamActive) ) - ! Iterate over list of dimensions we determined we need from the above loop - call mpas_pool_begin_iteration(streamDimensions) - do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) - if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then - ! Try to read the dimension - call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + if ( streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then - ! Check to see if the dimension has already been defined - call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=streamName) - ! If to see if dimension was read or not - if ( err_local == MPAS_IO_NOERR ) then - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) + ! Build stream dimension pool from the list of fields + call mpas_pool_create_pool(streamDimensions) + do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamName, fieldName, isActive=fieldActive) ) + + if (fieldActive) then + call get_dimlist_for_field(domain % blocklist % allFields, fieldName, dimNames) + + do i=1,size(dimNames) + call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) if ( .not. associated(dimValue) ) then - call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) - else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then - dimValue = tempDim - else if ( dimValue /= tempDim ) then - call mpas_log_write('Dimension ' // trim(poolItr % membername) & - // ' was read with an inconsistent value.', MPAS_LOG_CRIT) + call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) end if - else - call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') - end if - + end do + deallocate(dimNames) end if + end do - ! Close file - call mpas_io_close(inputHandle) - else - call mpas_log_write(' ') - call mpas_log_write(' *** unable to open input file '//trim(streamFilename)//' for stream ''' & - //trim(streamName)//'''') - end if + ! Determine stream filename + call mpas_get_stream_filename(domain % streamManager, streamID = streamName, filename = streamFilename, ierr = err_local) - ! Destroy pool that contains list of streams dimensions - call mpas_pool_destroy_pool(streamDimensions) + ! Determine stream io_type + call MPAS_stream_mgr_get_property(domain % streamManager, streamName, & + MPAS_STREAM_PROPERTY_IOTYPE, ioType, ierr = err_local) - else if ( .not. streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + ! Try to open file + inputHandle = MPAS_io_open(trim(streamFilename), MPAS_IO_READ, ioType, domain % ioContext, ierr = err_local) + + ! If to determine if file was opened or not. + if ( err_local == MPAS_IO_NOERR ) then + + call mpas_log_write(' ') + call mpas_log_write('----- reading dimensions from stream '''//trim(streamName)//''' using file ' & + //trim(streamFilename) ) + + ! Iterate over list of dimensions we determined we need from the above loop + call mpas_pool_begin_iteration(streamDimensions) + do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then + ! Try to read the dimension + call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + + ! Check to see if the dimension has already been defined + call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + + ! If to see if dimension was read or not + if ( err_local == MPAS_IO_NOERR ) then + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) + + if ( .not. associated(dimValue) ) then + call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) + else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then + dimValue = tempDim + else if ( dimValue /= tempDim ) then + call mpas_log_write('Dimension ' // trim(poolItr % membername) & + // ' was read with an inconsistent value.', MPAS_LOG_CRIT) + end if + else + call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') + call mpas_log_write('') + call mpas_log_write("At least one fields to be read from the '" // trim(streamName) & + // "' stream is dimensioned", messageType=MPAS_LOG_ERR) + call mpas_log_write("by '" // trim(poolItr % memberName) // "', but the '" & + // trim(poolItr % memberName) // "' dimension is not defined", & + messageType=MPAS_LOG_ERR) + call mpas_log_write('in the file '//trim(streamFilename), messageType=MPAS_LOG_ERR) + call mpas_log_write("Please check the input file(s) to be read by the '" // trim(streamName) & + // "' input stream.", messageType=MPAS_LOG_CRIT) + end if - call mpas_log_write(' ') - call mpas_log_write('----- skipping inactive stream '''//trim(streamName)//'''') + end if + end do + + ! Close file + call mpas_io_close(inputHandle) + else + call mpas_log_write(' ') + call mpas_log_write(' *** unable to open input file '//trim(streamFilename)//' for stream ''' & + //trim(streamName)//'''') + end if + + ! Destroy pool that contains list of streams dimensions + call mpas_pool_destroy_pool(streamDimensions) + + else if ( .not. streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + + call mpas_log_write(' ') + call mpas_log_write('----- skipping inactive stream '''//trim(streamName)//'''') - end if + end if - end do + end do - call mpas_log_write(' ') - call mpas_log_write('----- done reading dimensions from input streams -----') - call mpas_log_write(' ') - call mpas_log_write(' ') + call mpas_log_write(' ') + call mpas_log_write('----- done reading dimensions from input streams -----') + call mpas_log_write(' ') + call mpas_log_write(' ') + + end if call mpas_pool_set_error_level(err_level) diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 1eec5d3565..c98cb8102b 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -22,35 +22,72 @@ module mpas_constants use mpas_kind_types - real (kind=RKIND), parameter :: pii = 3.141592653589793 !< Constant: Pi - real (kind=RKIND), parameter :: a = 6371229.0 !< Constant: Spherical Earth radius [m] - real (kind=RKIND), parameter :: omega = 7.29212e-5 !< Constant: Angular rotation rate of the Earth [s-1] - real (kind=RKIND), parameter :: gravity = 9.80616 !< Constant: Acceleration due to gravity [m s-2] - real (kind=RKIND), parameter :: rgas = 287.0 !< Constant: Gas constant for dry air [J kg-1 K-1] - real (kind=RKIND), parameter :: rv = 461.6 !< Constant: Gas constant for water vapor [J kg-1 K-1] - real (kind=RKIND), parameter :: rvord = rv/rgas ! -! real (kind=RKIND), parameter :: cp = 1003.0 !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] - real (kind=RKIND), parameter :: cp = 7.*rgas/2. !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] - real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1] - real (kind=RKIND), parameter :: cvpm = -cv/cp ! - real (kind=RKIND), parameter :: prandtl = 1.0 !< Constant: Prandtl number +#ifdef MPAS_CAM_DYCORE + use physconst, only : pii => pi + use physconst, only : gravity => gravit + use physconst, only : omega + use physconst, only : a => rearth + use physconst, only : cp => cpair + use physconst, only : rgas => rair + use physconst, only : rv => rh2o + real (kind=RKIND) :: rvord = huge(1.0_RKIND) ! Derived in mpas_constants_compute_derived + real (kind=RKIND) :: cv = huge(1.0_RKIND) ! Derived in mpas_constants_compute_derived + real (kind=RKIND) :: cvpm = huge(1.0_RKIND) ! Derived in mpas_constants_compute_derived +#else + real (kind=RKIND), parameter :: pii = 3.141592653589793_RKIND !< Constant: Pi + real (kind=RKIND), parameter :: a = 6371229.0_RKIND !< Constant: Spherical Earth radius [m] + real (kind=RKIND), parameter :: omega = 7.29212e-5_RKIND !< Constant: Angular rotation rate of the Earth [s-1] + real (kind=RKIND), parameter :: gravity = 9.80616_RKIND !< Constant: Acceleration due to gravity [m s-2] + real (kind=RKIND), parameter :: rgas = 287.0_RKIND !< Constant: Gas constant for dry air [J kg-1 K-1] + real (kind=RKIND), parameter :: rv = 461.6_RKIND !< Constant: Gas constant for water vapor [J kg-1 K-1] +! real (kind=RKIND), parameter :: cp = 1003.0_RKIND !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] + real (kind=RKIND), parameter :: cp = 7.0_RKIND*rgas/2.0_RKIND !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] + real (kind=RKIND), parameter :: rvord = rv / rgas ! + real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1] + real (kind=RKIND), parameter :: cvpm = -cv / cp ! +#endif + real (kind=RKIND), parameter :: p0 = 1.0e5_RKIND !< Constant: 100000 Pa + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number contains !*********************************************************************** ! -! routine dummy +! mpas_constants_compute_derived ! -!> \brief MPAS Dummy Routine +!> \brief Computes derived constants !> \author Michael Duda -!> \date 03/27/13 +!> \date 8 May 2020 !> \details -!> This is a dummy routine that doesn't do anything. +!> This routine provides a place where physical constants provided by +!> the mpas_constants module may be computed at runtime. For example, +!> if some constants depend on namelist options or other runtime +!> settings, other constants that derive from them may be computed in +!> this routine. +!> +!> At present, the MPAS infrastructure does not call this routine, and +!> it is the responsibility of any MPAS core that needs to compute +!> derived constants at runtime to add calls to this routine, e.g., in +!> its core_init routine. ! !----------------------------------------------------------------------- - subroutine dummy() + subroutine mpas_constants_compute_derived() + + implicit none + +#ifdef MPAS_CAM_DYCORE + ! + ! In the case of CAM-MPAS, rgas may depend on a CAM namelist option, + ! so physical constants that depend on rgas must be computed here after + ! CAM has called the physconst_readnl routine. + ! + + rvord = rv / rgas + cv = cp - rgas + cvpm = -cv / cp +#endif - end subroutine dummy + end subroutine mpas_constants_compute_derived end module mpas_constants diff --git a/src/framework/mpas_core_types.inc b/src/framework/mpas_core_types.inc index df5ede54ab..282c804ab1 100644 --- a/src/framework/mpas_core_types.inc +++ b/src/framework/mpas_core_types.inc @@ -23,7 +23,7 @@ abstract interface function mpas_setup_packages_function(configs, packages, iocontext) result(iErr) import mpas_pool_type - import mpas_io_context_type + import mpas_io_context_type type (mpas_pool_type), intent(inout) :: configs type (mpas_pool_type), intent(inout) :: packages @@ -64,12 +64,13 @@ end interface abstract interface - function mpas_setup_log_function(logInfo, domain) result(iErr) + function mpas_setup_log_function(logInfo, domain, unitNumbers) result(iErr) import mpas_log_type import domain_type type (mpas_log_type), pointer, intent(inout) :: logInfo type (domain_type), pointer, intent(in) :: domain + integer, dimension(2), intent(in), optional :: unitNumbers integer :: iErr end function mpas_setup_log_function end interface @@ -105,15 +106,15 @@ abstract interface function mpas_setup_decomposed_dimensions_function(block, streamManager, readDimensions, dimensionPool, totalBlocks) result(iErr) - import block_type - import mpas_streamManager_type + import block_type + import mpas_streamManager_type import mpas_pool_type - type (block_type), intent(inout) :: block - type (mpas_streamManager_type), intent(inout) :: streamManager + type (block_type), intent(inout) :: block + type (mpas_streamManager_type), intent(inout) :: streamManager type (mpas_pool_type), intent(inout) :: readDimensions type (mpas_pool_type), intent(inout) :: dimensionPool - integer, intent(in) :: totalBlocks + integer, intent(in) :: totalBlocks integer :: iErr end function mpas_setup_decomposed_dimensions_function end interface @@ -151,6 +152,7 @@ character (len=StrKIND) :: modelVersion !< Constant: Version number character (len=StrKIND) :: executableName !< Constant: Name of executable generated at build time. character (len=StrKIND) :: git_version !< Constant: Version string from git-describe. + character (len=StrKIND) :: build_target !< Constant: Build target from top-level Makefile. character (len=StrKIND*2) :: history !< History attribute, read in from input file. character (len=StrKIND) :: Conventions !< Conventions attribute, read in from input file. character (len=StrKIND) :: source !< source attribute, read in from input file. diff --git a/src/framework/mpas_derived_types.F b/src/framework/mpas_derived_types.F index 9404093daa..e9972e771a 100644 --- a/src/framework/mpas_derived_types.F +++ b/src/framework/mpas_derived_types.F @@ -27,16 +27,16 @@ module mpas_derived_types use mpas_kind_types +#ifdef MPAS_PIO_SUPPORT use pio use pio_types +#endif + +#ifdef MPAS_SMIOL_SUPPORT + use smiolf, only : SMIOLf_context, SMIOLf_decomp, SMIOLf_file, SMIOL_offset_kind +#endif use ESMF - use ESMF_BaseMod - use ESMF_Stubs - use ESMF_CalendarMod - use ESMF_ClockMod - use ESMF_TimeMod - use ESMF_TimeIntervalMod #include "mpas_attlist_types.inc" @@ -46,6 +46,8 @@ module mpas_derived_types #include "mpas_field_types.inc" +#include "mpas_halo_types.inc" + #include "mpas_pool_types.inc" #include "mpas_particle_list_types.inc" diff --git a/src/framework/mpas_dmpar.F b/src/framework/mpas_dmpar.F index 490687d095..8e5340e420 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -8463,7 +8463,12 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field1d_integer(exchangeGroup, fiel commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + ! workaround for PGI compiler (CPR): ICE on pointers in private clause of omp-do workshare + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8528,7 +8533,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field2d_integer(exchangeGroup, fiel commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8596,7 +8605,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field3d_integer(exchangeGroup, fiel commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8666,7 +8679,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field1d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8731,7 +8748,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field2d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8798,7 +8819,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field3d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8868,7 +8893,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field4d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, l, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8941,7 +8970,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field5d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, l, m, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem diff --git a/src/framework/mpas_domain_types.inc b/src/framework/mpas_domain_types.inc index 0bea339e52..20eae3a11a 100644 --- a/src/framework/mpas_domain_types.inc +++ b/src/framework/mpas_domain_types.inc @@ -15,6 +15,10 @@ ! Store exchange group information here type (mpas_exchange_group), pointer :: exchangeGroups => null() + ! Storage for halo exchange groups + type (mpas_pool_type), pointer :: haloGroupPool => null() ! Only used internally by mpas_halo module + type (mpas_halo_group), pointer :: haloGroups => null() ! Head pointer of linked list of halo groups + ! Domain specific constants logical :: on_a_sphere = .true. logical :: is_periodic = .false. @@ -26,6 +30,9 @@ character (len=StrKIND) :: mesh_spec = '' !< mesh_spec attribute, read in from input file. character (len=StrKIND) :: parent_id = '' !< parent_id attribute, read in from input file. + ! Unique global ID number for this domain + integer :: domainID + ! Pointer to timer root type (mpas_timer_root), pointer :: timer_root => null() diff --git a/src/framework/mpas_field_accessor.F b/src/framework/mpas_field_accessor.F deleted file mode 100644 index 67aad7f53c..0000000000 --- a/src/framework/mpas_field_accessor.F +++ /dev/null @@ -1,293 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and the University Corporation for Atmospheric Research (UCAR). -! -! Unless noted otherwise source code is licensed under the BSD license. -! Additional copyright and license information can be found in the LICENSE file -! distributed with this code, or at http://mpas-dev.github.com/license.html -! - -#define COMMA , -#define ACCESSOR_ERROR_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_ERR) - -!*********************************************************************** -! -! mpas_field_accessor -! -!> \brief Module providing quick access to members of fields by name -!> \author Michael Duda, Doug Jacobsen -!> \date 28 March 2016 -!> \details -!> This module provides routines for accessing members of field types -!> (e.g., missingValue) given only the name of the field and a pool -!> in which the field may be found. -! -!----------------------------------------------------------------------- -module mpas_field_accessor - - use mpas_derived_types, only : mpas_pool_type, mpas_pool_field_info_type, & - MPAS_POOL_REAL, MPAS_POOL_INTEGER, MPAS_POOL_CHARACTER, MPAS_POOL_LOGICAL, & - field0DReal, field1DReal, field2DReal, field3DReal, field4DReal, field5DReal, & - field0DInteger, field1DInteger, field2DInteger, field3DInteger, & - field0DChar, field1DChar, & - field0DLogical, & - MPAS_LOG_ERR - use mpas_kind_types, only : RKIND, StrKIND - use mpas_pool_routines, only : mpas_pool_get_field_info, mpas_pool_get_field - use mpas_log - - interface mpas_field_access_missing_value - module procedure mpas_field_access_msgval_real - module procedure mpas_field_access_msgval_int - module procedure mpas_field_access_msgval_char - module procedure mpas_field_access_msgval_logical - end interface mpas_field_access_missing_value - - - contains - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_real(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - real(kind=RKIND), intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DReal), pointer :: r0 => null() - type (field1DReal), pointer :: r1 => null() - type (field2DReal), pointer :: r2 => null() - type (field3DReal), pointer :: r3 => null() - type (field4DReal), pointer :: r4 => null() - type (field5DReal), pointer :: r5 => null() - - - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_REAL - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_REAL) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not a real-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is a real-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), r0) - missingValue = r0 % missingValue - case (1) - call mpas_pool_get_field(fieldPool, trim(fieldName), r1) - missingValue = r1 % missingValue - case (2) - call mpas_pool_get_field(fieldPool, trim(fieldName), r2) - missingValue = r2 % missingValue - case (3) - call mpas_pool_get_field(fieldPool, trim(fieldName), r3) - missingValue = r3 % missingValue - case (4) - call mpas_pool_get_field(fieldPool, trim(fieldName), r4) - missingValue = r4 % missingValue - case (5) - call mpas_pool_get_field(fieldPool, trim(fieldName), r5) - missingValue = r5 % missingValue - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (6-d or more) in mpas_field_access_msgval_real') - end select - - end subroutine mpas_field_access_msgval_real - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_int(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - integer, intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DInteger), pointer :: i0 => null() - type (field1DInteger), pointer :: i1 => null() - type (field2DInteger), pointer :: i2 => null() - type (field3DInteger), pointer :: i3 => null() - - - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_INTEGER - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_INTEGER) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not an integer-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is an integer-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), i0) - missingValue = i0 % missingValue - case (1) - call mpas_pool_get_field(fieldPool, trim(fieldName), i1) - missingValue = i1 % missingValue - case (2) - call mpas_pool_get_field(fieldPool, trim(fieldName), i2) - missingValue = i2 % missingValue - case (3) - call mpas_pool_get_field(fieldPool, trim(fieldName), i3) - missingValue = i3 % missingValue - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (4-d or more) in mpas_field_access_msgval_int') - end select - - end subroutine mpas_field_access_msgval_int - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_char(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - character(len=*), intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DChar), pointer :: c0 => null() - type (field1DChar), pointer :: c1 => null() - - - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_CHARACTER - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_CHARACTER) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not a char-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is a character-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), c0) - if (len(missingValue) < len_trim(c0 % missingValue)) then - ACCESSOR_ERROR_WRITE('Truncating missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Actual argument for missingValue is too short') - missingValue = c0 % missingValue(1:len(missingValue)) - else - missingValue = trim(c0 % missingValue) - end if - case (1) - call mpas_pool_get_field(fieldPool, trim(fieldName), c1) - if (len(missingValue) < len_trim(c1 % missingValue)) then - ACCESSOR_ERROR_WRITE('Truncating missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Actual argument for missingValue is too short') - missingValue = c1 % missingValue(1:len(missingValue)) - else - missingValue = trim(c1 % missingValue) - end if - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (2-d or more) in mpas_field_access_msgval_char') - end select - - end subroutine mpas_field_access_msgval_char - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_logical(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - logical, intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DLogical), pointer :: l0 => null() - - -#ifdef POOL_LOGICAL_FIELD_SUPPORT - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_LOGICAL - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_LOGICAL) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not a logical-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is a logical-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), l0) - missingValue = l0 % missingValue - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (1-d or more) in mpas_field_access_msgval_logical') - end select -#else - ACCESSOR_ERROR_WRITE('Support for accessing missingValue for logical fields is not implemented') -#endif - - end subroutine mpas_field_access_msgval_logical - - -end module mpas_field_accessor diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index a5f6960749..0ae6e169e8 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -108,6 +108,22 @@ module mpas_field_routines module procedure mpas_deallocate_field1d_char end interface + interface mpas_deallocate_field_target + module procedure mpas_deallocate_field0d_logical_target + module procedure mpas_deallocate_field0d_integer_target + module procedure mpas_deallocate_field1d_integer_target + module procedure mpas_deallocate_field2d_integer_target + module procedure mpas_deallocate_field3d_integer_target + module procedure mpas_deallocate_field0d_real_target + module procedure mpas_deallocate_field1d_real_target + module procedure mpas_deallocate_field2d_real_target + module procedure mpas_deallocate_field3d_real_target + module procedure mpas_deallocate_field4d_real_target + module procedure mpas_deallocate_field5d_real_target + module procedure mpas_deallocate_field0d_char_target + module procedure mpas_deallocate_field1d_char_target + end interface + contains !*********************************************************************** @@ -1388,43 +1404,39 @@ end subroutine mpas_deallocate_scratch_field1d_char!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_logical +! routine mpas_deallocate_field0D_logical ! -!> \brief MPAS 0D logical deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 0D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 0D logical field. +!> This routine deallocates a 0-d logical field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field0d_logical(f)!{{{ + + implicit none + type (field0dLogical), pointer :: f !< Input: Field to deallocate - type (field0dLogical), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() - - if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field0dLogical), pointer :: f_cursor, f_next - deallocate(f_cursor) - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_logical!}}} @@ -1432,43 +1444,39 @@ end subroutine mpas_deallocate_field0d_logical!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_integer +! routine mpas_deallocate_field0D_integer ! -!> \brief MPAS 0D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 0D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 0D integer field. +!> This routine deallocates a 0-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field0d_integer(f)!{{{ + + implicit none + type (field0dInteger), pointer :: f !< Input: Field to deallocate - type (field0dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() - - if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field0dInteger), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_integer!}}} @@ -1478,45 +1486,37 @@ end subroutine mpas_deallocate_field0d_integer!}}} ! ! routine mpas_deallocate_field1D_integer ! -!> \brief MPAS 1D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 1D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 1D integer field. +!> This routine deallocates a 1-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field1d_integer(f)!{{{ + + implicit none + type (field1dInteger), pointer :: f !< Input: Field to deallocate - type (field1dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + type (field1dInteger), pointer :: f_cursor, f_next - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_integer!}}} @@ -1526,45 +1526,37 @@ end subroutine mpas_deallocate_field1d_integer!}}} ! ! routine mpas_deallocate_field2D_integer ! -!> \brief MPAS 2D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 2D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 2D integer field. +!> This routine deallocates a 2-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field2d_integer(f)!{{{ + + implicit none + type (field2dInteger), pointer :: f !< Input: Field to deallocate - type (field2dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + type (field2dInteger), pointer :: f_cursor, f_next - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field2d_integer!}}} @@ -1574,45 +1566,37 @@ end subroutine mpas_deallocate_field2d_integer!}}} ! ! routine mpas_deallocate_field3D_integer ! -!> \brief MPAS 3D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 3D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 3D integer field. +!> This routine deallocates a 3-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field3d_integer(f)!{{{ + + implicit none + type (field3dInteger), pointer :: f !< Input: Field to deallocate - type (field3dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + type (field3dInteger), pointer :: f_cursor, f_next - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field3d_integer!}}} @@ -1620,44 +1604,39 @@ end subroutine mpas_deallocate_field3d_integer!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_real +! routine mpas_deallocate_field0D_real ! !> \brief MPAS 0D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 0D real field. +!> This routine deallocates a 0-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field0d_real(f)!{{{ - type (field0dReal), pointer :: f !< Input: Field to deallocate - type (field0dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - f_cursor => f + type (field0dReal), pointer :: f !< Input: Field to deallocate - if ( threadNum == 0 ) then - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field0dReal), pointer :: f_cursor, f_next - deallocate(f_cursor) - - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_real!}}} @@ -1668,44 +1647,36 @@ end subroutine mpas_deallocate_field0d_real!}}} ! routine mpas_deallocate_field1D_real ! !> \brief MPAS 1D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 1D real field. +!> This routine deallocates a 1-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field1d_real(f)!{{{ - type (field1dReal), pointer :: f !< Input: Field to deallocate - type (field1dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field1dReal), pointer :: f !< Input: Field to deallocate + + type (field1dReal), pointer :: f_cursor, f_next - deallocate(f_cursor) + call mpas_deallocate_field_target(f) - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_real!}}} @@ -1716,44 +1687,36 @@ end subroutine mpas_deallocate_field1d_real!}}} ! routine mpas_deallocate_field2D_real ! !> \brief MPAS 2D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 2D real field. +!> This routine deallocates a 2-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field2d_real(f)!{{{ - type (field2dReal), pointer :: f !< Input: Field to deallocate - type (field2dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field2dReal), pointer :: f !< Input: Field to deallocate - deallocate(f_cursor) + type (field2dReal), pointer :: f_cursor, f_next - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field2d_real!}}} @@ -1764,44 +1727,36 @@ end subroutine mpas_deallocate_field2d_real!}}} ! routine mpas_deallocate_field3D_real ! !> \brief MPAS 3D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 3D real field. +!> This routine deallocates a 3-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field3d_real(f)!{{{ - type (field3dReal), pointer :: f !< Input: Field to deallocate - type (field3dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field3dReal), pointer :: f !< Input: Field to deallocate + + type (field3dReal), pointer :: f_cursor, f_next - deallocate(f_cursor) + call mpas_deallocate_field_target(f) - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field3d_real!}}} @@ -1812,44 +1767,36 @@ end subroutine mpas_deallocate_field3d_real!}}} ! routine mpas_deallocate_field4D_real ! !> \brief MPAS 4D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 4D real field. +!> This routine deallocates a 4-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field4d_real(f)!{{{ - type (field4dReal), pointer :: f !< Input: Field to deallocate - type (field4dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field4dReal), pointer :: f !< Input: Field to deallocate - deallocate(f_cursor) + type (field4dReal), pointer :: f_cursor, f_next - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field4d_real!}}} @@ -1860,139 +1807,753 @@ end subroutine mpas_deallocate_field4d_real!}}} ! routine mpas_deallocate_field5D_real ! !> \brief MPAS 5D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 5D real field. +!> This routine deallocates a 5-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field5d_real(f)!{{{ + + implicit none + type (field5dReal), pointer :: f !< Input: Field to deallocate - type (field5dReal), pointer :: f_cursor + + type (field5dReal), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field5d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_char +! +!> \brief MPAS 0D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 0-d character field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_char(f)!{{{ + + implicit none + + type (field0dChar), pointer :: f !< Input: Field to deallocate + + type (field0dChar), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field0d_char!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_char +! +!> \brief MPAS 1D char deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 1-d character field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_char(f)!{{{ + + implicit none + + type (field1dChar), pointer :: f !< Input: Field to deallocate + + type (field1dChar), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field1d_char!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_logical_target +! +!> \brief MPAS 0D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D logical field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_logical_target(f)!{{{ + + implicit none + + type (field0dLogical), target :: f !< Input: Field to deallocate + + type (field0dLogical), pointer :: f_cursor, f_next integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if - deallocate(f_cursor) + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if - end subroutine mpas_deallocate_field5d_real!}}} + end subroutine mpas_deallocate_field0d_logical_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0D_char +! routine mpas_deallocate_field0D_integer_target ! -!> \brief MPAS 0D character deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 0D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D character field. +!> This routine deallocates a 0D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_char(f)!{{{ - type (field0dChar), pointer :: f !< Input: Field to deallocate - type (field0dChar), pointer :: f_cursor + subroutine mpas_deallocate_field0d_integer_target(f)!{{{ + + implicit none + + type (field0dInteger), target :: f !< Input: Field to deallocate + + type (field0dInteger), pointer :: f_cursor, f_next integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - deallocate(f_cursor) - f_cursor => f - end do + f_cursor => f_next + end do end if - end subroutine mpas_deallocate_field0d_char!}}} + end subroutine mpas_deallocate_field0d_integer_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field1D_char +! routine mpas_deallocate_field1D_integer_target ! -!> \brief MPAS 1D character deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 1D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D character field. +!> This routine deallocates a 1D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_char(f)!{{{ - type (field1dChar), pointer :: f !< Input: Field to deallocate - type (field1dChar), pointer :: f_cursor + subroutine mpas_deallocate_field1d_integer_target(f)!{{{ + + implicit none + + type (field1dInteger), target :: f !< Input: Field to deallocate + + type (field1dInteger), pointer :: f_cursor, f_next integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if - deallocate(f_cursor) + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if - end subroutine mpas_deallocate_field1d_char!}}} + end subroutine mpas_deallocate_field1d_integer_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field2D_integer_target +! +!> \brief MPAS 2D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 2D int field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field2d_integer_target(f)!{{{ + + implicit none + + type (field2dInteger), target :: f !< Input: Field to deallocate + + type (field2dInteger), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field2d_integer_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field3D_integer_target +! +!> \brief MPAS 3D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 3D int field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field3d_integer_target(f)!{{{ + + implicit none + + type (field3dInteger), target :: f !< Input: Field to deallocate + + type (field3dInteger), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field3d_integer_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_real_target +! +!> \brief MPAS 0D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_real_target(f)!{{{ + + implicit none + + type (field0dReal), target :: f !< Input: Field to deallocate + + type (field0dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field0d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_real_target +! +!> \brief MPAS 1D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 1D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_real_target(f)!{{{ + + implicit none + + type (field1dReal), target :: f !< Input: Field to deallocate + + type (field1dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field1d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field2D_real_target +! +!> \brief MPAS 2D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 2D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field2d_real_target(f)!{{{ + + implicit none + + type (field2dReal), target :: f !< Input: Field to deallocate + + type (field2dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field2d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field3D_real_target +! +!> \brief MPAS 3D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 3D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field3d_real_target(f)!{{{ + + implicit none + + type (field3dReal), target :: f !< Input: Field to deallocate + + type (field3dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field3d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field4D_real_target +! +!> \brief MPAS 4D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 4D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field4d_real_target(f)!{{{ + + implicit none + + type (field4dReal), target :: f !< Input: Field to deallocate + + type (field4dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field4d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field5D_real_target +! +!> \brief MPAS 5D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 5D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field5d_real_target(f)!{{{ + + implicit none + + type (field5dReal), target :: f !< Input: Field to deallocate + + type (field5dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field5d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_char_target +! +!> \brief MPAS 0D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_char_target(f)!{{{ + + implicit none + + type (field0dChar), target :: f !< Input: Field to deallocate + + type (field0dChar), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field0d_char_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_char_target +! +!> \brief MPAS 1D char deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 1D char field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_char_target(f)!{{{ + + implicit none + + type (field1dChar), target :: f !< Input: Field to deallocate + + type (field1dChar), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field1d_char_target!}}} !*********************************************************************** diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 974e0935ca..d31576c712 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -67,11 +67,18 @@ end subroutine mpas_framework_init_phase1!}}} !----------------------------------------------------------------------- subroutine mpas_framework_init_phase2(domain, io_system, calendar)!{{{ + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + implicit none type (domain_type), pointer :: domain +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), optional, pointer :: io_system +#else + integer, optional, pointer :: io_system +#endif character(len=*), intent(in), optional :: calendar character(len=StrKIND), pointer :: config_calendar_type @@ -85,22 +92,51 @@ subroutine mpas_framework_init_phase2(domain, io_system, calendar)!{{{ call mpas_pool_set_error_level(MPAS_POOL_WARN) #endif - call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) - call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) - call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) - if (present(calendar)) then call mpas_timekeeping_init(calendar) else + call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) call mpas_timekeeping_init(config_calendar_type) end if - pio_num_iotasks = config_pio_num_iotasks - pio_stride = config_pio_stride - if (pio_num_iotasks == 0) then - pio_num_iotasks = domain % dminfo % nprocs + ! + ! Note: pio_num_iotasks and pio_stride are only used in MPAS_io_init if io_system is + ! not present. In stand-alone configurations, we expect that io_system will not + ! be present and that pio_num_iotasks and pio_stride will be available from + ! the namelist; in other systems, a PIO io_system may be provided. + ! + if (.not. present(io_system)) then + call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) + call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) + pio_num_iotasks = config_pio_num_iotasks + pio_stride = config_pio_stride + + ! + ! If at most one of config_pio_num_iotasks and config_io_stride are zero, compute + ! a sensible value for the zero-valued option + ! + if (pio_num_iotasks == 0 .and. pio_stride == 0) then + call mpas_log_write('Namelist options config_pio_num_iotasks and config_pio_stride cannot both be zero.', & + messageType=MPAS_LOG_CRIT) + else if (pio_num_iotasks == 0) then + pio_num_iotasks = domain % dminfo % nprocs / pio_stride + else if (pio_stride == 0) then + pio_stride = domain % dminfo % nprocs / pio_num_iotasks + end if + + call mpas_log_write('') + call mpas_log_write('----- I/O task configuration: -----') + call mpas_log_write('') + call mpas_log_write(' I/O task count = $i', intArgs=[pio_num_iotasks]) + call mpas_log_write(' I/O task stride = $i', intArgs=[pio_stride]) + call mpas_log_write('') + else + pio_num_iotasks = -1 ! Not used when external io_system is provided + pio_stride = -1 ! Not used when external io_system is provided end if + domain % ioContext % dminfo => domain % dminfo + call MPAS_io_init(domain % ioContext, pio_num_iotasks, pio_stride, io_system) end subroutine mpas_framework_init_phase2!}}} @@ -122,7 +158,11 @@ subroutine mpas_framework_finalize(dminfo, domain, io_system)!{{{ type (dm_info), pointer :: dminfo type (domain_type), pointer :: domain +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), optional, pointer :: io_system +#else + integer, optional, pointer :: io_system +#endif call MPAS_io_finalize(domain % ioContext, .false.) diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F new file mode 100644 index 0000000000..401ab2c40f --- /dev/null +++ b/src/framework/mpas_halo.F @@ -0,0 +1,1647 @@ +#define CONTIGUOUS contiguous, + +! Copyright (c) 2021-2023 The University Corporation for Atmospheric Research (UCAR). +! +! Unless noted otherwise source code is licensed under the BSD license. +! Additional copyright and license information can be found in the LICENSE file +! distributed with this code, or at https://mpas-dev.github.io/license.html . +! +!----------------------------------------------------------------------- +! mpas_halo +! +!> \brief Communication of halos for groups of fields +!> \author Michael Duda +!> \date 29 September 2021 +!> \details +!> This module provides routines for defining groups of fields, and for +!> communicating the halos of all fields in a group. +! +!----------------------------------------------------------------------- +module mpas_halo + + implicit none + + private + + public :: mpas_halo_init, & + mpas_halo_finalize, & + mpas_halo_exch_group_create, & + mpas_halo_exch_group_complete, & + mpas_halo_exch_group_destroy, & + mpas_halo_exch_group_add_field, & + mpas_halo_exch_group_full_halo_exch + + + contains + + + !----------------------------------------------------------------------- + ! routine mpas_halo_init + ! + !> \brief Initialize halo exchange module + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine initialize the halo exchange module and must be + !> called before any other routine for building or exchanging halos. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_init(domain, iErr) + + use mpas_derived_types, only : domain_type + use mpas_pool_routines, only : mpas_pool_create_pool + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, optional, intent(out) :: iErr + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_create_pool(domain % haloGroupPool) + + end subroutine mpas_halo_init + + + !----------------------------------------------------------------------- + ! routine mpas_halo_finalize + ! + !> \brief Finalize halo exchange module + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine finalize the halo exchange module and must be + !> called after all other calls for building or exchanging halos. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_finalize(domain, iErr) + + use mpas_derived_types, only : domain_type + use mpas_pool_routines, only : mpas_pool_destroy_pool + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, optional, intent(out) :: iErr + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_destroy_pool(domain % haloGroupPool) + + end subroutine mpas_halo_finalize + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_create + ! + !> \brief Create a new group, to which fields can be later added + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine creates a new group, into which fields can be added by + !> subsequent calls to mpas_halo_exch_group_add_field. After one or more + !> fields have been added to a group created by this routine, a call to + !> mpas_halo_exch_group_complete must be made before the halos of fields + !> in the group can be exchanged with a call to + !> mpas_halo_exch_group_full_halo_exch. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_create(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_pool_type + use mpas_pool_routines, only : mpas_pool_create_pool, mpas_pool_add_subpool + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + type (mpas_pool_type), pointer :: newGroup + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_create_pool(newGroup) + call mpas_pool_add_subpool(domain % haloGroupPool, groupName, newGroup) + + end subroutine mpas_halo_exch_group_create + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_complete + ! + !> \brief Complete the creation of an exchange group + !> \author Michael Duda + !> \date 29 September 2021 + !> \details + !> Complete the creation of an exchange group that was defined via a call + !> to the mpas_halo_exch_group_create routine, and to which fields were + !> added through calls to mpas_halo_exch_group_add_field. This routine + !> must be called for an exchange group before the group can be used in + !> calls to the mpas_halo_exch_group_full_halo_exch routine. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_complete(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_pool_type, mpas_pool_iterator_type, MPAS_POOL_CONFIG, & + MPAS_POOL_REAL, MPAS_HALO_REAL, mpas_halo_group, MPAS_LOG_CRIT, & + field2DReal, field3DReal + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_remove_subpool, mpas_pool_destroy_pool, & + mpas_pool_begin_iteration, mpas_pool_get_next_member, mpas_pool_get_dimension, & + mpas_pool_remove_field, mpas_pool_get_field + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i + type (mpas_pool_type), pointer :: completedGroup + type (mpas_pool_iterator_type) :: itr + integer, dimension(:), pointer :: fieldHaloInfo + integer, dimension(:), pointer :: haloLayers + type (mpas_halo_group), pointer :: newGroup + type (field2DReal), pointer :: r2d + type (field3DReal), pointer :: r3d + integer, pointer :: timeLevel + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_get_subpool(domain % haloGroupPool, groupName, completedGroup) + + ! + ! Add new mpas_halo_group to list of haloGroups in domain + ! + allocate(newGroup) + newGroup % groupName = groupName + newGroup % next => domain % haloGroups + domain % haloGroups => newGroup + + ! + ! Figure out how many fields are in this group + ! + newGroup % nFields = 0 + call mpas_pool_begin_iteration(completedGroup) + do while (mpas_pool_get_next_member(completedGroup, itr)) + if (itr % memberType == MPAS_POOL_CONFIG) then + newGroup % nFields = newGroup % nFields + 1 + end if + end do + + allocate(newGroup % fields(newGroup % nFields)) + + ! + ! Fill in field entries for this group + ! + i = 1 + call mpas_pool_begin_iteration(completedGroup) + do while (mpas_pool_get_next_member(completedGroup, itr)) + if (itr % memberType == MPAS_POOL_CONFIG) then + newGroup % fields(i) % fieldName = trim(itr % memberName) + + call mpas_pool_get_dimension(completedGroup, trim(itr % memberName)//'.info', fieldHaloInfo) + + call mpas_pool_get_dimension(completedGroup, trim(itr % memberName)//'.timelevel', timeLevel) + + call mpas_pool_get_dimension(completedGroup, trim(itr % memberName)//'.layers', haloLayers) + + newGroup % fields(i) % nDims = fieldHaloInfo(2) + newGroup % fields(i) % timeLevel = timeLevel + + select case (fieldHaloInfo(1)) + case (MPAS_POOL_REAL) + newGroup % fields(i) % fieldType = MPAS_HALO_REAL + case default + call mpas_log_write('Only real-valued fields are supported in mpas_halo_exch_group_complete', & + messageType=MPAS_LOG_CRIT) + end select + + if (fieldHaloInfo(1) == MPAS_POOL_REAL) then + if (fieldHaloInfo(2) == 2) then + call mpas_pool_get_field(completedGroup, trim(itr % memberName)//'.field', r2d) + call mpas_halo_compact_halo_info(domain, r2d % sendList, r2d % recvList, r2d % dimSizes, & + haloLayers, & + newGroup % fields(i) % compactHaloInfo, & + newGroup % fields(i) % compactSendLists, & + newGroup % fields(i) % compactRecvLists) + else if (fieldHaloInfo(2) == 3) then + call mpas_pool_get_field(completedGroup, trim(itr % memberName)//'.field', r3d) + call mpas_halo_compact_halo_info(domain, r3d % sendList, r3d % recvList, r3d % dimSizes, & + haloLayers, & + newGroup % fields(i) % compactHaloInfo, & + newGroup % fields(i) % compactSendLists, & + newGroup % fields(i) % compactRecvLists) + else + call mpas_log_write('Unsupported dimensionality for real field in mpas_halo_exch_group_complete.', & + messageType=MPAS_LOG_CRIT) + end if + else + call mpas_log_write('Unsupported field type in mpas_halo_exch_group_complete.', & + messageType=MPAS_LOG_CRIT) + end if + + call mpas_pool_remove_field(completedGroup, trim(itr % memberName)//'.field') + i = i + 1 + end if + end do + + call mpas_halo_aggregate_group_info(newGroup) + + ! + ! Pre-allocate buffers and MPI request lists + ! + allocate(newGroup % sendBuf(newGroup % groupSendBufSize)) + allocate(newGroup % recvBuf(newGroup % groupRecvBufSize)) + allocate(newGroup % sendRequests(newGroup % nGroupSendNeighbors)) + allocate(newGroup % recvRequests(newGroup % nGroupRecvNeighbors)) + + call mpas_pool_destroy_pool(completedGroup) + call mpas_pool_remove_subpool(domain % haloGroupPool, groupName) + + call refactor_lists(domain, groupName, iErr) + + end subroutine mpas_halo_exch_group_complete + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_destroy + ! + !> \brief Destroys a halo exchange group + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine frees memory associated with the named group, which must + !> have been previously created with calls to mpas_halo_exch_group_create + !> and mpas_halo_exch_group_complete. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_destroy(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_halo_group, MPAS_LOG_CRIT + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i + type (mpas_halo_group), pointer :: cursor, prev + + + if (present(iErr)) then + iErr = 0 + end if + + ! + ! Find this halo exhange group in the list of groups + ! + nullify(prev) + cursor => domain % haloGroups + do while (associated(cursor)) + if (trim(cursor % groupName) == trim(groupName)) then + exit + end if + + prev => cursor + cursor => cursor % next + end do + + if (.not. associated(cursor)) then + call mpas_log_write('Halo exchange group '//trim(groupName)//' not found in destroy routine.', & + messageType=MPAS_LOG_CRIT) + end if + + ! + ! Unlink this exchange group + ! + if (.not. associated(prev)) then + domain % haloGroups => cursor % next + else + prev % next => cursor % next + end if + + ! + ! Deallocate this exchange group + ! + do i = 1, cursor % nFields + deallocate(cursor % fields(i) % compactHaloInfo) + deallocate(cursor % fields(i) % compactSendLists) + deallocate(cursor % fields(i) % compactRecvLists) + deallocate(cursor % fields(i) % nSendLists) + deallocate(cursor % fields(i) % sendListSrc) + deallocate(cursor % fields(i) % sendListDst) + deallocate(cursor % fields(i) % packOffsets) + deallocate(cursor % fields(i) % nRecvLists) + deallocate(cursor % fields(i) % recvListSrc) + deallocate(cursor % fields(i) % recvListDst) + deallocate(cursor % fields(i) % unpackOffsets) + end do + deallocate(cursor % fields) + deallocate(cursor % groupPackOffsets) + deallocate(cursor % groupSendNeighbors) + deallocate(cursor % groupSendOffsets) + deallocate(cursor % groupSendCounts) + deallocate(cursor % groupUnpackOffsets) + deallocate(cursor % groupRecvNeighbors) + deallocate(cursor % groupToFieldRecvIdx) + deallocate(cursor % groupRecvOffsets) + deallocate(cursor % groupRecvCounts) + deallocate(cursor % sendBuf) + deallocate(cursor % recvBuf) + deallocate(cursor % sendRequests) + deallocate(cursor % recvRequests) + deallocate(cursor) + + end subroutine mpas_halo_exch_group_destroy + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_add_field + ! + !> \brief Add a field to a halo exchange group + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine adds the field named fieldName to the exchange group named + !> groupName. The timeLevel argument provides control over which time level + !> will be exchanged for the field. If the timeLevel argument is omitted, + !> time level 1 of the field will be exchanged. The haloLayers argument + !> specifies which halo layers will be exchanged for the field; if haloLayers + !> is not specified, all halo layers will be exchanged. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_add_field(domain, groupName, fieldName, timeLevel, haloLayers, iErr) + + use mpas_derived_types, only : domain_type, mpas_pool_type, mpas_pool_field_info_type, MPAS_POOL_REAL, & + field2DReal, field3DReal, MPAS_LOG_CRIT + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_add_config, mpas_pool_get_field_info, & + mpas_pool_add_dimension, mpas_pool_get_field, mpas_pool_add_field + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + character (len=*), intent(in) :: fieldName + integer, optional, intent(in) :: timeLevel + integer, dimension(:), optional, intent(in) :: haloLayers + integer, optional, intent(out) :: iErr + + ! Local variables + type (mpas_pool_type), pointer :: group + type (mpas_pool_field_info_type) :: info + integer, allocatable, dimension(:) :: fieldHaloInfo + integer :: local_timeLevel + type (field2DReal), pointer :: r2d + type (field3DReal), pointer :: r3d + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_get_subpool(domain % haloGroupPool, groupName, group) + + ! + ! Store an item in the pool to signal the field whose halo is to be exchanged + ! + call mpas_pool_add_config(group, fieldName, 1) + + call mpas_pool_get_field_info(domain % blocklist % allFields, fieldName, info) + + ! + ! Store an item in the pool with basic info about this field + ! + allocate(fieldHaloInfo(4)) + fieldHaloInfo(1) = info % fieldType + fieldHaloInfo(2) = info % nDims + fieldHaloInfo(3) = info % nTimeLevels + fieldHaloInfo(4) = info % nHaloLayers + call mpas_pool_add_dimension(group, fieldName//'.info', fieldHaloInfo) + deallocate(fieldHaloInfo) + + ! + ! Store an item in the pool with list of halo layers to exchange, or (/-1/) if all layers + ! + if (present(haloLayers)) then + call mpas_pool_add_dimension(group, fieldName//'.layers', haloLayers) + else + call mpas_pool_add_dimension(group, fieldName//'.layers', (/ -1 /)) + end if + + ! + ! Store an item in the pool indicating which time level to exchange + ! + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + call mpas_pool_add_dimension(group, fieldName//'.timelevel', local_timeLevel) + + ! + ! Store a reference to the field itself in the pool + ! + if (info % fieldType == MPAS_POOL_REAL) then + if (info % nDims == 2) then + call mpas_pool_get_field(domain % blocklist % allFields, fieldName, r2d, timeLevel=local_timeLevel) + call mpas_pool_add_field(group, fieldName//'.field', r2d) + else if (info % nDims == 3) then + call mpas_pool_get_field(domain % blocklist % allFields, fieldName, r3d, timeLevel=local_timeLevel) + call mpas_pool_add_field(group, fieldName//'.field', r3d) + else + call mpas_log_write('Unsupported dimensionality for real field '//trim(fieldName), messageType=MPAS_LOG_CRIT) + end if + else + call mpas_log_write('Unsupported field type for field '//trim(fieldName), messageType=MPAS_LOG_CRIT) + end if + + end subroutine mpas_halo_exch_group_add_field + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_full_halo_exch + ! + !> \brief Communicate halos for all fields in a group + !> \author Michael Duda + !> \date 15 August 2022 + !> \details + !> This routine exchanges the halos for all fields in the named halo + !> exchange group. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) + + use mpi + use mpas_derived_types, only : domain_type, mpas_halo_group, MPAS_HALO_REAL, MPAS_LOG_CRIT + use mpas_pool_routines, only : mpas_pool_get_array + use mpas_log, only : mpas_log_write + + ! Parameters +#ifdef SINGLE_PRECISION + integer, parameter :: MPI_REALKIND = MPI_REAL +#else + integer, parameter :: MPI_REALKIND = MPI_DOUBLE_PRECISION +#endif + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i, bufstart, bufend + integer :: dim1, dim2 + integer :: i1, i2, j, iNeighbor, iReq + integer :: iHalo, iEndp + integer :: nHalos, nSendEndpts, nRecvEndpts + integer :: rank, comm + integer :: mpi_ierr + type (mpas_halo_group), pointer :: group + integer, dimension(:), pointer :: compactHaloInfo + integer, dimension(:), pointer :: compactSendLists + integer, dimension(:), pointer :: compactRecvLists + integer, dimension(:,:), CONTIGUOUS pointer :: nSendLists + integer :: maxNSendList + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListSrc, sendListDst + integer, dimension(:), CONTIGUOUS pointer :: packOffsets + integer, dimension(:,:), CONTIGUOUS pointer :: nRecvLists + integer :: maxNRecvList + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListSrc, recvListDst + integer, dimension(:), CONTIGUOUS pointer :: unpackOffsets + + + if (present(iErr)) then + iErr = 0 + end if + + ! + ! Find this halo exhange group in the list of groups + ! + group => domain % haloGroups + do while (associated(group)) + if (trim(group % groupName) == trim(groupName)) then + exit + end if + + group => group % next + end do + + if (.not. associated(group)) then + call mpas_log_write('Halo exchange group '//trim(groupName)//' not found in full_exch routine.', & + messageType=MPAS_LOG_CRIT) + end if + + ! + ! Get the rank of this task and the MPI communicator to use from the first field in + ! the group; all fields should be using the same communicator, so this should not + ! be problematic + ! + comm = group % fields(1) % compactHaloInfo(7) + rank = group % fields(1) % compactHaloInfo(8) + + + ! + ! Initiate non-blocking MPI receives for all neighbors + ! + do i = 1, group % nGroupRecvNeighbors + if (group % groupRecvCounts(i) > 0) then + bufstart = group % groupRecvOffsets(i) + bufend = group % groupRecvOffsets(i) + group % groupRecvCounts(i) - 1 +!TO DO: how do we determine appropriate type here? + call MPI_Irecv(group % recvBuf(bufstart:bufend), group % groupRecvCounts(i), MPI_REALKIND, & + group % groupRecvNeighbors(i), group % groupRecvNeighbors(i), comm, & + group % recvRequests(i), mpi_ierr) + else + group % recvRequests(i) = MPI_REQUEST_NULL + end if + end do + + ! + ! Pack the segmented send buffer with elements from all fields and for all neighbors + ! + do i = 1, group % nFields + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactSendLists => group % fields(i) % compactSendLists + + ! + ! Packing code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + dim1 = compactHaloInfo(2) + dim2 = compactHaloInfo(3) + + nHalos = compactHaloInfo(9) + nSendEndpts = compactHaloInfo(10) + + sendListSrc => group % fields(i) % sendListSrc + sendListDst => group % fields(i) % sendListDst + nSendLists => group % fields(i) % nSendLists + packOffsets => group % fields(i) % packOffsets + maxNSendList = group % fields(i) % maxNSendList + + select case (group % fields(i) % nDims) + + ! + ! Packing code for 2-d real-valued fields + ! + case (2) + call mpas_pool_get_array(domain % blocklist % allFields, trim(group % fields(i) % fieldName), & + group % fields(i) % r2arr, timeLevel=group % fields(i) % timeLevel) + + ! + ! Pack send buffer for all neighbors for current field + ! + do iEndp = 1, nSendEndpts + do iHalo = 1, nHalos + do j = 1, maxNSendList + do i1 = 1, dim1 + if (j <= nSendLists(iHalo,iEndp)) then + group % sendBuf(packOffsets(iEndp) + dim1 * (sendListDst(j,iHalo,iEndp) - 1) + i1) = & + group % fields(i) % r2arr(i1, sendListSrc(j,iHalo,iEndp)) + end if + end do + end do + end do + end do + + ! + ! Packing code for 3-d real-valued fields + ! + case (3) + call mpas_pool_get_array(domain % blocklist % allFields, trim(group % fields(i) % fieldName), & + group % fields(i) % r3arr, group % fields(i) % timeLevel) + + ! + ! Pack send buffer for all neighbors for current field + ! + do iEndp = 1, nSendEndpts + do iHalo = 1, nHalos + do j = 1, maxNSendList + do i2 = 1, dim2 + do i1 = 1, dim1 + if (j <= nSendLists(iHalo,iEndp)) then + group % sendBuf(packOffsets(iEndp) + dim1*dim2*(sendListDst(j,iHalo,iEndp) - 1) & + + dim1*(i2-1) + i1) = & + group % fields(i) % r3arr(i1, i2, sendListSrc(j,iHalo,iEndp)) + end if + end do + end do + end do + end do + end do + + end select + end if + end do + + ! + ! Initiate non-blocking sends to all neighbors + ! + do i = 1, group % nGroupSendNeighbors + if (group % groupSendCounts(i) > 0) then + bufstart = group % groupSendOffsets(i) + bufend = group % groupSendOffsets(i) + group % groupSendCounts(i) - 1 +!TO DO: how do we determine appropriate type here? + call MPI_Isend(group % sendBuf(bufstart:bufend), group % groupSendCounts(i), MPI_REALKIND, & + group % groupSendNeighbors(i), rank, comm, & + group % sendRequests(i), mpi_ierr) + else + group % sendRequests(i) = MPI_REQUEST_NULL + end if + end do + + ! + ! Unpack messages as they are received + ! + do iNeighbor = 1, group % nGroupRecvNeighbors + + call MPI_Waitany(group % nGroupRecvNeighbors, group % recvRequests, iReq, MPI_STATUS_IGNORE, mpi_ierr) + + ! + ! Unpack the segmented recv buffer with elements for all fields and from all neighbors + ! + do i = 1, group % nFields + + ! Find field-local neighbor index corresponding to the neighbor for which we + ! just received a message. If iEndp == 0, then field i does not receive any + ! values from neighbor iReq + iEndp = group % groupToFieldRecvIdx(iReq, i) + + if (iEndp == 0) cycle ! No unpacking needed from this neighbor for this field + + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactRecvLists => group % fields(i) % compactRecvLists + + nHalos = compactHaloInfo(9) + nRecvEndpts = compactHaloInfo(11) + + recvListSrc => group % fields(i) % recvListSrc + recvListDst => group % fields(i) % recvListDst + nRecvLists => group % fields(i) % nRecvLists + unpackOffsets => group % fields(i) % unpackOffsets + maxNRecvList = group % fields(i) % maxNRecvList + + + ! + ! Unpacking code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + dim1 = compactHaloInfo(2) + dim2 = compactHaloInfo(3) + + select case (group % fields(i) % nDims) + + ! + ! Unpacking code for 2-d real-valued fields + ! + case (2) + ! + ! Unpack recv buffer from all neighbors for current field + ! + do iHalo = 1, nHalos + do j = 1, maxNRecvList + do i1 = 1, dim1 + if (j <= nRecvLists(iHalo,iEndp)) then + group % fields(i) % r2arr(i1, recvListDst(j,iHalo,iEndp)) = & + group % recvBuf(unpackOffsets(iEndp) + dim1 * (recvListSrc(j,iHalo,iEndp) - 1) + i1) + end if + end do + end do + end do + + ! + ! Unpacking code for 3-d real-valued fields + ! + case (3) + ! + ! Unpack recv buffer from all neighbors for current field + ! + do iHalo = 1, nHalos + do j = 1, maxNRecvList + do i2 = 1, dim2 + do i1 = 1, dim1 + if (j <= nRecvLists(iHalo,iEndp)) then + group % fields(i) % r3arr(i1, i2, recvListDst(j,iHalo,iEndp)) = & + group % recvBuf(unpackOffsets(iEndp) + dim1*dim2*(recvListSrc(j,iHalo,iEndp) - 1) & + + dim1*(i2-1) + i1) + end if + end do + end do + end do + end do + + end select + end if + end do + end do + + ! + ! Nullify array pointers - not necessary for correctness, but helpful when debugging + ! to not leave pointers to what might later be incorrect targets + ! + do i = 1, group % nFields + if (group % fields(i) % nDims == 2) then + nullify(group % fields(i) % r2arr) + else if (group % fields(i) % nDims == 3) then + nullify(group % fields(i) % r3arr) + end if + end do + + ! + ! Wait for all sends to complete before returning + ! + call MPI_Waitall(group % nGroupSendNeighbors, group % sendRequests, MPI_STATUSES_IGNORE, mpi_ierr) + + end subroutine mpas_halo_exch_group_full_halo_exch + + + !----------------------------------------------------------------------- + ! routine mpas_halo_compact_halo_info + ! + !> \brief Compacts information needed for halo exchanges + !> \author Michael Duda + !> \date 7 December 2017 + !> \details + !> This routine extracts all information needed to perform a halo exchange + !> from dynamic data types and places it into a single, contiguous array + !> for use by the mpas_halo_exch_halo_acc routines. + !> The resulting compactHaloInfo array has the following elements: + !> 1 - The dimensionality of the field + !> 2 - Dimension 1 of the field (i.e., the left-most dimension) + !> 3 - Dimension 2 of the field + !> 4 - Dimension 3 of the field + !> 5 - Dimension 4 of the field + !> 6 - Dimension 5 of the field + !> 7 - The MPI communicator + !> 8 - The MPI rank of the current process + !> 9 - The number of halo layers for the field + !> 10 - The number of endpoints to send to + !> 11 - The number of endpoints to recv from + !> + !> The compactSendLists and compactRecvLists arrays have the following elements: + !> foreach (send endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + !> foreach (recv endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_compact_halo_info(domain, sendList, recvList, dimSizes, haloLayers, & + compactHaloInfo, compactSendLists, compactRecvLists) + + use mpas_derived_types, only : domain_type, mpas_multihalo_exchange_list, mpas_exchange_list, MPAS_LOG_CRIT + use mpas_log, only : mpas_log_write + + implicit none + + ! Arguments + type (domain_type), intent(in) :: domain + type (mpas_multihalo_exchange_list), pointer :: sendList + type (mpas_multihalo_exchange_list), pointer :: recvList + integer, dimension(:), intent(in) :: dimsizes + integer, dimension(:), intent(in) :: haloLayers + integer, dimension(:), pointer :: compactHaloInfo + integer, dimension(:), pointer :: compactSendLists + integer, dimension(:), pointer :: compactRecvLists + + ! Local variables + integer :: i, iendpt, j, ioffset + integer :: idx + integer :: nSendEndpoints + integer :: maxSendEndpoints + integer :: totSendListSize + integer :: nRecvEndpoints + integer :: maxRecvEndpoints + integer :: totRecvListSize + integer :: nHaloLayers + logical :: found + integer, allocatable, dimension(:) :: sendEndpoints + integer, allocatable, dimension(:) :: recvEndpoints + type (mpas_multihalo_exchange_list), pointer :: sendListCursor, recvListCursor + type (mpas_exchange_list), pointer :: exchListPtr + integer :: activeHaloLayers + logical, dimension(:), allocatable :: useHalo + + + ! + ! Find number of halo layers + ! + nHaloLayers = size(sendList % halos) + if (nHaloLayers /= size(recvList % halos)) then + call mpas_log_write('The number of halo layers in the recv list does not match the number in the send list', & + messageType=MPAS_LOG_CRIT) + end if + + ! + ! Create logical array indicating, for each halo layer, whether that halo layer should be + ! used in a halo exchange + ! + allocate(useHalo(nHaloLayers)) + + if (haloLayers(1) == -1) then ! Use all halo layers + useHalo(:) = .true. + activeHaloLayers = nHaloLayers + else + useHalo(:) = .false. + activeHaloLayers = size(haloLayers) + do i = 1, activeHaloLayers + useHalo(haloLayers(i)) = .true. + end do + end if + + ! + ! Find the maximum number of "endpoints" that we will need to send to for any halo layer, + ! as well as the total size of the send lists for all halo layers + ! + maxSendEndpoints = 0 + totSendListSize = 0 + sendListCursor => sendList + do while (associated(sendListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + nSendEndpoints = 0 + exchListPtr => sendListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + nSendEndpoints = nSendEndpoints + 1 + totSendListSize = totSendListSize + 2 * exchListPtr % nList ! We have srcList and destList + exchListPtr => exchListPtr % next + end do + maxSendEndpoints = max(nSendEndpoints, maxSendEndpoints) + end if + end do + sendListCursor => sendListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + allocate(sendEndpoints(maxSendEndpoints * activeHaloLayers)) + + ! + ! Gather a list of the unique endpoints that we will need to send to + ! + nSendEndpoints = 0 + sendListCursor => sendList + do while (associated(sendListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + exchListPtr => sendListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + + ! If the current endpoint is not already in the list, add it + do j=1,nSendEndpoints + if (exchListPtr % endPointID == sendEndpoints(j)) exit + end do + if (j > nSendEndpoints) then + nSendEndpoints = nSendEndpoints + 1 + sendEndpoints(nSendEndpoints) = exchListPtr % endPointID + end if + + exchListPtr => exchListPtr % next + end do + end if + end do + sendListCursor => sendListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + ! + ! Find the maximum number of "endpoints" that we will need to receive from for any halo layer, + ! as well as the total size of the recv lists for all halo layers + ! + maxRecvEndpoints = 0 + totRecvListSize = 0 + recvListCursor => recvList + do while (associated(recvListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + nRecvEndpoints = 0 + exchListPtr => recvListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + nRecvEndpoints = nRecvEndpoints + 1 + totRecvListSize = totRecvListSize + 2 * exchListPtr % nList ! We have srcList and destList + exchListPtr => exchListPtr % next + end do + maxRecvEndpoints = max(nRecvEndpoints, maxRecvEndpoints) + end if + end do + recvListCursor => recvListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + allocate(recvEndpoints(maxRecvEndpoints * activeHaloLayers)) + + ! + ! Gather a list of the unique endpoints that we will need to receive from + ! + nRecvEndpoints = 0 + recvListCursor => recvList + do while (associated(recvListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + exchListPtr => recvListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + + ! If the current endpoint is not already in the list, add it + do j=1,nRecvEndpoints + if (exchListPtr % endPointID == recvEndpoints(j)) exit + end do + if (j > nRecvEndpoints) then + nRecvEndpoints = nRecvEndpoints + 1 + recvEndpoints(nRecvEndpoints) = exchListPtr % endPointID + end if + + exchListPtr => exchListPtr % next + end do + end if + end do + recvListCursor => recvListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + + ! + ! Compute the number of elements we will need in compactHaloInfo + ! + allocate(compactHaloInfo(11)) + allocate(compactSendLists(nSendEndpoints + activeHaloLayers * nSendEndpoints + totSendListSize)) + allocate(compactRecvLists(nRecvEndpoints + activeHaloLayers * nRecvEndpoints + totRecvListSize)) + + compactHaloInfo(:) = 0 + compactSendLists(:) = 0 + compactRecvLists(:) = 0 + + ! + ! 1-6: Add field dimensionality and dimensions + ! + compactHaloInfo(1) = size(dimSizes) ! Dimensionality of the field + idx = 2 + do i=1,compactHaloInfo(1) + compactHaloInfo(idx) = dimSizes(i) + idx = idx + 1 + end do + + ! + ! 7-8: Add MPI info + ! + idx = 7 + compactHaloInfo(idx) = domain % dminfo % comm + idx = idx + 1 + compactHaloInfo(idx) = domain % dminfo % my_proc_id + idx = idx + 1 + + ! + ! 9: Add number of halo layers + ! + compactHaloInfo(idx) = activeHaloLayers + idx = idx + 1 + + ! + ! 10: Add number of send endpoints + ! + compactHaloInfo(idx) = nSendEndpoints + idx = idx + 1 + + ! + ! 11: Add number of receive endpoints + ! + compactHaloInfo(idx) = nRecvEndpoints + idx = idx + 1 + + ! + ! foreach (endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + ! + idx = 1 + do iendpt=1,nSendEndpoints + compactSendLists(idx) = sendEndpoints(iendpt) + idx = idx + 1 + ioffset = 0 + do i=1,nHaloLayers + if (useHalo(i)) then + sendListCursor => sendList + do while (associated(sendListCursor)) + found = .false. + exchListPtr => sendListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + if (exchListPtr % endPointID == sendEndpoints(iendpt)) then + found = .true. + compactSendLists(idx) = exchListPtr % nList + idx = idx + 1 + compactSendLists(idx:idx+exchListPtr % nList-1) = exchListPtr % srcList(1:exchListPtr % nList) + idx = idx + exchListPtr % nList + compactSendLists(idx:idx+exchListPtr % nList-1) = exchListPtr % destList(1:exchListPtr % nList) + & + ioffset + idx = idx + exchListPtr % nList + ioffset = ioffset + exchListPtr % nList + exit + end if + exchListPtr => exchListPtr % next + end do + if (.not. found) then + compactSendLists(idx) = 0 + idx = idx + 1 + end if + sendListCursor => sendListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + end if + end do + end do + + deallocate(sendEndpoints) + + ! + ! foreach (endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + ! + idx = 1 + do iendpt=1,nRecvEndpoints + compactRecvLists(idx) = recvEndpoints(iendpt) + idx = idx + 1 + ioffset = 0 + do i=1,nHaloLayers + if (useHalo(i)) then + recvListCursor => recvList + do while (associated(recvListCursor)) + found = .false. + exchListPtr => recvListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + if (exchListPtr % endPointID == recvEndpoints(iendpt)) then + found = .true. + compactRecvLists(idx) = exchListPtr % nList + idx = idx + 1 + compactRecvLists(idx:idx+exchListPtr % nList-1) = exchListPtr % srcList(1:exchListPtr % nList) + & + ioffset + idx = idx + exchListPtr % nList + compactRecvLists(idx:idx+exchListPtr % nList-1) = exchListPtr % destList(1:exchListPtr % nList) + idx = idx + exchListPtr % nList + ioffset = ioffset + exchListPtr % nList + exit + end if + exchListPtr => exchListPtr % next + end do + if (.not. found) then + compactRecvLists(idx) = 0 + idx = idx + 1 + end if + recvListCursor => recvListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + end if + end do + end do + + deallocate(recvEndpoints) + + deallocate(useHalo) + + end subroutine mpas_halo_compact_halo_info + + + !----------------------------------------------------------------------- + ! routine mpas_halo_aggregate_group_info + ! + !> \brief Aggregate exchange info from all fields in a halo exchange group + !> \author Michael Duda + !> \date 23 November 2021 + !> \details + !> Given an mpas_halo_group, this routine aggregates information from across + !> all mpas_halo_field members of the group. + !> The end result of this routine is a set of arrays that can be used by + !> the mpas_halo_exch_group_full_halo_exch routine to pack/unpack buffers + !> and launch MPI sends and receives: + !> + !> nGroupSendNeighbors + !> groupSendBufSize + !> groupPackOffsets + !> groupSendNeighbors + !> groupSendOffsets + !> groupSendCounts + !> + !> nGroupRecvNeighbors + !> groupRecvBufSize + !> groupUnpackOffsets + !> groupRecvNeighbors + !> groupToFieldRecvEndpt + !> groupRecvOffsets + !> groupRecvCounts + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_aggregate_group_info(group, ierr) + + use mpas_derived_types, only : mpas_halo_group + + ! Arguments + type (mpas_halo_group), intent(inout) :: group + integer, intent(out), optional :: ierr + + ! Local variables + integer :: i, j, idx, ihalo, iendp, nlist + integer :: ndims, ninnerelems + integer :: maxGroupSendNeighbors, maxGroupRecvNeighbors + integer, allocatable, dimension(:) :: sendNeighbors, recvNeighbors + integer, allocatable, dimension(:,:) :: sendCounts, recvCounts + + + if (present(ierr)) then + ierr = 0 + end if + + ! + ! Compute an upper bound on the number of send and recv neighbors for this group + ! + maxGroupSendNeighbors = 0 + maxGroupRecvNeighbors = 0 + do i = 1, group % nFields + maxGroupSendNeighbors = maxGroupSendNeighbors + group % fields(i) % compactHaloInfo(10) + maxGroupRecvNeighbors = maxGroupRecvNeighbors + group % fields(i) % compactHaloInfo(11) + end do + + + ! + ! Create a list of unique send and recv neighbors for this group + ! + allocate(sendNeighbors(maxGroupSendNeighbors)) + allocate(recvNeighbors(maxGroupRecvNeighbors)) + + sendNeighbors(:) = -1 + recvNeighbors(:) = -1 + + group % nGroupSendNeighbors = 0 + group % nGroupRecvNeighbors = 0 + + do i = 1, group % nFields + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(10) + + ! Try to locate this endPointID in the list + do j = 1, group % nGroupSendNeighbors + if (sendNeighbors(j) == group % fields(i) % compactSendLists(idx)) then + exit + end if + end do + + ! If endPointID was not found, add it to the list + if (j > group % nGroupSendNeighbors) then + group % nGroupSendNeighbors = group % nGroupSendNeighbors + 1 + sendNeighbors(group % nGroupSendNeighbors) = group % fields(i) % compactSendLists(idx) + end if + + ! Skip over remaining info for this endpoint + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactSendLists(idx) + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(11) + + ! Try to locate this endPointID in the list + do j = 1, group % nGroupRecvNeighbors + if (recvNeighbors(j) == group % fields(i) % compactRecvLists(idx)) then + exit + end if + end do + + ! If endPointID was not found, add it to the list + if (j > group % nGroupRecvNeighbors) then + group % nGroupRecvNeighbors = group % nGroupRecvNeighbors + 1 + recvNeighbors(group % nGroupRecvNeighbors) = group % fields(i) % compactRecvLists(idx) + end if + + ! Skip over remaining info for this endpoint + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactRecvLists(idx) + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + end do + + allocate(group % groupSendNeighbors(group % nGroupSendNeighbors)) + group % groupSendNeighbors(:) = sendNeighbors(1:group % nGroupSendNeighbors) + + allocate(group % groupRecvNeighbors(group % nGroupRecvNeighbors)) + group % groupRecvNeighbors(:) = recvNeighbors(1:group % nGroupRecvNeighbors) + + allocate(group % groupToFieldRecvIdx(group % nGroupRecvNeighbors, group % nFields)) + group % groupToFieldRecvIdx(:,:) = 0 + + deallocate(sendNeighbors) + deallocate(recvNeighbors) + + + ! + ! Compute total size of send and receive buffers for this group + ! + group % groupSendBufSize = 0 + group % groupRecvBufSize = 0 + + do i = 1, group % nFields + + ndims = group % fields(i) % compactHaloInfo(1) + ninnerelems = 1 + do j = 1, ndims - 1 ! Do not include right-most dimension (nCells, nEdges, or nVertices) + ninnerelems = ninnerelems * group % fields(i) % compactHaloInfo(j + 1) ! First dim is at (2), etc. + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(10) + + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactSendLists(idx) + group % groupSendBufSize = group % groupSendBufSize + ninnerelems * nlist + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(11) + + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactRecvLists(idx) + group % groupRecvBufSize = group % groupRecvBufSize + ninnerelems * nlist + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + end do + + + ! + ! Compute sizes and offsets in group send and recv buffers for all fields in group + ! + allocate(group % groupPackOffsets(group % nGroupSendNeighbors, group % nFields)) + allocate(group % groupSendOffsets(group % nGroupSendNeighbors)) + allocate(group % groupSendCounts(group % nGroupSendNeighbors)) + group % groupPackOffsets(:,:) = -1 + group % groupSendOffsets(:) = -1 + group % groupSendCounts(:) = -1 + + allocate(group % groupUnpackOffsets(group % nGroupRecvNeighbors, group % nFields)) + allocate(group % groupRecvOffsets(group % nGroupRecvNeighbors)) + allocate(group % groupRecvCounts(group % nGroupRecvNeighbors)) + group % groupUnpackOffsets(:,:) = -1 + group % groupRecvOffsets(:) = -1 + group % groupRecvCounts(:) = -1 + + allocate(sendCounts(group % nGroupSendNeighbors, group % nFields)) + allocate(recvCounts(group % nGroupRecvNeighbors, group % nFields)) + sendCounts(:,:) = 0 + recvCounts(:,:) = 0 + + do i = 1, group % nFields + + ndims = group % fields(i) % compactHaloInfo(1) + ninnerelems = 1 + do j = 1, ndims - 1 ! Do not include right-most dimension (nCells, nEdges, or nVertices) + ninnerelems = ninnerelems * group % fields(i) % compactHaloInfo(j + 1) ! First dim is at (2), etc. + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(10) + + ! Find neighbor in groupSendNeighbors + do j = 1, group % nGroupSendNeighbors + if (group % fields(i) % compactSendLists(idx) == group % groupSendNeighbors(j)) then + exit + end if + end do + + idx = idx + 1 ! skip over endPointID + sendCounts(j, i) = 0 + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactSendLists(idx) + sendCounts(j, i) = sendCounts(j, i) + nlist * ninnerelems + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(11) + + ! Find neighbor in groupRecvNeighbors + do j = 1, group % nGroupRecvNeighbors + if (group % fields(i) % compactRecvLists(idx) == group % groupRecvNeighbors(j)) then + group % groupToFieldRecvIdx(j, i) = iendp + exit + end if + end do + + idx = idx + 1 ! skip over endPointID + recvCounts(j, i) = 0 + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactRecvLists(idx) + recvCounts(j, i) = recvCounts(j, i) + nlist * ninnerelems + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + end do + + do j = 1, group % nGroupSendNeighbors + group % groupPackOffsets(j, 1) = 0 + do i = 2, group % nFields + group % groupPackOffsets(j, i) = group % groupPackOffsets(j, i-1) + sendCounts(j, i-1) + end do + end do + + do j = 1, group % nGroupRecvNeighbors + group % groupUnpackOffsets(j, 1) = 0 + do i = 2, group % nFields + group % groupUnpackOffsets(j, i) = group % groupUnpackOffsets(j, i-1) + recvCounts(j, i-1) + end do + end do + + do j = 1, group % nGroupSendNeighbors + group % groupSendCounts(j) = 0 + do i = 1, group % nFields + group % groupSendCounts(j) = group % groupSendCounts(j) + sendCounts(j, i) + end do + + if (j == 1) then + group % groupSendOffsets(j) = 1 + else + group % groupSendOffsets(j) = group % groupSendOffsets(j-1) + group % groupSendCounts(j-1) + + do i = 1, group % nFields + group % groupPackOffsets(j, i) = group % groupPackOffsets(j, i) + group % groupSendOffsets(j) - 1 + end do + end if + end do + + do j = 1, group % nGroupRecvNeighbors + group % groupRecvCounts(j) = 0 + do i = 1, group % nFields + group % groupRecvCounts(j) = group % groupRecvCounts(j) + recvCounts(j, i) + end do + + if (j == 1) then + group % groupRecvOffsets(j) = 1 + else + group % groupRecvOffsets(j) = group % groupRecvOffsets(j-1) + group % groupRecvCounts(j-1) + + do i = 1, group % nFields + group % groupUnpackOffsets(j, i) = group % groupUnpackOffsets(j, i) + group % groupRecvOffsets(j) - 1 + end do + end if + end do + + deallocate(sendCounts) + deallocate(recvCounts) + + end subroutine mpas_halo_aggregate_group_info + + + !----------------------------------------------------------------------- + ! routine refactor_lists + ! + !> \brief Convert compact{Send,Recv}Lists into multi-dimensional arrays + !> \author Michael Duda + !> \date 25 May 2022 + !> \details + !> For each field in the halo exchange group identified by groupName, + !> convert the compact{Send,Recv}Lists 1-d arrays into multi-dimensional + !> arrays that allow for more optimal pack and unpack loops in the + !> mpas_halo_exch_group_full_halo_exch routine. + !> + !> The following members in the mpas_halo_field type are allocated and + !> set by this routine: + !> + !> nSendLists + !> maxNSendList + !> sendListSrc + !> sendListDst + !> packOffsets + !> + !> nRecvLists + !> maxNRecvList + !> recvListSrc + !> recvListDst + !> unpackOffsets + ! + !----------------------------------------------------------------------- + subroutine refactor_lists(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_halo_group, MPAS_HALO_REAL, MPAS_LOG_CRIT + use mpas_pool_routines, only : mpas_pool_get_array + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i + integer :: iNeighbor, j + integer :: iHalo, iEndp + integer :: nHalos, nSendEndpts, nRecvEndpts + integer :: idx, idx_local + type (mpas_halo_group), pointer :: group + integer, dimension(:), pointer :: compactHaloInfo + integer, dimension(:), pointer :: compactSendLists + integer, dimension(:), pointer :: compactRecvLists + integer :: maxNSendList + integer, dimension(:,:), CONTIGUOUS pointer :: nSendLists + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListSrc, sendListDst + integer, dimension(:), CONTIGUOUS pointer :: packOffsets + integer :: maxNRecvList + integer, dimension(:,:), CONTIGUOUS pointer :: nRecvLists + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListSrc, recvListDst + integer, dimension(:), CONTIGUOUS pointer :: unpackOffsets + + + if (present(iErr)) then + iErr = 0 + end if + + ! + ! Find this halo exhange group in the list of groups + ! + group => domain % haloGroups + do while (associated(group)) + if (trim(group % groupName) == trim(groupName)) then + exit + end if + + group => group % next + end do + + if (.not. associated(group)) then + call mpas_log_write('Halo exchange group '//trim(groupName)//' not found in refactor_lists.', & + messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Pack the segmented send buffer with elements from all fields and for all neighbors + ! + do i = 1, group % nFields + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactSendLists => group % fields(i) % compactSendLists + + ! + ! Packing code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + nHalos = compactHaloInfo(9) + nSendEndpts = compactHaloInfo(10) + idx = 1 + + allocate(group % fields(i) % nSendLists(3,nSendEndpts)) ! MGD fix hard-coded 3 later... + allocate(group % fields(i) % packOffsets(nSendEndpts)) + + nSendLists => group % fields(i) % nSendLists + packOffsets => group % fields(i) % packOffsets + + nSendLists(:,:) = 0 + packOffsets(:) = 0 + + idx_local = idx + + do iEndp = 1, nSendEndpts + ! Find this endpoint in the list of neighbors + do iNeighbor = 1, group % nGroupSendNeighbors + if (group % groupSendNeighbors(iNeighbor) == compactSendLists(idx)) exit + end do + idx = idx + 1 + + packOffsets(iEndp) = group % groupPackOffsets(iNeighbor, i) + + do iHalo = 1, nHalos + nSendLists(iHalo,iEndp) = compactSendLists(idx) + idx = idx + 1 + idx = idx + 2*nSendLists(iHalo,iEndp) + end do + end do + + maxNSendList = maxval(nSendLists) + group % fields(i) % maxNSendList = maxNSendList + + allocate(group % fields(i) % sendListSrc(maxNSendList,nHalos,nSendEndpts)) + allocate(group % fields(i) % sendListDst(maxNSendList,nHalos,nSendEndpts)) + + sendListSrc => group % fields(i) % sendListSrc + sendListDst => group % fields(i) % sendListDst + + sendListSrc(:,:,:) = 0 + sendListDst(:,:,:) = 0 + + idx = idx_local + + do iEndp = 1, nSendEndpts + idx = idx + 1 + + do iHalo = 1, nHalos + idx = idx + 1 + do j = 1, nSendLists(iHalo,iEndp) + sendListSrc(j,iHalo,iEndp) = compactSendLists(idx + j - 1) + sendListDst(j,iHalo,iEndp) = compactSendLists(idx + nSendLists(iHalo,iEndp) + j - 1) + end do + idx = idx + 2*nSendLists(iHalo,iEndp) + end do + end do + + end if + end do + + + ! + ! Unpack the segmented recv buffer with elements for all fields and from all neighbors + ! + do i = 1, group % nFields + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactRecvLists => group % fields(i) % compactRecvLists + + idx = 1 + + ! + ! Unpacking code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + nHalos = compactHaloInfo(9) + nRecvEndpts = compactHaloInfo(11) + idx = 1 + + allocate(group % fields(i) % nRecvLists(3,nRecvEndpts)) ! MGD fix hard-coded 3 later... + allocate(group % fields(i) % unpackOffsets(nRecvEndpts)) + + nRecvLists => group % fields(i) % nRecvLists + unpackOffsets => group % fields(i) % unpackOffsets + + nRecvLists(:,:) = 0 + unpackOffsets(:) = 0 + + idx_local = idx + + do iEndp = 1, nRecvEndpts + ! Find this endpoint in the list of neighbors + do iNeighbor = 1, group % nGroupRecvNeighbors + if (group % groupRecvNeighbors(iNeighbor) == compactRecvLists(idx)) exit + end do + idx = idx + 1 + + unpackOffsets(iEndp) = group % groupUnpackOffsets(iNeighbor, i) + + do iHalo = 1, nHalos + nRecvLists(iHalo,iEndp) = compactRecvLists(idx) + idx = idx + 1 + idx = idx + 2*nRecvLists(iHalo,iEndp) + end do + end do + + maxNRecvList = maxval(nRecvLists) + group % fields(i) % maxNRecvList = maxNRecvList + + allocate(group % fields(i) % recvListSrc(maxNRecvList,nHalos,nRecvEndpts)) + allocate(group % fields(i) % recvListDst(maxNRecvList,nHalos,nRecvEndpts)) + + recvListSrc => group % fields(i) % recvListSrc + recvListDst => group % fields(i) % recvListDst + + recvListSrc(:,:,:) = 0 + recvListDst(:,:,:) = 0 + + idx = idx_local + + do iEndp = 1, nRecvEndpts + idx = idx + 1 + + do iHalo = 1, nHalos + idx = idx + 1 + do j = 1, nRecvLists(iHalo,iEndp) + recvListSrc(j,iHalo,iEndp) = compactRecvLists(idx + j - 1) + recvListDst(j,iHalo,iEndp) = compactRecvLists(idx + nRecvLists(iHalo,iEndp) + j - 1) + end do + idx = idx + 2*nRecvLists(iHalo,iEndp) + end do + end do + + end if + end do + + end subroutine refactor_lists + +end module mpas_halo diff --git a/src/framework/mpas_halo_types.inc b/src/framework/mpas_halo_types.inc new file mode 100644 index 0000000000..46841c6883 --- /dev/null +++ b/src/framework/mpas_halo_types.inc @@ -0,0 +1,77 @@ +#define CONTIGUOUS contiguous, + + integer, parameter :: MPAS_HALO_INVALID = -1 + + integer, parameter :: MPAS_HALO_REAL = 5001, & + MPAS_HALO_INTEGER = 5002 + + + ! + ! Information about an individual field in a halo group + ! + type mpas_halo_field + character(len=StrKIND) :: fieldName = '' ! Name of the field + integer :: nDims = MPAS_HALO_INVALID ! Number of dimensions for field + integer :: fieldType = MPAS_HALO_INVALID ! Field type: MPAS_HALO_REAL, MPAS_HALO_INTEGER + integer :: timeLevel = MPAS_HALO_INVALID ! Which time level to exchange + + integer, dimension(:), pointer :: compactHaloInfo => null() ! Information about halo communication for this field + integer, dimension(:), pointer :: compactSendLists => null() ! Elements sent to each neighbor + integer, dimension(:), pointer :: compactRecvLists => null() ! Elements received from each neighbor + + integer, dimension(:,:), CONTIGUOUS pointer :: nSendLists => null() ! (3,nSendEndpoints) 3 is assumed max halos + integer :: maxNSendList ! maxval(nSendLists) + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListSrc => null() ! (maxNSendList,nHalos,nSendEndpts) + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListDst => null() ! (maxNSendList,nHalos,nSendEndpts) + integer, dimension(:), CONTIGUOUS pointer :: packOffsets => null() ! (nSendEndpts) + + integer, dimension(:,:), CONTIGUOUS pointer :: nRecvLists => null() ! (3,nRecvEndpoints) 3 is assumed max halos + integer :: maxNRecvList ! maxval(nRecvLists) + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListSrc => null() ! (maxNRecvList,nHalos,nRecvEndpts) + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListDst => null() ! (maxNRecvList,nHalos,nRecvEndpts) + integer, dimension(:), CONTIGUOUS pointer :: unpackOffsets => null() ! (nRecvEndpts) + + real (kind=RKIND), dimension(:,:), pointer :: r2arr => null() ! Pointer to field array, only used internally + real (kind=RKIND), dimension(:,:,:), pointer :: r3arr => null() ! Pointer to field array, only used internally + end type mpas_halo_field + + + ! + ! Information about an entire halo group + ! + type mpas_halo_group + character(len=StrKIND) :: groupName = '' ! Name of the group + integer :: nFields = MPAS_HALO_INVALID ! Number of fields in the group + type (mpas_halo_field), dimension(:), pointer :: fields => null() ! Array of field halo info types, dimensioned nFields + + integer :: nGroupSendNeighbors = MPAS_HALO_INVALID ! Number of unique neighbors that we send to + integer :: groupSendBufSize = MPAS_HALO_INVALID ! Total number of elements to be sent in a group exchange + real (kind=RKIND), dimension(:), pointer :: sendBuf => null() ! Segmented buffer used for outgoing messages + integer, dimension(:), pointer :: sendRequests => null() ! Used internally - MPI request IDs + integer, dimension(:,:), pointer :: groupPackOffsets => null() ! Offsets into sendBuf for each neighbor and each field + ! dimensioned (nGroupSendNeighbors, nFields) + integer, dimension(:), pointer :: groupSendNeighbors => null() ! List of neighbors we send to + ! dimensioned (nGroupSendNeighbors) + integer, dimension(:), pointer :: groupSendOffsets => null() ! Offset in sendBuf of segment to send to each neighbor + ! dimensioned (nGroupSendNeighbors) + integer, dimension(:), pointer :: groupSendCounts => null() ! Size of sendBuf segment to send to each neighbor + ! dimensioned (nGroupSendNeighbors) + + integer :: nGroupRecvNeighbors = MPAS_HALO_INVALID ! Number of unique neighbors that we recv from + integer :: groupRecvBufSize = MPAS_HALO_INVALID ! Total number of elements to be recvd in a group exchange + real (kind=RKIND), dimension(:), pointer :: recvBuf => null() ! Segmented buffer used for incoming messages + integer, dimension(:), pointer :: recvRequests => null() ! Used internally - MPI request IDs + integer, dimension(:,:), pointer :: groupUnpackOffsets => null() ! Offsets into recvBuf for each neighbor and each field + ! dimensioned (nGroupRecvNeighbors, nFields) + integer, dimension(:), pointer :: groupRecvNeighbors => null() ! List of neighbors we recv from + ! dimensioned (nGroupRecvNeighbors) + integer, dimension(:,:), pointer :: groupToFieldRecvIdx => null() ! Convert from group-wide neighbor indices to + ! field-local indices + ! dimensioned (nGroupRecvNeighbors, nFields) + integer, dimension(:), pointer :: groupRecvOffsets => null() ! Offset in recvBuf of segment to recv from each neighbor + ! dimensioned (nGroupRecvNeighbors) + integer, dimension(:), pointer :: groupRecvCounts => null() ! Size of recvBuf segment to recv from each neighbor + ! dimensioned (nGroupRecvNeighbors) + + type (mpas_halo_group), pointer :: next => null() ! Pointer to the next halo group + end type mpas_halo_group diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 7fcec3a76b..01ab167243 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -12,6 +12,7 @@ module mpas_io use mpas_dmpar use mpas_log +#ifdef MPAS_PIO_SUPPORT use pio use piolib_mod use pionfatt_mod @@ -22,7 +23,19 @@ module mpas_io #else integer, parameter :: PIO_REALKIND = PIO_DOUBLE #endif +#endif + +#ifdef MPAS_SMIOL_SUPPORT + use SMIOLf + +#include "smiol_codes.inc" +#endif + +#ifdef MPAS_PIO_SUPPORT + ! + ! PIO-based fill values + ! #ifdef USE_PIO2 integer, parameter :: MPAS_INT_FILLVAL = PIO_FILL_INT character, parameter :: MPAS_CHAR_FILLVAL = achar(0) ! TODO: To be replaced with PIO_FILL_CHAR once PIO2 provides this variable @@ -43,6 +56,30 @@ module mpas_io #else real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = NF_FILL_DOUBLE #endif +#endif + +#else + +#ifdef MPAS_SMIOL_SUPPORT + + ! + ! SMIOL-based fill values + ! + integer, parameter :: MPAS_INT_FILLVAL = huge(0) + character, parameter :: MPAS_CHAR_FILLVAL = achar(0) + real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = huge(0.0_RKIND) + +#else + + ! + ! Default fill values + ! + integer, parameter :: MPAS_INT_FILLVAL = huge(1) + character, parameter :: MPAS_CHAR_FILLVAL = achar(0) + real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = huge(1.0_RKIND) + +#endif + #endif interface MPAS_io_get_var @@ -103,7 +140,11 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier type (mpas_io_context_type), intent(inout) :: ioContext integer, intent(in) :: io_task_count integer, intent(in) :: io_task_stride +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), optional, pointer :: io_system +#else + integer, optional, pointer :: io_system +#endif integer, intent(out), optional :: ierr integer :: local_ierr @@ -114,7 +155,9 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier if (present(ierr)) ierr = MPAS_IO_NOERR if (present(io_system)) then +#ifdef MPAS_PIO_SUPPORT ioContext % pio_iosystem => io_system +#endif else !call mpas_log_write('MGD PIO_init') if ( io_task_count < 0 .or. io_task_count > ioContext % dminfo % nprocs ) then @@ -140,6 +183,7 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier call mpas_log_write('Invalid PIO configuration.', MPAS_LOG_CRIT) end if +#ifdef MPAS_PIO_SUPPORT allocate(ioContext % pio_iosystem) call PIO_init(ioContext % dminfo % my_proc_id, & ! comp_rank ioContext % dminfo % comm, & ! comp_comm @@ -148,10 +192,29 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier io_task_stride, & ! stride PIO_rearr_box, & ! rearr ioContext % pio_iosystem) ! iosystem +#endif + +#ifdef MPAS_SMIOL_SUPPORT + allocate(ioContext % smiol_context) + local_ierr = SMIOLf_init(ioContext % dminfo % comm, & + io_task_count, & + io_task_stride, & + iocontext % smiol_context) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_init failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(ioContext % smiol_context)), messageType=MPAS_LOG_CRIT) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_CRIT) + end if + end if +#endif end if +#ifdef MPAS_PIO_SUPPORT call pio_seterrorhandling(ioContext % pio_iosystem, PIO_BCAST_ERROR) +#endif end subroutine MPAS_io_init @@ -212,7 +275,8 @@ subroutine MPAS_io_unset_iotype(ioContext, ierr) end subroutine MPAS_io_unset_iotype - type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioContext, clobber_file, truncate_file, ierr) + type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioContext, & + clobber_file, truncate_file, pio_file_desc, ierr) implicit none @@ -222,11 +286,20 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon type (mpas_io_context_type), pointer :: ioContext logical, intent(in), optional :: clobber_file logical, intent(in), optional :: truncate_file +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, optional :: pio_file_desc +#endif integer, intent(out), optional :: ierr integer :: pio_ierr, pio_iotype, pio_mode + integer :: local_ierr logical :: local_clobber, local_truncate logical :: exists +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: preexisting_records +#endif ! call mpas_log_write('Called MPAS_io_open()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -266,6 +339,7 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon MPAS_io_open % ioformat = ioformat MPAS_io_open % ioContext => ioContext +#ifdef MPAS_PIO_SUPPORT if (ioContext % master_pio_iotype /= -999) then pio_iotype = ioContext % master_pio_iotype pio_mode = PIO_64BIT_OFFSET @@ -288,48 +362,88 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon #endif end if end if +#endif - if (mode == MPAS_IO_WRITE) then + if (present(pio_file_desc)) then +#ifdef MPAS_PIO_SUPPORT + MPAS_io_open % pio_file = pio_file_desc +#endif + MPAS_io_open % external_file_desc = .true. + else + if (mode == MPAS_IO_WRITE) then !call mpas_log_write('MGD PIO_createfile') - if (ioContext % dminfo % my_proc_id == 0) then - inquire(file=trim(filename), exist=exists) - end if - call mpas_dmpar_bcast_logical(ioContext % dminfo, exists) + if (ioContext % dminfo % my_proc_id == 0) then + inquire(file=trim(filename), exist=exists) + end if + call mpas_dmpar_bcast_logical(ioContext % dminfo, exists) - ! If the file exists and we are not allowed to clobber it, return an - ! appropriate error code - if (exists .and. (.not. local_clobber)) then - if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER - return - end if + ! If the file exists and we are not allowed to clobber it, return an + ! appropriate error code + if (exists .and. (.not. local_clobber)) then + if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER + return + end if - if (exists .and. (.not. local_truncate)) then - pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) - MPAS_io_open % preexisting_file = .true. - else - pio_ierr = PIO_createfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), pio_mode) + if (exists .and. (.not. local_truncate)) then +#ifdef MPAS_PIO_SUPPORT + pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_open_file(ioContext % smiol_context, trim(filename), & + SMIOL_FILE_WRITE, MPAS_io_open % smiol_file) +#endif + MPAS_io_open % preexisting_file = .true. + else +#ifdef MPAS_PIO_SUPPORT + pio_ierr = PIO_createfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), pio_mode) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_open_file(ioContext % smiol_context, trim(filename), & + SMIOL_FILE_CREATE, MPAS_io_open % smiol_file) +#endif #ifdef MPAS_DEBUG - if (exists) then - call mpas_log_write('MPAS I/O: Truncating existing data in output file '//trim(filename), MPAS_LOG_WARN) - end if + if (exists) then + call mpas_log_write('MPAS I/O: Truncating existing data in output file '//trim(filename), MPAS_LOG_WARN) + end if #endif - end if - else - inquire(file=trim(filename), exist=exists) + end if + else + inquire(file=trim(filename), exist=exists) - if (.not. exists) then - if (present(ierr)) ierr = MPAS_IO_ERR_NOEXIST_READ + if (.not. exists) then + if (present(ierr)) ierr = MPAS_IO_ERR_NOEXIST_READ + return + end if +#ifdef MPAS_PIO_SUPPORT +!call mpas_log_write('MGD PIO_openfile') + pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_open_file(ioContext % smiol_context, trim(filename), & + SMIOL_FILE_READ, MPAS_io_open % smiol_file) +#endif + endif +#ifdef MPAS_PIO_SUPPORT + if (pio_ierr /= PIO_noerr) then + if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if -!call mpas_log_write('MGD PIO_openfile') - pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) - endif - if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO - return +#endif +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_open_file failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif + MPAS_io_open % external_file_desc = .false. end if if (mode == MPAS_IO_READ .or. MPAS_io_open % preexisting_file) then +#ifdef MPAS_PIO_SUPPORT !MPAS_io_open % pio_unlimited_dimid = 44 pio_ierr = PIO_inquire(MPAS_io_open % pio_file, unlimitedDimID=MPAS_io_open % pio_unlimited_dimid) !call mpas_log_write('Found unlimited dim $i', intArgs=(/MPAS_io_open % pio_unlimited_dimid/) ) @@ -337,7 +451,9 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif +#ifdef MPAS_PIO_SUPPORT ! Here we're depending on the undocumented behavior of PIO to return a ! negative dimension ID when an unlimited dimension is not found. This ! might change in the future, causing this code to break, though it @@ -351,6 +467,12 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon else MPAS_io_open % preexisting_records = -1 end if +#endif +#ifdef MPAS_SMIOL_SUPPORT +!MGD TODO: need a way to determine which dimension is the unlimited dimension + local_ierr = SMIOLf_inquire_dim(MPAS_io_open % smiol_file, 'Time', dimsize=preexisting_records) + MPAS_io_open % preexisting_records = preexisting_records +#endif end if MPAS_io_open % initialized = .true. @@ -383,12 +505,19 @@ subroutine MPAS_io_inq_unlimited_dim(handle, dimname, ierr) return end if +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_dimname(handle % pio_file, handle % pio_unlimited_dimid, dimname) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_NO_UNLIMITED_DIM dimname = ' ' return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT +!MGD TODO: Do this for SMIOL once we have a way to inquire about unlimited dim by name + dimname = 'Time' +#endif end subroutine MPAS_io_inq_unlimited_dim @@ -405,6 +534,10 @@ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr) type (dimlist_type), pointer :: new_dimlist_node type (dimlist_type), pointer :: dim_cursor integer :: pio_ierr + integer :: local_ierr +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: local_dimsize +#endif ! call mpas_log_write('Called MPAS_io_inq_dim()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -438,6 +571,7 @@ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr) new_dimlist_node % dimhandle % dimname = dimname +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_dimid(handle % pio_file, trim(dimname), new_dimlist_node % dimhandle % dimid) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_MISSING_DIM @@ -457,6 +591,21 @@ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr) dimsize = -1 return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_inquire_dim(handle % smiol_file, trim(dimname), & + dimsize=local_dimsize, & + is_unlimited=new_dimlist_node % dimhandle % is_unlimited_dim) + if (local_ierr /= SMIOL_SUCCESS) then + if (present(ierr)) ierr = MPAS_IO_ERR_MISSING_DIM + deallocate(new_dimlist_node % dimhandle) + deallocate(new_dimlist_node) + dimsize = -1 + return + end if + new_dimlist_node % dimhandle % dimsize = local_dimsize +#endif ! Keep dimension information for future reference if (.not. associated(handle % dimlist_head)) then @@ -484,7 +633,11 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: inq_dimsize +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: local_dimsize +#endif type (dimlist_type), pointer :: new_dimlist_node type (dimlist_type), pointer :: dim_cursor @@ -563,16 +716,39 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) new_dimlist_node % dimhandle % dimsize = dimsize if (dimsize == MPAS_IO_UNLIMITED_DIM) then new_dimlist_node % dimhandle % is_unlimited_dim = .true. +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_def_dim(handle % pio_file, trim(dimname), PIO_unlimited, new_dimlist_node % dimhandle % dimid) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_dimsize = -1_SMIOL_offset_kind +#endif else +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_def_dim(handle % pio_file, trim(dimname), dimsize, new_dimlist_node % dimhandle % dimid) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_dimsize = int(dimsize,kind=SMIOL_offset_kind) +#endif end if +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_define_dim(handle % smiol_file, trim(dimname), local_dimsize) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_dim failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif +#ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO deallocate(new_dimlist_node % dimhandle) deallocate(new_dimlist_node) return end if +#endif ! Keep dimension information if (.not. associated(handle % dimlist_head)) then @@ -611,6 +787,13 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz integer, dimension(:), pointer :: dimids logical :: found integer :: pio_ierr + integer :: local_ierr + integer :: smiol_type + integer :: smiol_ndims + character(len=StrKind), dimension(:), allocatable :: smiol_dimnames +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: smiol_dimlen +#endif ! call mpas_log_write('Called MPAS_io_inq_var()') @@ -649,6 +832,7 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz new_fieldlist_node % fieldhandle % fieldname = fieldname ! Get variable ID +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % fieldid) pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % field_desc) if (pio_ierr /= PIO_noerr) then @@ -684,8 +868,36 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz new_fieldlist_node % fieldhandle % field_type = MPAS_IO_CHAR !!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!! end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), vartype=smiol_type) + if (local_ierr /= SMIOL_SUCCESS) then + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + deallocate(new_fieldlist_node % fieldhandle) + deallocate(new_fieldlist_node) + call mpas_log_write('Variable ' // trim(fieldname) // ' not in input file.', MPAS_LOG_WARN) + return + end if + new_fieldlist_node % fieldhandle % field_type = smiol_type + + ! Convert to MPAS type + new_fieldlist_node % fieldhandle % precision = MPAS_IO_NATIVE_PRECISION + if (new_fieldlist_node % fieldhandle % field_type == SMIOL_REAL64) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_DOUBLE + new_fieldlist_node % fieldhandle % precision = MPAS_IO_DOUBLE_PRECISION + else if (new_fieldlist_node % fieldhandle % field_type == SMIOL_REAL32) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL + new_fieldlist_node % fieldhandle % precision = MPAS_IO_SINGLE_PRECISION + else if (new_fieldlist_node % fieldhandle % field_type == SMIOL_INT32) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_INT + else if (new_fieldlist_node % fieldhandle % field_type == SMIOL_CHAR) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_CHAR + end if +#endif ! Get number of dimensions +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_varndims(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, new_fieldlist_node % fieldhandle % ndims) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO @@ -694,10 +906,32 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz return end if !call mpas_log_write('Inquired about number of dimensions $i', intArgs=(/new_fieldlist_node % fieldhandle % ndims/) ) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), ndims=smiol_ndims) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_inquire_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + + deallocate(new_fieldlist_node % fieldhandle) + deallocate(new_fieldlist_node) + call mpas_log_write('Variable ' // trim(fieldname) // ' not in input file.', MPAS_LOG_WARN) + return + end if + new_fieldlist_node% fieldhandle % ndims = smiol_ndims +#endif allocate(dimids(new_fieldlist_node % fieldhandle % ndims)) ! Get dimension IDs +#ifdef MPAS_PIO_SUPPORT if (new_fieldlist_node % fieldhandle % ndims > 0) then pio_ierr = PIO_inq_vardimid(handle % pio_file, new_fieldlist_node % fieldhandle % fieldid, dimids) if (pio_ierr /= PIO_noerr) then @@ -709,9 +943,11 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz end if !call mpas_log_write('Inquired about dimension IDs $i.', intArgs=(/dimids/) ) end if +#endif allocate(new_fieldlist_node % fieldhandle % dims(new_fieldlist_node % fieldhandle % ndims)) +#ifdef MPAS_PIO_SUPPORT ! Get information about dimensions do i=1,new_fieldlist_node % fieldhandle % ndims new_fieldlist_node % fieldhandle % dims(i) % dimid = dimids(i) @@ -741,6 +977,42 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz !call mpas_log_write('Inquired about dimension name ' // trim(new_fieldlist_node % fieldhandle % dims(i) % dimname)) end do +#endif + +#ifdef MPAS_SMIOL_SUPPORT + new_fieldlist_node % fieldhandle % has_unlimited_dim = .false. + allocate(smiol_dimnames(smiol_ndims)) + local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), dimnames=smiol_dimnames) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_inquire_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if + do i=1,new_fieldlist_node % fieldhandle % ndims + new_fieldlist_node % fieldhandle % dims(i) % dimname = smiol_dimnames(i) + end do + do i=1,new_fieldlist_node % fieldhandle % ndims + local_ierr = SMIOLf_inquire_dim(handle % smiol_file, trim(smiol_dimnames(i)), & + dimsize=smiol_dimlen, & + is_unlimited=new_fieldlist_node % fieldhandle % dims(i) % is_unlimited_dim) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_inquire_dim failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if + new_fieldlist_node % fieldhandle % dims(i) % dimsize = smiol_dimlen + if (new_fieldlist_node % fieldhandle % dims(i) % is_unlimited_dim) then + new_fieldlist_node % fieldhandle % has_unlimited_dim = .true. + end if + end do + deallocate(smiol_dimnames) +#endif deallocate(dimids) @@ -828,7 +1100,9 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie integer :: i integer :: pio_ierr + integer :: local_ierr integer :: pio_type + integer :: smiol_type integer :: ndims integer :: inq_fieldtype integer :: inq_ndims @@ -980,25 +1254,56 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie ! Convert from MPAS type if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_DOUBLE) then if (local_precision == MPAS_IO_SINGLE_PRECISION) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_real +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL32 +#endif new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL else +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_double +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL64 +#endif end if else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_REAL) then if (local_precision == MPAS_IO_DOUBLE_PRECISION) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_double +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL64 +#endif new_fieldlist_node % fieldhandle % field_type = MPAS_IO_DOUBLE else +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_real +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL32 +#endif end if else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_INT) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_int +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_INT32 +#endif else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_CHAR) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_char +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_CHAR +#endif !!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!! end if +#ifdef MPAS_PIO_SUPPORT if (ndims == 0) then pio_ierr = PIO_def_var(handle % pio_file, trim(fieldname), pio_type, new_fieldlist_node % fieldhandle % field_desc) else @@ -1008,13 +1313,27 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_define_var(handle % smiol_file, trim(fieldname), smiol_type, size(dimnames), dimnames) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif ! Get the varid for use by put_att routines +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_varid(handle % pio_file, trim(fieldname), new_fieldlist_node % fieldhandle % fieldid) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif deallocate(dimids) @@ -1102,6 +1421,11 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) integer, dimension(:), pointer :: dimlist integer (kind=MPAS_IO_OFFSET_KIND), dimension(:), pointer :: compdof type (decomplist_type), pointer :: decomp_cursor, new_decomp +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind), dimension(:), pointer :: smiol_indices + integer :: local_ierr + integer(kind=SMIOL_offset_kind) :: smiol_n_compute_elements +#endif ! call mpas_log_write('Called MPAS_io_set_var_indices()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -1147,6 +1471,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) !if (.not. associated(decomp_cursor)) call mpas_log_write('No existing decompositions to check...') early_return = 0 DECOMP_LOOP: do while (associated(decomp_cursor)) +#ifdef MPAS_PIO_SUPPORT if (decomp_cursor % decomphandle % field_type == field_cursor % fieldhandle % field_type) then if (size(decomp_cursor % decomphandle % dims) == field_cursor % fieldhandle % ndims) then !call mpas_log_write('Number of dimensions matches...') @@ -1157,6 +1482,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) cycle DECOMP_LOOP end if end do +#endif if (size(decomp_cursor % decomphandle % indices) /= size(indices)) then !call mpas_log_write('We do not have the same number of indices in this decomposition...') @@ -1177,6 +1503,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) !call mpas_log_write('Found a matching decomposition that we can use') early_return = 1 exit DECOMP_LOOP +#ifdef MPAS_PIO_SUPPORT else if ((size(decomp_cursor % decomphandle % dims) == field_cursor % fieldhandle % ndims - 1) & .and. field_cursor % fieldhandle % has_unlimited_dim & ) then @@ -1212,6 +1539,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) exit DECOMP_LOOP end if end if +#endif decomp_cursor => decomp_cursor % next end do DECOMP_LOOP @@ -1244,6 +1572,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) new_decomp % decomphandle % indices(:) = indices(:) ! Convert from MPAS type +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % field_type == MPAS_IO_DOUBLE) then pio_type = PIO_double else if (field_cursor % fieldhandle % field_type == MPAS_IO_REAL) then @@ -1326,6 +1655,26 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) dimlist(ndims) = field_cursor % fieldhandle % dims(ndims) % dimsize call PIO_initdecomp(handle % ioContext % pio_iosystem, pio_type, dimlist, compdof, new_decomp % decomphandle % pio_iodesc) + deallocate(compdof) + deallocate(dimlist) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + allocate(smiol_indices(size(indices))) + smiol_indices(:) = int(indices(:), kind=SMIOL_offset_kind) - 1_SMIOL_offset_kind ! SMIOL indices are 0-based + smiol_n_compute_elements = size(indices,kind=SMIOL_offset_kind) + local_ierr = SMIOLf_create_decomp(handle % ioContext % smiol_context, smiol_n_compute_elements, smiol_indices, & + new_decomp % decomphandle % smiol_decomp) + deallocate(smiol_indices) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_create_decomp failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif ! Add new decomposition to the list if (.not. associated(handle % ioContext % decomp_list)) then @@ -1340,8 +1689,6 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) !call mpas_log_write('Setting decomp in fieldhandle') field_cursor % fieldhandle % decomp => new_decomp % decomphandle - deallocate(compdof) - deallocate(dimlist) !call mpas_log_write('All finished.') end subroutine MPAS_io_set_var_indices @@ -1355,22 +1702,23 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr type (MPAS_IO_Handle_type), intent(inout) :: handle character (len=*), intent(in) :: fieldname - integer, intent(out), optional :: intVal - integer, dimension(:), intent(out), optional :: intArray1d - integer, dimension(:,:), intent(out), optional :: intArray2d - integer, dimension(:,:,:), intent(out), optional :: intArray3d - integer, dimension(:,:,:,:), intent(out), optional :: intArray4d - real (kind=RKIND), intent(out), optional :: realVal - real (kind=RKIND), dimension(:), intent(out), optional :: realArray1d - real (kind=RKIND), dimension(:,:), intent(out), optional :: realArray2d - real (kind=RKIND), dimension(:,:,:), intent(out), optional :: realArray3d - real (kind=RKIND), dimension(:,:,:,:), intent(out), optional :: realArray4d - real (kind=RKIND), dimension(:,:,:,:,:), intent(out), optional :: realArray5d - character (len=*), intent(out), optional :: charVal - character (len=*), dimension(:), intent(out), optional :: charArray1d + integer, intent(out), target, optional :: intVal + integer, dimension(:), intent(out), target, optional :: intArray1d + integer, dimension(:,:), intent(out), target, optional :: intArray2d + integer, dimension(:,:,:), intent(out), target, optional :: intArray3d + integer, dimension(:,:,:,:), intent(out), target, optional :: intArray4d + real (kind=RKIND), intent(out), target, optional :: realVal + real (kind=RKIND), dimension(:), intent(out), target, optional :: realArray1d + real (kind=RKIND), dimension(:,:), intent(out), target, optional :: realArray2d + real (kind=RKIND), dimension(:,:,:), intent(out), target, optional :: realArray3d + real (kind=RKIND), dimension(:,:,:,:), intent(out), target, optional :: realArray4d + real (kind=RKIND), dimension(:,:,:,:,:), intent(out), target, optional :: realArray5d + character (len=*), intent(out), target, optional :: charVal + character (len=*), dimension(:), intent(out), target, optional :: charArray1d integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer, dimension(1) :: start1 integer, dimension(1) :: count1 integer, dimension(2) :: start2 @@ -1388,19 +1736,44 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr integer i, j - real (kind=R4KIND) :: singleVal - real (kind=R4KIND), dimension(:), allocatable :: singleArray1d - real (kind=R4KIND), dimension(:,:), allocatable :: singleArray2d - real (kind=R4KIND), dimension(:,:,:), allocatable :: singleArray3d - real (kind=R4KIND), dimension(:,:,:,:), allocatable :: singleArray4d - real (kind=R4KIND), dimension(:,:,:,:,:), allocatable :: singleArray5d + real (kind=R4KIND), pointer :: singleVal + real (kind=R4KIND), target :: singleVal_target + real (kind=R4KIND), dimension(:), pointer :: singleArray1d + real (kind=R4KIND), dimension(:,:), pointer :: singleArray2d + real (kind=R4KIND), dimension(:,:,:), pointer :: singleArray3d + real (kind=R4KIND), dimension(:,:,:,:), pointer :: singleArray4d + real (kind=R4KIND), dimension(:,:,:,:,:), pointer :: singleArray5d + + real (kind=R8KIND), pointer :: doubleVal + real (kind=R8KIND), target :: doubleVal_target + real (kind=R8KIND), dimension(:), pointer :: doubleArray1d + real (kind=R8KIND), dimension(:,:), pointer :: doubleArray2d + real (kind=R8KIND), dimension(:,:,:), pointer :: doubleArray3d + real (kind=R8KIND), dimension(:,:,:,:), pointer :: doubleArray4d + real (kind=R8KIND), dimension(:,:,:,:,:), pointer :: doubleArray5d + + integer, pointer :: intVal_p + integer, dimension(:), pointer :: intArray1d_p + integer, dimension(:,:), pointer :: intArray2d_p + integer, dimension(:,:,:), pointer :: intArray3d_p + integer, dimension(:,:,:,:), pointer :: intArray4d_p + real (kind=RKIND), pointer :: realVal_p + real (kind=RKIND), dimension(:), pointer :: realArray1d_p + real (kind=RKIND), dimension(:,:), pointer :: realArray2d_p + real (kind=RKIND), dimension(:,:,:), pointer :: realArray3d_p + real (kind=RKIND), dimension(:,:,:,:), pointer :: realArray4d_p + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: realArray5d_p + character (len=:), pointer :: charVal_p + character (len=:), dimension(:), pointer :: charArray1d_p + +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_decomp), pointer :: null_decomp + + nullify(null_decomp) +#endif - real (kind=R8KIND) :: doubleVal - real (kind=R8KIND), dimension(:), allocatable :: doubleArray1d - real (kind=R8KIND), dimension(:,:), allocatable :: doubleArray2d - real (kind=R8KIND), dimension(:,:,:), allocatable :: doubleArray3d - real (kind=R8KIND), dimension(:,:,:,:), allocatable :: doubleArray4d - real (kind=R8KIND), dimension(:,:,:,:,:), allocatable :: doubleArray5d + singleVal => singleVal_target + doubleVal => doubleVal_target ! Sanity checks if (.not. handle % initialized) then @@ -1430,11 +1803,26 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write('Checking for unlimited dim') if (field_cursor % fieldhandle % has_unlimited_dim) then +#ifdef MPAS_PIO_SUPPORT #ifdef USE_PIO2 call PIO_setframe(handle % pio_file, field_cursor % fieldhandle % field_desc, handle % frame_number) #else call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number) #endif +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_set_frame(handle % smiol_file, int(handle % frame_number - 1, kind=SMIOL_offset_kind)) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_set_frame failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif + start1(1) = handle % frame_number count1(1) = 1 @@ -1448,36 +1836,74 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write(' value is real') if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleVal) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, singleVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, singleVal) end if +#endif + realVal = real(singleVal,RKIND) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleVal) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, doubleVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, doubleVal) end if +#endif + realVal = real(doubleVal,RKIND) else + realVal_p => realVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realVal_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) end if +#endif end if else if (present(intVal)) then ! call mpas_log_write(' value is int') + + intVal_p => intVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intVal_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, intVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, intVal) end if +#endif else if (present(charVal)) then ! call mpas_log_write(' value is char') + + charVal_p => charVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then count2(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar) @@ -1488,8 +1914,10 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar) charVal(1:count1(1)) = tempchar(1)(1:count1(1)) end if +#endif else if (present(charArray1d)) then ! call mpas_log_write(' value is char1') +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then ! Can only read one string at a time, since the sizes differ so much (i.e. StrLen != StrKIND) do i = 1, field_cursor % fieldhandle % dims(2) % dimsize @@ -1533,15 +1961,33 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr end do end do end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d char variables not yet implemented in SMIOL: '//trim(fieldname), messageType=MPAS_LOG_ERR) +#endif + else if (present(realArray1d)) then ! call mpas_log_write(' value is real1') if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray1d(size(realArray1d,1))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1553,6 +1999,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, singleArray1d) end if +#endif end if realArray1d(:) = real(singleArray1d(:),RKIND) deallocate(singleArray1d) @@ -1560,9 +2007,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray1d(size(realArray1d,1))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1574,14 +2033,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, doubleArray1d) end if +#endif end if realArray1d(:) = real(doubleArray1d(:),RKIND) deallocate(doubleArray1d) else + realArray1d_p => realArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1593,6 +2066,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, realArray1d) end if +#endif end if end if else if (present(realArray2d)) then @@ -1601,9 +2075,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray2d(size(realArray2d,1), size(realArray2d,2))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1617,6 +2103,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, singleArray2d) end if +#endif end if realArray2d(:,:) = real(singleArray2d(:,:),RKIND) deallocate(singleArray2d) @@ -1624,9 +2111,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray2d(size(realArray2d,1), size(realArray2d,2))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1640,14 +2139,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, doubleArray2d) end if +#endif end if realArray2d(:,:) = real(doubleArray2d(:,:),RKIND) deallocate(doubleArray2d) else + realArray2d_p => realArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1661,6 +2174,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, realArray2d) end if +#endif end if end if else if (present(realArray3d)) then @@ -1669,9 +2183,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray3d(size(realArray3d,1),size(realArray3d,2),size(realArray3d,3))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1687,6 +2213,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, singleArray3d) end if +#endif end if realArray3d(:,:,:) = real(singleArray3d(:,:,:),RKIND) deallocate(singleArray3d) @@ -1694,9 +2221,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray3d(size(realArray3d,1),size(realArray3d,2),size(realArray3d,3))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1712,14 +2251,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, doubleArray3d) end if +#endif end if realArray3d(:,:,:) = real(doubleArray3d(:,:,:),RKIND) deallocate(doubleArray3d) else + realArray3d_p => realArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1735,6 +2288,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, realArray3d) end if +#endif end if end if else if (present(realArray4d)) then @@ -1743,9 +2297,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray4d(size(realArray4d,1),size(realArray4d,2),size(realArray4d,3),size(realArray4d,4))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1763,6 +2329,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, singleArray4d) end if +#endif end if realArray4d(:,:,:,:) = real(singleArray4d(:,:,:,:),RKIND) deallocate(singleArray4d) @@ -1770,9 +2337,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray4d(size(realArray4d,1),size(realArray4d,2),size(realArray4d,3),size(realArray4d,4))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1790,14 +2369,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, doubleArray4d) end if +#endif end if realArray4d(:,:,:,:) = real(doubleArray4d(:,:,:,:),RKIND) deallocate(doubleArray4d) else + realArray4d_p => realArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1815,6 +2408,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, realArray4d) end if +#endif end if end if else if (present(realArray5d)) then @@ -1823,9 +2417,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray5d(size(realArray5d,1),size(realArray5d,2),size(realArray5d,3),size(realArray5d,4),size(realArray5d,5))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray5d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(:) = 1 start6(6) = handle % frame_number @@ -1845,6 +2451,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, singleArray5d) end if +#endif end if realArray5d(:,:,:,:,:) = real(singleArray5d(:,:,:,:,:),RKIND) deallocate(singleArray5d) @@ -1852,9 +2459,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray5d(size(realArray5d,1),size(realArray5d,2),size(realArray5d,3),size(realArray5d,4),size(realArray5d,5))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray5d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(:) = 1 start6(6) = handle % frame_number @@ -1874,14 +2493,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, doubleArray5d) end if +#endif end if realArray5d(:,:,:,:,:) = real(doubleArray5d(:,:,:,:,:),RKIND) deallocate(doubleArray5d) else + realArray5d_p => realArray5d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray5d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray5d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray5d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(:) = 1 start6(6) = handle % frame_number @@ -1901,14 +2534,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, realArray5d) end if +#endif end if end if else if (present(intArray1d)) then ! call mpas_log_write(' value is int1') + intArray1d_p => intArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1920,13 +2567,27 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, intArray1d) end if +#endif end if else if (present(intArray2d)) then ! call mpas_log_write(' value is int2') + intArray2d_p => intArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1940,13 +2601,27 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, intArray2d) end if +#endif end if else if (present(intArray3d)) then ! call mpas_log_write(' value is int3') + intArray3d_p => intArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1962,13 +2637,27 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, intArray3d) end if +#endif end if else if (present(intArray4d)) then ! call mpas_log_write(' value is int4') + intArray4d_p => intArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1986,14 +2675,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, intArray4d) end if +#endif end if end if ! call mpas_log_write('Checking for error') +#ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_get_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif end subroutine MPAS_io_get_var_generic @@ -2263,22 +2966,23 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr type (MPAS_IO_Handle_type), intent(inout) :: handle character (len=*), intent(in) :: fieldname - integer, intent(in), optional :: intVal - integer, dimension(:), intent(in), optional :: intArray1d - integer, dimension(:,:), intent(in), optional :: intArray2d - integer, dimension(:,:,:), intent(in), optional :: intArray3d - integer, dimension(:,:,:,:), intent(in), optional :: intArray4d - real (kind=RKIND), intent(in), optional :: realVal - real (kind=RKIND), dimension(:), intent(in), optional :: realArray1d - real (kind=RKIND), dimension(:,:), intent(in), optional :: realArray2d - real (kind=RKIND), dimension(:,:,:), intent(in), optional :: realArray3d - real (kind=RKIND), dimension(:,:,:,:), intent(in), optional :: realArray4d - real (kind=RKIND), dimension(:,:,:,:,:), intent(in), optional :: realArray5d - character (len=*), intent(in), optional :: charVal - character (len=*), dimension(:), intent(in), optional :: charArray1d + integer, intent(in), target, optional :: intVal + integer, dimension(:), intent(in), target, optional :: intArray1d + integer, dimension(:,:), intent(in), target, optional :: intArray2d + integer, dimension(:,:,:), intent(in), target, optional :: intArray3d + integer, dimension(:,:,:,:), intent(in), target, optional :: intArray4d + real (kind=RKIND), intent(in), target, optional :: realVal + real (kind=RKIND), dimension(:), intent(in), target, optional :: realArray1d + real (kind=RKIND), dimension(:,:), intent(in), target, optional :: realArray2d + real (kind=RKIND), dimension(:,:,:), intent(in), target, optional :: realArray3d + real (kind=RKIND), dimension(:,:,:,:), intent(in), target, optional :: realArray4d + real (kind=RKIND), dimension(:,:,:,:,:), intent(in), target, optional :: realArray5d + character (len=*), intent(in), target, optional :: charVal + character (len=*), dimension(:), intent(in), target, optional :: charArray1d integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer, dimension(1) :: start1 integer, dimension(1) :: count1 integer, dimension(2) :: start2 @@ -2295,19 +2999,44 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr integer :: i - real (kind=R4KIND) :: singleVal - real (kind=R4KIND), dimension(:), allocatable :: singleArray1d - real (kind=R4KIND), dimension(:,:), allocatable :: singleArray2d - real (kind=R4KIND), dimension(:,:,:), allocatable :: singleArray3d - real (kind=R4KIND), dimension(:,:,:,:), allocatable :: singleArray4d - real (kind=R4KIND), dimension(:,:,:,:,:), allocatable :: singleArray5d + real (kind=R4KIND), target :: singleVal_target + real (kind=R4KIND), pointer :: singleVal + real (kind=R4KIND), dimension(:), pointer :: singleArray1d + real (kind=R4KIND), dimension(:,:), pointer :: singleArray2d + real (kind=R4KIND), dimension(:,:,:), pointer :: singleArray3d + real (kind=R4KIND), dimension(:,:,:,:), pointer :: singleArray4d + real (kind=R4KIND), dimension(:,:,:,:,:), pointer :: singleArray5d + + real (kind=R8KIND), target :: doubleVal_target + real (kind=R8KIND), pointer :: doubleVal + real (kind=R8KIND), dimension(:), pointer :: doubleArray1d + real (kind=R8KIND), dimension(:,:), pointer :: doubleArray2d + real (kind=R8KIND), dimension(:,:,:), pointer :: doubleArray3d + real (kind=R8KIND), dimension(:,:,:,:), pointer :: doubleArray4d + real (kind=R8KIND), dimension(:,:,:,:,:), pointer :: doubleArray5d + + integer, pointer :: intVal_p + integer, dimension(:), pointer :: intArray1d_p + integer, dimension(:,:), pointer :: intArray2d_p + integer, dimension(:,:,:), pointer :: intArray3d_p + integer, dimension(:,:,:,:), pointer :: intArray4d_p + real (kind=RKIND), pointer :: realVal_p + real (kind=RKIND), dimension(:), pointer :: realArray1d_p + real (kind=RKIND), dimension(:,:), pointer :: realArray2d_p + real (kind=RKIND), dimension(:,:,:), pointer :: realArray3d_p + real (kind=RKIND), dimension(:,:,:,:), pointer :: realArray4d_p + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: realArray5d_p + character (len=:), pointer :: charVal_p + character (len=:), dimension(:), pointer :: charArray1d_p + +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_decomp), pointer :: null_decomp + + nullify(null_decomp) +#endif - real (kind=R8KIND) :: doubleVal - real (kind=R8KIND), dimension(:), allocatable :: doubleArray1d - real (kind=R8KIND), dimension(:,:), allocatable :: doubleArray2d - real (kind=R8KIND), dimension(:,:,:), allocatable :: doubleArray3d - real (kind=R8KIND), dimension(:,:,:,:), allocatable :: doubleArray4d - real (kind=R8KIND), dimension(:,:,:,:,:), allocatable :: doubleArray5d + singleVal => singleVal_target + doubleVal => doubleVal_target ! Sanity checks if (.not. handle % initialized) then @@ -2318,15 +3047,18 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr if (.not. handle % data_mode) then handle % data_mode = .true. +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_enddef(handle % pio_file) ! If we are working with a preexisting file, we likely didn't define ! new dimensions or variables, in which case PIO_enddef() will return ! an error under harmless circumstances; so, don't return only for ! pre-existing files. - if (pio_ierr /= PIO_noerr .and. (.not. handle % preexisting_file)) then + if (pio_ierr /= PIO_noerr .and. & + .not. (handle % external_file_desc .or. handle % preexisting_file)) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif end if ! call mpas_log_write('Writing '//trim(fieldname)) @@ -2348,11 +3080,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr if (field_cursor % fieldhandle % has_unlimited_dim) then +#ifdef MPAS_PIO_SUPPORT #ifdef USE_PIO2 call PIO_setframe(handle % pio_file, field_cursor % fieldhandle % field_desc, handle % frame_number) #else call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number) #endif +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_set_frame(handle % smiol_file, int(handle % frame_number - 1, kind=SMIOL_offset_kind)) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_set_frame failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif + start1(1) = handle % frame_number count1(1) = 1 @@ -2368,33 +3115,60 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then singleVal = real(realVal,R4KIND) +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, singleVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, singleVal) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleVal) +#endif else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then doubleVal = real(realVal,R8KIND) +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, doubleVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, doubleVal) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleVal) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) end if +#endif + + realVal_p => realVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realVal_p) +#endif end if else if (present(intVal)) then +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, intVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, intVal) end if +#endif + + intVal_p => intVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intVal_p) +#endif else if (present(charVal)) then +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then count2(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, charVal(1:count2(1))) @@ -2403,7 +3177,14 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, charVal(1:count1(1))) end if +#endif + + charVal_p => charVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) +#endif else if (present(charArray1d)) then +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then ! Write one string at a time because the sizes differ so much (i.e. StrLen != StrKIND) do i = 1, field_cursor % fieldhandle % dims(2) % dimsize @@ -2425,15 +3206,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, charArray1d(i)(1:count2(1))) end do end if +#endif +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d char variables not yet implemented in SMIOL: '//trim(fieldname), messageType=MPAS_LOG_ERR) +#endif else if (present(realArray1d)) then if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray1d(size(realArray1d))) singleArray1d(:) = real(realArray1d(:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray1d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2445,6 +3238,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, singleArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray1d) +#endif end if deallocate(singleArray1d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2452,9 +3250,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray1d(size(realArray1d))) doubleArray1d(:) = real(realArray1d(:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray1d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2466,13 +3272,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, doubleArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray1d) +#endif end if deallocate(doubleArray1d) else + realArray1d_p => realArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray1d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2484,6 +3304,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, realArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray1d_p) +#endif end if end if else if (present(realArray2d)) then @@ -2492,9 +3317,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray2d(size(realArray2d,1), size(realArray2d,2))) singleArray2d(:,:) = real(realArray2d(:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray2d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2509,6 +3342,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, singleArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray2d) +#endif end if deallocate(singleArray2d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2516,9 +3354,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray2d(size(realArray2d,1), size(realArray2d,2))) doubleArray2d(:,:) = real(realArray2d(:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray2d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2533,13 +3379,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, doubleArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray2d) +#endif end if deallocate(doubleArray2d) else + realArray2d_p => realArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray2d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2554,6 +3414,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, realArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray2d_p) +#endif end if end if else if (present(realArray3d)) then @@ -2562,9 +3427,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray3d(size(realArray3d,1), size(realArray3d,2), size(realArray3d,3))) singleArray3d(:,:,:) = real(realArray3d(:,:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray3d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2582,6 +3455,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, singleArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray3d) +#endif end if deallocate(singleArray3d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2589,9 +3467,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray3d(size(realArray3d,1), size(realArray3d,2), size(realArray3d,3))) doubleArray3d(:,:,:) = real(realArray3d(:,:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray3d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2609,13 +3495,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, doubleArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray3d) +#endif end if deallocate(doubleArray3d) else + realArray3d_p => realArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray3d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2633,6 +3533,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, realArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray3d_p) +#endif end if end if else if (present(realArray4d)) then @@ -2641,9 +3546,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray4d(size(realArray4d,1), size(realArray4d,2), size(realArray4d,3), size(realArray4d,4))) singleArray4d(:,:,:,:) = real(realArray4d(:,:,:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray4d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2664,6 +3577,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, singleArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray4d) +#endif end if deallocate(singleArray4d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2671,9 +3589,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray4d(size(realArray4d,1), size(realArray4d,2), size(realArray4d,3), size(realArray4d,4))) doubleArray4d(:,:,:,:) = real(realArray4d(:,:,:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray4d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2694,13 +3620,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, doubleArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray4d) +#endif end if deallocate(doubleArray4d) else + realArray4d_p => realArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray4d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2721,6 +3661,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, realArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray4d_p) +#endif end if end if else if (present(realArray5d)) then @@ -2729,9 +3674,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray5d(size(realArray5d,1), size(realArray5d,2), size(realArray5d,3), size(realArray5d,4), size(realArray5d,5))) singleArray5d(:,:,:,:,:) = real(realArray5d(:,:,:,:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray5d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray5d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(1) = 1 start6(2) = 1 @@ -2755,6 +3708,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, singleArray5d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray5d) +#endif end if deallocate(singleArray5d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2762,9 +3720,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray5d(size(realArray5d,1), size(realArray5d,2), size(realArray5d,3), size(realArray5d,4), size(realArray5d,5))) doubleArray5d(:,:,:,:,:) = real(realArray5d(:,:,:,:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray5d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray5d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(1) = 1 start6(2) = 1 @@ -2788,13 +3754,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, doubleArray5d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray5d) +#endif end if deallocate(doubleArray5d) else + realArray5d_p => realArray5d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray5d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray5d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(1) = 1 start6(2) = 1 @@ -2818,13 +3798,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, realArray5d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray5d_p) +#endif end if end if else if (present(intArray1d)) then + intArray1d_p => intArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray1d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2836,12 +3830,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, intArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray1d_p) +#endif end if else if (present(intArray2d)) then + intArray2d_p => intArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray2d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2856,12 +3864,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, intArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray2d_p) +#endif end if else if (present(intArray3d)) then + intArray3d_p => intArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray3d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2879,12 +3901,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, intArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray3d_p) +#endif end if else if (present(intArray4d)) then + intArray4d_p => intArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray4d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2905,12 +3941,29 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, intArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray4d_p) +#endif end if end if +#ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_put_var failed with error $i : '//trim(fieldname), intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif end subroutine MPAS_io_put_var_generic @@ -3147,6 +4200,7 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: xtype #ifdef USE_PIO2 @@ -3216,10 +4270,13 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if ! Query attribute value +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO @@ -3235,6 +4292,24 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), attValue) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), attValue) + end if + if (local_ierr /= SMIOL_SUCCESS) then + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE + return + else + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + return + end if + end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3305,6 +4380,9 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d integer attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif ! ! For variable attributes, find the structure for fieldname @@ -3357,10 +4435,13 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if ! Query attribute value +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO @@ -3384,6 +4465,7 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3437,6 +4519,7 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: local_precision real (kind=R4KIND) :: singleVal @@ -3509,7 +4592,9 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if if (present(precision)) then @@ -3519,45 +4604,93 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio end if ! Query attribute value +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif if ((local_precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then +#ifdef MPAS_PIO_SUPPORT if (xtype /= PIO_REAL) then if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE return end if pio_ierr = PIO_get_att(handle % pio_file, varid, attName, singleVal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), singleVal) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), singleVal) + end if +#endif + attValue = real(singleVal,RKIND) else if ((local_precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then +#ifdef MPAS_PIO_SUPPORT if (xtype /= PIO_DOUBLE) then if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE return end if pio_ierr = PIO_get_att(handle % pio_file, varid, attName, doubleVal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), doubleVal) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), doubleVal) + end if +#endif + attValue = real(doubleVal,RKIND) else +#ifdef MPAS_PIO_SUPPORT if (xtype /= PIO_DOUBLE .and. xtype /= PIO_REAL) then if (present(ierr)) ierr=MPAS_IO_ERR_WRONG_ATT_TYPE return end if pio_ierr = PIO_get_att(handle % pio_file, varid, attName, attValue) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), attValue) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), attValue) + end if +#endif end if +#ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE + return + else + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + return + end if + end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3633,6 +4766,9 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d real attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif ! ! For variable attributes, find the structure for fieldname @@ -3685,7 +4821,9 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if if (present(precision)) then @@ -3695,6 +4833,7 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio end if ! Query attribute value +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO @@ -3747,6 +4886,7 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3800,6 +4940,7 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: xtype #ifdef USE_PIO2 @@ -3869,10 +5010,13 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if ! Query attribute value +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_att(handle % pio_file, varid, attName, xtype, len) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO @@ -3888,6 +5032,24 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), attValue) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), attValue) + end if + if (local_ierr /= SMIOL_SUCCESS) then + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE + return + else + if (present(ierr)) ierr = MPAS_IO_ERR_PIO + return + end if + end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3940,6 +5102,7 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: attValueLocal type (fieldlist_type), pointer :: field_cursor @@ -4041,7 +5204,9 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4064,11 +5229,29 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, end if end if +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), attValueLocal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), attValueLocal) + end if + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_att failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif ! Maybe we should add attribute to list only after a successfull call to PIO? @@ -4112,6 +5295,9 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d integer attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif allocate(new_attlist_node) nullify(new_attlist_node % next) @@ -4198,7 +5384,9 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4221,11 +5409,13 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, end if end if +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif deallocate(attValueLocal) @@ -4247,6 +5437,7 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid real (kind=RKIND) :: attValueLocal real (kind=R4KIND) :: singleVal @@ -4355,7 +5546,9 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4381,19 +5574,61 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, if ((new_attlist_node % attHandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then singleVal = real(attValueLocal,R4KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, singleVal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), singleVal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), singleVal) + end if +#endif else if ((new_attlist_node % attHandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then doubleVal = real(attValueLocal,R8KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, doubleVal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), doubleVal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), doubleVal) + end if +#endif else +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), attValueLocal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), attValueLocal) + end if +#endif end if +#ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_att failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif ! Maybe we should add attribute to list only after a successfull call to PIO? @@ -4441,6 +5676,9 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d real attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif allocate(new_attlist_node) nullify(new_attlist_node % next) @@ -4532,7 +5770,9 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4559,21 +5799,29 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleVal(size(attValueLocal))) singleVal(:) = real(attValueLocal(:),R4KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, singleVal) +#endif deallocate(singleVal) else if ((new_attlist_node % attHandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleVal(size(attValueLocal))) doubleVal(:) = real(attValueLocal(:),R8KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, doubleVal) +#endif deallocate(doubleVal) else +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) +#endif end if +#ifdef MPAS_PIO_SUPPORT if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if +#endif deallocate(attValueLocal) @@ -4594,6 +5842,7 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: valLen character (len=StrKind) :: attValueLocal, trimmedVal @@ -4705,7 +5954,9 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4728,6 +5979,7 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i end if end if +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, trim(attValueLocal)) if (pio_ierr /= PIO_noerr) then @@ -4761,6 +6013,23 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), trim(attValueLocal)) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), trim(attValueLocal)) + end if + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_att failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif ! Maybe we should add attribute to list only after a successfull call to PIO? @@ -4805,6 +6074,8 @@ subroutine MPAS_io_sync(handle, ierr) type (MPAS_IO_Handle_type), intent(inout) :: handle integer, intent(out), optional :: ierr + integer :: local_ierr + ! call mpas_log_write('Called MPAS_io_sync()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -4814,7 +6085,21 @@ subroutine MPAS_io_sync(handle, ierr) return end if +#ifdef MPAS_PIO_SUPPORT call PIO_syncfile(handle % pio_file) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_sync_file(handle % smiol_file) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_sync_file failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif end subroutine MPAS_io_sync @@ -4826,6 +6111,8 @@ subroutine MPAS_io_close(handle, ierr) type (MPAS_IO_Handle_type), intent(inout) :: handle integer, intent(out), optional :: ierr + integer :: local_ierr + type (dimlist_type), pointer :: dimlist_ptr, dimlist_del type (fieldlist_type), pointer :: fieldlist_ptr, fieldlist_del type (attlist_type), pointer :: attlist_ptr, attlist_del @@ -4886,7 +6173,22 @@ subroutine MPAS_io_close(handle, ierr) handle % initialized = .false. !call mpas_log_write('MGD PIO_closefile') - call PIO_closefile(handle % pio_file) + if (.not. handle % external_file_desc) then +#ifdef MPAS_PIO_SUPPORT + call PIO_closefile(handle % pio_file) +#endif + end if +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_close_file(handle % smiol_file) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_close_file failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if + end if +#endif end subroutine MPAS_io_close @@ -4900,6 +6202,7 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr type (decomplist_type), pointer :: decomp_cursor, decomp_del ! call mpas_log_write('Called MPAS_io_finalize()') @@ -4913,7 +6216,15 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) !if (.not. associated(decomp_del % decomphandle)) call mpas_log_write('OOPS... do not have decomphandle') deallocate(decomp_del % decomphandle % dims) deallocate(decomp_del % decomphandle % indices) +#ifdef MPAS_PIO_SUPPORT call PIO_freedecomp(ioContext % pio_iosystem, decomp_del % decomphandle % pio_iodesc) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_free_decomp(decomp_del % decomphandle % smiol_decomp) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_free_decomp failed with code $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + end if +#endif deallocate(decomp_del % decomphandle) deallocate(decomp_del) end do @@ -4921,12 +6232,20 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) !call mpas_log_write('MGD PIO_finalize') if (present(finalize_iosystem)) then if ( finalize_iosystem ) then +#ifdef MPAS_PIO_SUPPORT call PIO_finalize(ioContext % pio_iosystem, pio_ierr) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_PIO return end if deallocate(ioContext % pio_iosystem) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_finalize(ioContext % smiol_context) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_free_decomp failed with code $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + end if +#endif end if end if diff --git a/src/framework/mpas_io_streams.F b/src/framework/mpas_io_streams.F index 745534a319..82665d243e 100644 --- a/src/framework/mpas_io_streams.F +++ b/src/framework/mpas_io_streams.F @@ -78,7 +78,7 @@ module mpas_io_streams subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, precision, & - clobberRecords, clobberFiles, truncateFiles, ierr) + clobberRecords, clobberFiles, truncateFiles, pio_file_desc, ierr) implicit none @@ -91,6 +91,11 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, logical, intent(in), optional :: clobberRecords logical, intent(in), optional :: clobberFiles logical, intent(in), optional :: truncateFiles +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, optional :: pio_file_desc +#endif integer, intent(out), optional :: ierr integer :: io_err @@ -99,7 +104,7 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, stream % fileHandle = MPAS_io_open(fileName, ioDirection, ioFormat, ioContext, clobber_file=clobberFiles, truncate_file=truncateFiles, & - ierr=io_err) + pio_file_desc=pio_file_desc, ierr=io_err) ! ! Catch a few special errors ! diff --git a/src/framework/mpas_io_types.inc b/src/framework/mpas_io_types.inc index 6cb61723e6..e648b234ef 100644 --- a/src/framework/mpas_io_types.inc +++ b/src/framework/mpas_io_types.inc @@ -1,9 +1,19 @@ +#ifdef MPAS_PIO_SUPPORT #ifdef USE_PIO2 integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET_KIND #else integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET #endif +#else + +#ifdef MPAS_SMIOL_SUPPORT + integer, parameter :: MPAS_IO_OFFSET_KIND = SMIOL_offset_kind +#else + integer, parameter :: MPAS_IO_OFFSET_KIND = I8KIND +#endif +#endif + ! File access modes integer, parameter :: MPAS_IO_READ = 1, & MPAS_IO_WRITE = 2 @@ -61,7 +71,13 @@ logical :: initialized = .false. logical :: preexisting_file = .false. logical :: data_mode = .false. + logical :: external_file_desc = .false. +#ifdef MPAS_PIO_SUPPORT type (file_desc_t) :: pio_file +#endif +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_file), pointer :: smiol_file => null() +#endif character (len=StrKIND) :: filename integer :: iomode integer :: ioformat @@ -81,7 +97,12 @@ integer :: field_type integer, dimension(:), pointer :: dims integer, dimension(:), pointer :: indices +#ifdef MPAS_PIO_SUPPORT type (io_desc_t) :: pio_iodesc +#endif +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_decomp), pointer :: smiol_decomp => null() +#endif end type decomphandle_type type atthandle_type @@ -105,7 +126,9 @@ type fieldhandle_type character (len=StrKIND) :: fieldname integer :: fieldid +#ifdef MPAS_PIO_SUPPORT type (Var_desc_t) :: field_desc +#endif integer :: field_type logical :: has_unlimited_dim = .false. integer :: ndims @@ -138,7 +161,12 @@ type mpas_io_context_type type (decomplist_type), pointer :: decomp_list => null() +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), pointer :: pio_iosystem => null() +#endif +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_context), pointer :: smiol_context => null() +#endif integer :: master_pio_iotype = -999 type (dm_info), pointer :: dminfo => null() end type mpas_io_context_type diff --git a/src/framework/mpas_io_units.F b/src/framework/mpas_io_units.F index 579c8ffc23..acd3403b03 100644 --- a/src/framework/mpas_io_units.F +++ b/src/framework/mpas_io_units.F @@ -21,8 +21,19 @@ module mpas_io_units use mpas_kind_types - integer, parameter, private :: maxUnits = 99 - logical, dimension(0:maxUnits), private, save :: unitsInUse + implicit none + + private + + integer, parameter :: maxUnits = 200 + logical, dimension(0:maxUnits), save :: unitsInUse + + ! Units reserved for unformatted I/O + integer, parameter :: unformatted_min = 101 + integer, parameter :: unformatted_max = maxUnits + + public :: mpas_new_unit, & + mpas_release_unit contains @@ -38,14 +49,30 @@ module mpas_io_units !> the unit number ! !----------------------------------------------------------------------- - subroutine mpas_new_unit(newUnit)!{{{ + subroutine mpas_new_unit(newUnit, unformatted)!{{{ + integer, intent(inout) :: newUnit + logical, optional, intent(in) :: unformatted - integer :: i + integer :: i, minsearch, maxsearch logical :: opened - do i = 1, maxUnits + newUnit = -1 + + ! + ! Determine the range over which to search for an unused unit + ! + minsearch = 1 + maxsearch = unformatted_min - 1 + if ( present(unformatted) ) then + if ( unformatted ) then + minsearch = unformatted_min + maxsearch = unformatted_max + end if + end if + + do i = minsearch, maxsearch if (.not. unitsInUse(i)) then inquire(i, opened=opened) if (opened) then @@ -72,9 +99,12 @@ end subroutine mpas_new_unit!}}} ! !----------------------------------------------------------------------- subroutine mpas_release_unit(releasedUnit)!{{{ + integer, intent(in) :: releasedUnit - unitsInUse(releasedUnit) = .false. + if (0 <= releasedUnit .and. releasedUnit <= maxUnits) then + unitsInUse(releasedUnit) = .false. + end if end subroutine mpas_release_unit!}}} diff --git a/src/framework/mpas_log.F b/src/framework/mpas_log.F index 6950341a14..08404ca4c0 100644 --- a/src/framework/mpas_log.F +++ b/src/framework/mpas_log.F @@ -41,6 +41,7 @@ module mpas_log use mpas_derived_types use mpas_abort, only : mpas_dmpar_global_abort + use mpas_io_units, only : mpas_new_unit, mpas_release_unit implicit none private @@ -97,8 +98,6 @@ module mpas_log subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) - use mpas_io_units - !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- @@ -120,6 +119,7 @@ subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) ! local variables !----------------------------------------------------------------- character(len=16) :: taskString !< variable to build the task number as a string with appropriate zero padding + character(len=4) :: domainString !< variable to store the domain number as a string with appropriate zero padding integer :: unitNumber !< local variable used to get a unit number character(len=strKind) :: proposedLogFileName, proposedErrFileName logical :: isOpen @@ -176,6 +176,10 @@ subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) mpas_log_info % taskID = domain % dminfo % my_proc_id mpas_log_info % nTasks = domain % dminfo % nprocs + ! Store the domain number + ! This will be used to number the log files + mpas_log_info % domainID = domain % domainID + ! Set log file to be active or not based on master/nonmaster task and optimized/debug build ! * Optimized build: Only master task log is active ! * Debug build: All tasks active @@ -207,8 +211,17 @@ subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) else write(taskString, '(i9.9)') mpas_log_info % taskID end if - write(proposedLogFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".out" - write(proposedErrFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".err" + + if ( mpas_log_info % domainID > 0 ) then + write(domainString, '(i4.4)') mpas_log_info % domainID + write(proposedLogFileName, fmt='(a, a, a, a, a, a, a)') & + "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".d", trim(domainString), ".out" + write(proposedErrFileName, fmt='(a, a, a, a, a, a, a)') & + "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".d", trim(domainString), ".err" + else + write(proposedLogFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".out" + write(proposedErrFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".err" + end if ! Set the log and err file names and unit numbers if (present(unitNumbers)) then @@ -420,6 +433,9 @@ subroutine mpas_log_open(openErrorFile, err) write(unitNumber, '(a)') '----------------------------------------------------------------------' write(unitNumber, '(a,a,a,a,a,i7.1,a,i7.1)') 'Beginning MPAS-', trim(mpas_log_info % coreName), ' ', & trim(logTypeString), ' Log File for task ', mpas_log_info % taskID, ' of ', mpas_log_info % nTasks + if ( mpas_log_info % domainID > 0 ) then + write(unitNumber, '(a,i7.1)') ' for domain ID ', mpas_log_info % domainID + end if call date_and_time(date,time) write(unitNumber, '(a)') ' Opened at ' // date(1:4)//'/'//date(5:6)//'/'//date(7:8) // & ' ' // time(1:2)//':'//time(3:4)//':'//time(5:6) @@ -694,6 +710,7 @@ subroutine mpas_log_finalize(err) ! 2) the log mgr opened the file (otherwise the driver that opened it should close it) if (mpas_log_info % outputLog % isActive .and. mpas_log_info % outputLog % openedByLogModule) then close(mpas_log_info % outputLog % unitNum, iostat = err) + call mpas_release_unit(mpas_log_info % outputLog % unitNum) endif ! Note: should not need to close an err file. If these are open, they are intended to quickly lead to abort @@ -823,6 +840,7 @@ subroutine log_abort() ! Close the err log to be clean close(mpas_log_info % errorLog % unitNum) + call mpas_release_unit(mpas_log_info % errorLog % unitNum) deallocate(mpas_log_info % errorLog) deallocate(mpas_log_info % outputLog) diff --git a/src/framework/mpas_log_types.inc b/src/framework/mpas_log_types.inc index 28c018be17..34ba091a56 100644 --- a/src/framework/mpas_log_types.inc +++ b/src/framework/mpas_log_types.inc @@ -27,6 +27,7 @@ integer :: nTasks !< number of total tasks associated with this instance !< (stored here to eliminate the need for dminfo later) character(len=StrKIND) :: coreName !< name of the core to which this log manager instance belongs + integer :: domainID !< domain number for this instance of the log manager integer :: outputMessageCount !< counter for number of output messages printed during the run integer :: warningMessageCount !< counter for number of warning messages printed during the run diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index c362c770d8..aab1818c30 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -209,7 +209,7 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ integer :: i, j type (mpas_pool_member_type), pointer :: ptr type (mpas_pool_data_type), pointer :: dptr - integer :: local_err, threadNum + integer :: threadNum threadNum = mpas_threading_get_thread_num() @@ -224,9 +224,9 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ if (ptr % contentsType == MPAS_POOL_DIMENSION) then if (ptr % data % contentsDims > 0) then - deallocate(ptr % data % simple_int_arr, stat=local_err) + deallocate(ptr % data % simple_int_arr) else - deallocate(ptr % data % simple_int, stat=local_err) + deallocate(ptr % data % simple_int) end if else if (ptr % contentsType == MPAS_POOL_CONFIG) then @@ -234,13 +234,13 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ dptr => ptr % data if (dptr % contentsType == MPAS_POOL_REAL) then - deallocate(dptr % simple_real, stat=local_err) + deallocate(dptr % simple_real) else if (dptr % contentsType == MPAS_POOL_INTEGER) then - deallocate(dptr % simple_int, stat=local_err) + deallocate(dptr % simple_int) else if (dptr % contentsType == MPAS_POOL_CHARACTER) then - deallocate(dptr % simple_char, stat=local_err) + deallocate(dptr % simple_char) else if (dptr % contentsType == MPAS_POOL_LOGICAL) then - deallocate(dptr % simple_logical, stat=local_err) + deallocate(dptr % simple_logical) end if else if (ptr % contentsType == MPAS_POOL_FIELD) then @@ -249,138 +249,96 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ ! Do this through brute force... if (associated(dptr % r0)) then - deallocate(dptr % r0, stat=local_err) + call mpas_deallocate_field(dptr % r0) else if (associated(dptr % r1)) then - if (associated(dptr % r1 % array)) then - deallocate(dptr % r1 % array, stat=local_err) - end if - - deallocate(dptr % r1, stat=local_err) + call mpas_deallocate_field(dptr % r1) else if (associated(dptr % r2)) then - if (associated(dptr % r2 % array)) then - deallocate(dptr % r2 % array, stat=local_err) - end if - - deallocate(dptr % r2, stat=local_err) + call mpas_deallocate_field(dptr % r2) else if (associated(dptr % r3)) then - if (associated(dptr % r3 % array)) then - deallocate(dptr % r3 % array, stat=local_err) - end if - - deallocate(dptr % r3, stat=local_err) + call mpas_deallocate_field(dptr % r3) else if (associated(dptr % r4)) then - if (associated(dptr % r4 % array)) then - deallocate(dptr % r4 % array, stat=local_err) - end if - - deallocate(dptr % r4, stat=local_err) + call mpas_deallocate_field(dptr % r4) else if (associated(dptr % r5)) then - if (associated(dptr % r5 % array)) then - deallocate(dptr % r5 % array, stat=local_err) - end if - - deallocate(dptr % r5, stat=local_err) + call mpas_deallocate_field(dptr % r5) else if (associated(dptr % i0)) then - deallocate(dptr % i0, stat=local_err) + call mpas_deallocate_field(dptr % i0) else if (associated(dptr % i1)) then - if (associated(dptr % i1 % array)) then - deallocate(dptr % i1 % array, stat=local_err) - end if - - deallocate(dptr % i1, stat=local_err) + call mpas_deallocate_field(dptr % i1) else if (associated(dptr % i2)) then - if (associated(dptr % i2 % array)) then - deallocate(dptr % i2 % array, stat=local_err) - end if - - deallocate(dptr % i2, stat=local_err) + call mpas_deallocate_field(dptr % i2) else if (associated(dptr % i3)) then - if (associated(dptr % i3 % array)) then - deallocate(dptr % i3 % array, stat=local_err) - end if - - deallocate(dptr % i3, stat=local_err) + call mpas_deallocate_field(dptr % i3) else if (associated(dptr % c0)) then - deallocate(dptr % c0, stat=local_err) + call mpas_deallocate_field(dptr % c0) else if (associated(dptr % c1)) then - if (associated(dptr % c1 % array)) then - deallocate(dptr % c1 % array, stat=local_err) - end if - - deallocate(dptr % c1, stat=local_err) + call mpas_deallocate_field(dptr % c1) else if (associated(dptr % l0)) then - deallocate(dptr % l0, stat=local_err) + call mpas_deallocate_field(dptr % l0) else if (associated(dptr % r0a)) then - deallocate(dptr % r0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % r0a(j)) + end do + deallocate(dptr % r0a) else if (associated(dptr % r1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r1a(j) % array)) then - deallocate(dptr % r1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r1a(j)) end do - deallocate(dptr % r1a, stat=local_err) + deallocate(dptr % r1a) else if (associated(dptr % r2a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r2a(j) % array)) then - deallocate(dptr % r2a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r2a(j)) end do - deallocate(dptr % r2a, stat=local_err) + deallocate(dptr % r2a) else if (associated(dptr % r3a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r3a(j) % array)) then - deallocate(dptr % r3a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r3a(j)) end do - deallocate(dptr % r3a, stat=local_err) + deallocate(dptr % r3a) else if (associated(dptr % r4a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r4a(j) % array)) then - deallocate(dptr % r4a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r4a(j)) end do - deallocate(dptr % r4a, stat=local_err) + deallocate(dptr % r4a) else if (associated(dptr % r5a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r5a(j) % array)) then - deallocate(dptr % r5a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r5a(j)) end do - deallocate(dptr % r5a, stat=local_err) + deallocate(dptr % r5a) else if (associated(dptr % i0a)) then - deallocate(dptr % i0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % i0a(j)) + end do + deallocate(dptr % i0a) else if (associated(dptr % i1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i1a(j) % array)) then - deallocate(dptr % i1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % i1a(j)) end do - deallocate(dptr % i1a, stat=local_err) + deallocate(dptr % i1a) else if (associated(dptr % i2a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i2a(j) % array)) then - deallocate(dptr % i2a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % i2a(j)) end do - deallocate(dptr % i2a, stat=local_err) + deallocate(dptr % i2a) else if (associated(dptr % i3a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i3a(j) % array)) then - deallocate(dptr % i3a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % i3a(j)) end do - deallocate(dptr % i3a, stat=local_err) + deallocate(dptr % i3a) else if (associated(dptr % c0a)) then - deallocate(dptr % c0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % c0a(j)) + end do + deallocate(dptr % c0a) else if (associated(dptr % c1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % c1a(j) % array)) then - deallocate(dptr % c1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % c1a(j)) end do - deallocate(dptr % c1a, stat=local_err) + deallocate(dptr % c1a) else if (associated(dptr % l0a)) then - deallocate(dptr % l0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % l0a(j)) + end do + deallocate(dptr % l0a) else call pool_mesg('While destroying pool, member '//trim(ptr % key)//' has no valid field pointers.') end if @@ -390,14 +348,14 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ call mpas_pool_destroy_pool(ptr % data % p) end if - deallocate(ptr % data, stat=local_err) - deallocate(ptr, stat=local_err) + deallocate(ptr % data) + deallocate(ptr) end do end do - deallocate(inPool % table, stat=local_err) - deallocate(inPool, stat=local_err) + deallocate(inPool % table) + deallocate(inPool) end if end subroutine mpas_pool_destroy_pool!}}} @@ -1861,7 +1819,7 @@ recursive subroutine mpas_pool_link_parinfo(block, inPool)!{{{ end if else if (poolItr % nDims == 4) then if (poolItr % nTimeLevels > 1) then - decompType = pool_get_member_decomp_type(poolMem % r4 % dimNames(4)) + decompType = pool_get_member_decomp_type(poolMem % r4a(1) % dimNames(4)) if (decompType == MPAS_DECOMP_CELLS) then do i = 1, poolItr % nTimeLevels @@ -5142,7 +5100,7 @@ subroutine mpas_pool_add_subpool(inPool, key, subPool)!{{{ type (mpas_pool_type), intent(inout) :: inPool character (len=*), intent(in) :: key - type (mpas_pool_type), intent(in), target :: subPool + type (mpas_pool_type), pointer :: subPool type (mpas_pool_member_type), pointer :: newmem diff --git a/src/framework/mpas_stream_manager.F b/src/framework/mpas_stream_manager.F index 757327dbef..0276d34653 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -47,6 +47,23 @@ module mpas_stream_manager MPAS_get_stream_filename, & MPAS_build_stream_filename + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! IMPORTANT NOTE for {pre,post}write_reindex + ! + ! Caution is needed if calling the {pre,post}write_reindex routines directly + ! from outside of the stream manager. These two routines make use of module + ! state to save and retrieve pointers to the original indexing arrays. Problems + ! can arise, for example, if external code calls prewrite_reindex, then makes + ! a call to write output streams via the stream manager: in this case, pointers + ! set by the external call to prewrite_reindex will be overwritten by the + ! internal call to prewrite_reindex within mpas_stream_mgr_write. + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + public :: prewrite_reindex, & ! Please see note above... + postwrite_reindex, & ! Please see note above... + postread_reindex + private interface MPAS_stream_mgr_set_property @@ -4814,6 +4831,10 @@ end function is_decomposed_dim !}}} !> indexed fields in module variables *_save, and allocate new arrays for !> the fields, which are set to contain global indices. !> This routine should be called immediately before a write of a stream. + !> + !> IMPORTANT NOTE: Before calling this routine from outside of the stream + !> manager module, please read the "IMPORTANT NOTE" near + !> the top of this module where this routine is made public. ! !----------------------------------------------------------------------- subroutine prewrite_reindex(allFields, streamFields) !{{{ @@ -5113,6 +5134,10 @@ end subroutine prewrite_reindex !}}} !> !> NB: Even if the write of a stream fails, it is important to stil call !> this routine to reset the connectivity fields to contain local indices. + !> + !> IMPORTANT NOTE: Before calling this routine from outside of the stream + !> manager module, please read the "IMPORTANT NOTE" near + !> the top of this module where this routine is made public. ! !----------------------------------------------------------------------- subroutine postwrite_reindex(allFields, streamFields) !{{{ diff --git a/src/framework/mpas_timekeeping.F b/src/framework/mpas_timekeeping.F index c6de8f0aed..14a001039f 100644 --- a/src/framework/mpas_timekeeping.F +++ b/src/framework/mpas_timekeeping.F @@ -14,12 +14,6 @@ module mpas_timekeeping use mpas_log use ESMF - use ESMF_BaseMod - use ESMF_Stubs - use ESMF_CalendarMod - use ESMF_ClockMod - use ESMF_TimeMod - use ESMF_TimeIntervalMod private :: mpas_calibrate_alarms private :: mpas_in_ringing_envelope @@ -98,18 +92,31 @@ subroutine mpas_timekeeping_init(calendar) if (trim(calendar) == 'gregorian') then TheCalendar = MPAS_GREGORIAN #ifndef MPAS_NO_ESMF_INIT +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_GREGORIAN) +#else + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_GREGORIAN) +#endif #endif else if (trim(calendar) == 'gregorian_noleap') then TheCalendar = MPAS_GREGORIAN_NOLEAP #ifndef MPAS_NO_ESMF_INIT +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_NOLEAP) +#else + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_NOLEAP) +#endif #endif -! else if (trim(calendar) == '360day') then -! TheCalendar = MPAS_360DAY -!#ifndef MPAS_NO_ESMF_INIT + else if (trim(calendar) == '360day') then + TheCalendar = MPAS_360DAY +#ifndef MPAS_NO_ESMF_INIT +#ifndef MPAS_EXTERNAL_ESMF_LIB ! call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_360DAY) -!#endif + call mpas_log_write('mpas_timekeeping_init: 360-day calendar not supported with the built-in ESMF timekeeping library', MPAS_LOG_ERR) +#else + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_360DAY) +#endif +#endif else call mpas_log_write('mpas_timekeeping_init: Invalid calendar type', MPAS_LOG_ERR) end if @@ -153,7 +160,14 @@ subroutine mpas_timekeeping_set_year_width(yearWidthIn)!{{{ yearWidth = yearWidthIn + ! + ! The external ESMF library does not provide the ESMF_setYearWidth subroutine, + ! though this may not be a problem, since the library appears to return time strings + ! with as many digits as are needed to represent the year. + ! +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_setYearWidth(yearWidthIn) +#endif end subroutine mpas_timekeeping_set_year_width!}}} @@ -1291,9 +1305,28 @@ subroutine mpas_get_time(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTi character (len=StrKIND), intent(out), optional :: dateTimeString integer, intent(out), optional :: ierr + integer :: idx + call ESMF_TimeGet(curr_time % t, YY=YYYY, MM=MM, DD=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr) call ESMF_TimeGet(curr_time % t, dayOfYear=DoY, rc=ierr) +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_TimeGet(curr_time % t, timeString=dateTimeString, rc=ierr) +#else + call ESMF_TimeGet(curr_time % t, timeStringISOFrac=dateTimeString, rc=ierr) +#endif + + ! + ! In case an external ESMF library that returns ISO timestamps is being used, + ! convert a 'T' (if it exists in the string) to an '_' to match the format + ! used throughout MPAS + ! + if (present(dateTimeString)) then + idx = index(dateTimeString, 'T') + if (idx > 0) then + dateTimeString(idx:idx) = '_' + end if + end if + if (present(ierr)) then if (ierr == ESMF_SUCCESS) ierr = 0 end if @@ -1334,6 +1367,9 @@ subroutine mpas_set_timeInterval(interval, YY, MM, DD, H, M, S, S_n, S_d, S_i8, character (len=StrKIND) :: timeSubString character (len=StrKIND) :: secDecSubString character(len=StrKIND), pointer, dimension(:) :: subStrings + character(len=16) :: fmtString + integer :: iwidth + integer :: idecimals ! if (present(DD)) then ! days = DD @@ -1403,8 +1439,29 @@ subroutine mpas_set_timeInterval(interval, YY, MM, DD, H, M, S, S_n, S_d, S_i8, if (present(timeString) .or. present(dt)) then - if(present(dt)) then - write (timeString_,*) "00:00:", dt + if (present(dt)) then + ! + ! Before writing dt into a timeString, first construct an appropriate format string + ! + + ! Number of decimal places of precision (9 = nanosecond precision) + idecimals = 9 + + ! Scale total width of representation based on max(log10(dt),0.0) + ! (+2 for at least a leading zero and a '.') + if (dt /= 0.0_RKIND) then + iwidth = int(max(log10(abs(dt)),0.0_RKIND)) + idecimals + 2 + else + iwidth = idecimals + 2 + end if + + ! Add an extra character for a minus sign if needed + if (dt < 0.0_RKIND) then + iwidth = iwidth + 1 + end if + + write(fmtString, '(a,i2.2,a,i2.2,a)') '(a,f', iwidth, '.', idecimals, ')' + write(timeString_,trim(fmtString)) '00:00:', dt else timeString_ = timeString end if @@ -1544,21 +1601,38 @@ subroutine mpas_get_timeInterval(interval, StartTimeIn, DD, H, M, S, S_n, S_d, S real (kind=RKIND), intent(out), optional :: dt integer, intent(out), optional :: ierr - integer :: days, sn, sd + integer :: days, sn, sd, hours, minutes integer (kind=I8KIND) :: seconds + real (kind=R8KIND) :: seconds_real + character (len=1) :: neg + integer :: local_ierr if (present(StartTimeIn)) then call ESMF_TimeIntervalGet(interval % ti, StartTimeIn=StartTimeIn%t, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=ierr) else +#ifndef MPAS_EXTERNAL_ESMF_LIB if ( interval % ti % YR /= 0 .or. interval % ti % MM /= 0 ) then if (present(ierr)) ierr = 1 call mpas_log_write('mpas_get_timeInterval cannnot return time interval information for an interval containing ' // & 'months and years without a startTimeIn argument.', MPAS_LOG_ERR) return end if - call ESMF_TimeIntervalGet(interval % ti, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=ierr) +#endif + call ESMF_TimeIntervalGet(interval % ti, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=local_ierr) + if (present(ierr)) ierr = local_ierr +#ifdef MPAS_EXTERNAL_ESMF_LIB + ! + ! With an external ESMF library, treat the time interval type as opaque, and just + ! assume that a non-success error code will be returned if the interval cannot be retrieved. + ! + if (local_ierr /= ESMF_SUCCESS) then + call mpas_log_write('mpas_get_timeInterval cannnot return time interval information for an interval containing ' // & + 'months and years without a startTimeIn argument.', MPAS_LOG_ERR) + return + end if +#endif endif if (sd == 0) then ! may only occur if (sn == 0)? @@ -1606,7 +1680,31 @@ subroutine mpas_get_timeInterval(interval, StartTimeIn, DD, H, M, S, S_n, S_d, S end if if (present(timeString)) then +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_TimeIntervalGet(interval % ti, timeString=timeString, rc=ierr) +#else + ! + ! In case an external ESMF library is being used, the time interval may be returned in + ! ISO period format, in which case it is easier to build a time interval string in MPAS + ! format given days, hours, minutes, and seconds. + ! + call ESMF_TimeIntervalGet(interval % ti, StartTimeIn=StartTimeIn%t, & + d=days, h=hours, m=minutes, s_i8=seconds, sN=sn, sD=sd, rc=ierr) + seconds_real = real(seconds,kind=R8KIND) + (real(sn, kind=R8KIND) / real(sd, kind=R8KIND)) + + ! + ! If the time interval is negative, the ESMF library will return negative values for + ! non-zero components of the interval, so days, hours, minutes, and seconds_real must + ! be checked in order to determine whether a '-' needs to be prepended to the timeString + ! + neg = '' + if (days < 0 .or. hours < 0 .or. minutes < 0 .or. seconds_real < 0.0_R8KIND) then + neg = '-' + end if + + write(timeString,'(a,i9.9,a,i2.2,a,i2.2,a,i2.2,f10.9)') trim(neg), abs(days), '_', abs(hours), ':', abs(minutes), ':', & + int(abs(seconds_real)), abs(seconds_real) - int(abs(seconds_real)) +#endif end if if (present(ierr)) then @@ -1692,7 +1790,21 @@ type (MPAS_TimeInterval_type) function mul_ti_n8(ti, n8) type (MPAS_TimeInterval_type), intent(in) :: ti integer (kind=I8KIND), intent(in) :: n8 +#ifndef MPAS_EXTERNAL_ESMF_LIB mul_ti_n8 % ti = ti % ti * n8 +#else + ! + ! At present, the external ESMF library does not support multiplying a time interval + ! by an 8-byte integer, so we convert to a 4-byte integer whenever possible. + ! However, if the value of the 8-byte integer exceeds what can be represented by + ! a 4-byte integer, stop with a critical error. + ! + if (n8 > huge(int(n8)) .or. n8 < -huge(int(n8))) then + call mpas_log_write('(time interval) * 64-bit integer: integer out of range for external ESMF library', & + messageType=MPAS_LOG_CRIT) + end if + mul_ti_n8 % ti = ti % ti * int(n8) +#endif end function mul_ti_n8 @@ -2154,7 +2266,7 @@ subroutine mpas_expand_string(timeStamp, blockID, inString, outString)!{{{ call mpas_set_time(curTime, dateTimeString=timeStamp) - call mpas_get_time(curTime, YYYY=year) + call mpas_get_time(curTime, YYYY=year, MM=month, DD=day, H=hour, M=minute, S=second) write(yearFormat, '(a,i10,a)') '(i0.',yearWidth,')' @@ -2170,15 +2282,12 @@ subroutine mpas_expand_string(timeStamp, blockID, inString, outString)!{{{ if (charExpand) then select case (inString(i:i)) case ('Y') - call mpas_get_time(curTime, YYYY=year) write(timePart, yearFormat) year outString = trim(outString) // trim(timePart) case ('M') - call mpas_get_time(curTime, MM=month) write(timePart, '(i0.2)') month outString = trim(outString) // trim(timePart) case ('D') - call mpas_get_time(curTime, DD=day) write(timePart, '(i0.2)') day outString = trim(outString) // trim(timePart) case ('d') @@ -2186,21 +2295,15 @@ subroutine mpas_expand_string(timeStamp, blockID, inString, outString)!{{{ write(timePart, '(i0.3)') DoY outString = trim(outString) // trim(timePart) case ('h') - call mpas_get_time(curTime, H=hour) write(timePart, '(i0.2)') hour outString = trim(outString) // trim(timePart) case ('m') - call mpas_get_time(curTime, M=minute) write(timePart, '(i0.2)') minute outString = trim(outString) // trim(timePart) case ('s') - call mpas_get_time(curTime, S=second) write(timePart, '(i0.2)') second outString = trim(outString) // trim(timePart) case ('S') - call mpas_get_time(curTime, H=hour) - call mpas_get_time(curTime, M=minute) - call mpas_get_time(curTime, S=second) second = second + 60 * minute + 3600 * hour write(timePart, '(i0.5)') second outString = trim(outString) // trim(timePart) diff --git a/src/operators/mpas_geometry_utils.F b/src/operators/mpas_geometry_utils.F index 7ec62be6cb..ba9d49522a 100644 --- a/src/operators/mpas_geometry_utils.F +++ b/src/operators/mpas_geometry_utils.F @@ -1728,4 +1728,142 @@ subroutine mpas_spherical_linear_interp(pInterp, p0, p1, alpha) !{{{ end subroutine mpas_spherical_linear_interp !}}} + +!----------------------------------------------------------------------- +! routine mpas_rotate_about_vector +! +!> \brief Rotates a point about a vector in R3 +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Rotates the point (x,y,z) through an angle theta about the vector +!> originating at (a, b, c) and having direction (u, v, w). +! +!> Reference: https://sites.google.com/site/glennmurray/Home/rotation-matrices-and-formulas/rotation-about-an-arbitrary-axis-in-3-dimensions +! +!----------------------------------------------------------------------- + subroutine mpas_rotate_about_vector(x, y, z, theta, a, b, c, u, v, w, xp, yp, zp) + + implicit none + + real (kind=RKIND), intent(in) :: x, y, z, theta, a, b, c, u, v, w + real (kind=RKIND), intent(out) :: xp, yp, zp + + real (kind=RKIND) :: vw2, uw2, uv2 + real (kind=RKIND) :: m + + vw2 = v**2.0 + w**2.0 + uw2 = u**2.0 + w**2.0 + uv2 = u**2.0 + v**2.0 + m = sqrt(u**2.0 + v**2.0 + w**2.0) + + xp = (a*vw2 + u*(-b*v-c*w+u*x+v*y+w*z) + ((x-a)*vw2+u*(b*v+c*w-v*y-w*z))*cos(theta) + m*(-c*v+b*w-w*y+v*z)*sin(theta))/m**2.0 + yp = (b*uw2 + v*(-a*u-c*w+u*x+v*y+w*z) + ((y-b)*uw2+v*(a*u+c*w-u*x-w*z))*cos(theta) + m*( c*u-a*w+w*x-u*z)*sin(theta))/m**2.0 + zp = (c*uv2 + w*(-a*u-b*v+u*x+v*y+w*z) + ((z-c)*uv2+w*(a*u+b*v-u*x-v*y))*cos(theta) + m*(-b*u+a*v-v*x+u*y)*sin(theta))/m**2.0 + + end subroutine mpas_rotate_about_vector + + +!----------------------------------------------------------------------- +! routine mpas_mirror_point +! +!> \brief Finds the "mirror" of a point about a great-circle arc +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Given the endpoints of a great-circle arc (A,B) and a point, computes +!> the location of the point on the opposite side of the arc along a great- +!> circle arc that intersects (A,B) at a right angle, and such that the arc +!> between the point and its mirror is bisected by (A,B). +!> +!> Assumptions: A, B, and the point to be reflected all lie on the surface +!> of the unit sphere. +! +!----------------------------------------------------------------------- + subroutine mpas_mirror_point(xPoint, yPoint, zPoint, xA, yA, zA, xB, yB, zB, xMirror, yMirror, zMirror) + + implicit none + + real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint + real(kind=RKIND), intent(in) :: xA, yA, zA + real(kind=RKIND), intent(in) :: xB, yB, zB + real(kind=RKIND), intent(out) :: xMirror, yMirror, zMirror + + real(kind=RKIND) :: alpha + + ! + ! Find the spherical angle between arcs AP and AB (where P is the point to be reflected) + ! + alpha = mpas_sphere_angle(xA, yA, zA, xPoint, yPoint, zPoint, xB, yB, zB) + + ! + ! Rotate the point to be reflected by twice alpha about the vector from the origin to A + ! + call mpas_rotate_about_vector(xPoint, yPoint, zPoint, 2.0_RKIND * alpha, 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xA, yA, zA, xMirror, yMirror, zMirror) + + end subroutine mpas_mirror_point + + +!----------------------------------------------------------------------- +! routine mpas_in_cell +! +!> \brief Determines whether a point is within a Voronoi cell +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Given a point on the surface of the sphere, the corner points of a Voronoi +!> cell, and the generating point for that Voronoi cell, determines whether +!> the given point is within the Voronoi cell. +! +!----------------------------------------------------------------------- + logical function mpas_in_cell(xPoint, yPoint, zPoint, xCell, yCell, zCell, & + nEdgesOnCell, verticesOnCell, xVertex, yVertex, zVertex) + + implicit none + + real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint + real(kind=RKIND), intent(in) :: xCell, yCell, zCell + integer, intent(in) :: nEdgesOnCell + integer, dimension(:), intent(in) :: verticesOnCell + real(kind=RKIND), dimension(:), intent(in) :: xVertex, yVertex, zVertex + + integer :: i + integer :: vtx1, vtx2 + real(kind=RKIND) :: xNeighbor, yNeighbor, zNeighbor + real(kind=RKIND) :: inDist, outDist + real(kind=RKIND) :: radius + real(kind=RKIND) :: radius_inv + + radius = sqrt(xCell * xCell + yCell * yCell + zCell * zCell) + radius_inv = 1.0_RKIND / radius + + inDist = mpas_arc_length(xPoint, yPoint, zPoint, xCell, yCell, zCell) + + mpas_in_cell = .true. + + do i=1,nEdgesOnCell + vtx1 = verticesOnCell(i) + vtx2 = verticesOnCell(mod(i,nEdgesOnCell)+1) + + call mpas_mirror_point(xCell*radius_inv, yCell*radius_inv, zCell*radius_inv, & + xVertex(vtx1)*radius_inv, yVertex(vtx1)*radius_inv, zVertex(vtx1)*radius_inv, & + xVertex(vtx2)*radius_inv, yVertex(vtx2)*radius_inv, zVertex(vtx2)*radius_inv, & + xNeighbor, yNeighbor, zNeighbor) + + xNeighbor = xNeighbor * radius + yNeighbor = yNeighbor * radius + zNeighbor = zNeighbor * radius + + outDist = mpas_arc_length(xPoint, yPoint, zPoint, xNeighbor, yNeighbor, zNeighbor) + + if (outDist < inDist) then + mpas_in_cell = .false. + return + end if + + end do + + end function mpas_in_cell + end module mpas_geometry_utils diff --git a/src/operators/mpas_spline_interpolation.F b/src/operators/mpas_spline_interpolation.F index f7fa682842..6d0d2ffa02 100644 --- a/src/operators/mpas_spline_interpolation.F +++ b/src/operators/mpas_spline_interpolation.F @@ -115,6 +115,10 @@ subroutine mpas_interpolate_cubic_spline( &!{{{ ! INPUT PARAMETERS: + integer, intent(in) :: & + n, &!< Input: number of nodes, input grid + nOut !< Input: number of nodes, output grid + real (kind=RKIND), dimension(n), intent(in) :: & x, &!< Input: node location, input grid y, &!< Input: interpolation variable, input grid @@ -123,10 +127,6 @@ subroutine mpas_interpolate_cubic_spline( &!{{{ real (kind=RKIND), dimension(nOut), intent(in) :: & xOut !< Input: node location, output grid - integer, intent(in) :: & - n, &!< Input: number of nodes, input grid - nOut !< Input: number of nodes, output grid - ! OUTPUT PARAMETERS: real (kind=RKIND), dimension(nOut), intent(out) :: & @@ -359,6 +359,10 @@ subroutine mpas_interpolate_linear( &!{{{ ! !INPUT PARAMETERS: + integer, intent(in) :: & + N, &!< Input: number of nodes, input grid + NOut !< Input: number of nodes, output grid + real (kind=RKIND), dimension(n), intent(in) :: & x, &!< Input: node location, input grid y !< Input: interpolation variable, input grid @@ -366,10 +370,6 @@ subroutine mpas_interpolate_linear( &!{{{ real (kind=RKIND), dimension(nOut), intent(in) :: & xOut !< Input: node location, output grid - integer, intent(in) :: & - N, &!< Input: number of nodes, input grid - NOut !< Input: number of nodes, output grid - ! !OUTPUT PARAMETERS: real (kind=RKIND), dimension(nOut), intent(out) :: & diff --git a/src/operators/mpas_tracer_advection_helpers.F b/src/operators/mpas_tracer_advection_helpers.F index f18570bd79..15c9ec22d4 100644 --- a/src/operators/mpas_tracer_advection_helpers.F +++ b/src/operators/mpas_tracer_advection_helpers.F @@ -188,7 +188,7 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ sorted_cell_indices(2, n) = cellsOnCell(i, cell1) call mpas_hash_insert(cell_hash, cellsOnCell(i, cell1)) end if - end do ! loop over i + end do do i = 1, nEdgesOnCell(cell2) if(.not. mpas_hash_search(cell_hash, cellsOnCell(i, cell2))) then @@ -198,7 +198,7 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ sorted_cell_indices(2, n) = cellsOnCell(i, cell2) call mpas_hash_insert(cell_hash, cellsOnCell(i, cell2)) end if - end do ! loop over i + end do call mpas_hash_destroy(cell_hash) @@ -207,11 +207,28 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ nAdvCellsForEdge(iEdge) = n do iCell = 1, nAdvCellsForEdge(iEdge) advCellsForEdge(iCell, iEdge) = sorted_cell_indices(2, iCell) - end do ! loop over iCell + end do + + ! equation 7 in Skamarock, W. C., & Gassmann, A. (2011): + ! F(u,psi)_{i+1/2} = u_{i+1/2} * + ! [ 1/2 (psi_{i+1} + psi_i) term 1 + ! - 1/12(dx^2psi_{i+1} + dx^2psi_i) term 2 + ! + sign(u) beta/12 (dx^2psi_{i+1} - dx^2psi_i)] term 3 (note minus sign) + ! + ! adv_coefs accounts for terms 1 and 2 in SG11 equation 7. Term 1 is + ! the 2nd-order flux-function term. adv_coefs accounts for this with + ! the "+ 0.5" lines below. In the advection routines that use these + ! coefficients, the 2nd-order flux loop is then skipped. Term 2 is + ! the 4th-order flux-function term. adv_coefs_3rd accounts for term + ! 3, the beta term. beta > 0 corresponds to the third-order flux + ! function. The - sign in the deriv_two accumulation is for the i+1 + ! part of term 3, while the + sign is for the i part. adv_coefs(:,iEdge) = 0. adv_coefs_3rd(:,iEdge) = 0. + ! pull together third and fourth order contributions to the flux + ! first from cell1 k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cell1)) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(1,1,iEdge) @@ -224,27 +241,30 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(iCell+1, 1, iEdge) adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) + deriv_two(iCell+1, 1, iEdge) end if - end do ! loop over iCell + end do + ! pull together third and fourth order contributions to the flux + ! now from cell2 k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cell2)) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(1,2,iEdge) - adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) + deriv_two(1,2,iEdge) + adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) - deriv_two(1,2,iEdge) end if do iCell = 1, nEdgesOnCell(cell2) k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cellsOnCell(iCell,cell2))) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(iCell+1, 2, iEdge) - adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) + deriv_two(iCell+1, 2, iEdge) + adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) - deriv_two(iCell+1, 2, iEdge) end if - end do ! loop over iCell + end do do iCell = 1,nAdvCellsForEdge(iEdge) adv_coefs (iCell,iEdge) = - (dcEdge(iEdge) **2) * adv_coefs (iCell,iEdge) / 12. adv_coefs_3rd(iCell,iEdge) = - (dcEdge(iEdge) **2) * adv_coefs_3rd(iCell,iEdge) / 12. - end do ! loop over iCell + end do + ! 2nd order centered contribution - place this in the main flux weights k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cell1)) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + 0.5 @@ -255,11 +275,12 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + 0.5 end if + ! multiply by edge length - thus the flux is just dt*ru times the results of the vector-vector multiply do iCell=1,nAdvCellsForEdge(iEdge) adv_coefs (iCell,iEdge) = dvEdge(iEdge) * adv_coefs (iCell,iEdge) adv_coefs_3rd(iCell,iEdge) = dvEdge(iEdge) * adv_coefs_3rd(iCell,iEdge) - end do ! loop over iCell - end if + end do + end if ! only do for edges of owned-cells end do ! end loop over edges deallocate(cell_indices) diff --git a/src/operators/operators.cmake b/src/operators/operators.cmake new file mode 100644 index 0000000000..d65c7c661e --- /dev/null +++ b/src/operators/operators.cmake @@ -0,0 +1,13 @@ +# operators +list(APPEND COMMON_RAW_SOURCES + operators/mpas_vector_operations.F + operators/mpas_matrix_operations.F + operators/mpas_tensor_operations.F + operators/mpas_rbf_interpolation.F + operators/mpas_vector_reconstruction.F + operators/mpas_spline_interpolation.F + operators/mpas_tracer_advection_helpers.F + operators/mpas_tracer_advection_mono.F + operators/mpas_tracer_advection_std.F + operators/mpas_geometry_utils.F +) diff --git a/src/tools/CMakeLists.txt b/src/tools/CMakeLists.txt new file mode 100644 index 0000000000..513ae48cf1 --- /dev/null +++ b/src/tools/CMakeLists.txt @@ -0,0 +1,30 @@ + +if (DEFINED ENV{MPAS_TOOL_DIR}) + message(STATUS "*** Using MPAS tools from $ENV{MPAS_TOOL_DIR} ***") + add_custom_target(namelist_gen) + add_custom_command( + TARGET namelist_gen PRE_BUILD + COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/namelist_gen ${CMAKE_CURRENT_BINARY_DIR}/namelist_gen) + add_custom_target(streams_gen) + add_custom_command( + TARGET streams_gen PRE_BUILD + COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/streams_gen ${CMAKE_CURRENT_BINARY_DIR}/streams_gen) + add_custom_target(parse) + add_custom_command( + TARGET parse PRE_BUILD + COMMAND ${CMAKE_COMMAND} -E copy $ENV{MPAS_TOOL_DIR}/input_gen/parse ${CMAKE_CURRENT_BINARY_DIR}/parse) +else() + message(STATUS "*** Building MPAS tools from source ***") + # Make build tools, need to be compiled with serial compiler. + set(CMAKE_C_COMPILER ${SCC}) + + add_executable(streams_gen input_gen/streams_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) + add_executable(namelist_gen input_gen/namelist_gen.c input_gen/test_functions.c ../external/ezxml/ezxml.c) + add_executable(parse registry/parse.c registry/dictionary.c registry/gen_inc.c registry/fortprintf.c registry/utility.c ../external/ezxml/ezxml.c) + + foreach(EXEITEM streams_gen namelist_gen parse) + target_compile_definitions(${EXEITEM} PRIVATE ${CPPDEFS}) + target_compile_options(${EXEITEM} PRIVATE "-Uvector") + target_include_directories(${EXEITEM} PRIVATE ${INCLUDES}) + endforeach() +endif() diff --git a/src/tools/registry/gen_inc.c b/src/tools/registry/gen_inc.c index 06a31d2039..8f5e79b813 100644 --- a/src/tools/registry/gen_inc.c +++ b/src/tools/registry/gen_inc.c @@ -22,6 +22,7 @@ void write_model_variables(ezxml_t registry){/*{{{*/ const char * suffix = MACRO_TO_STR(MPAS_NAMELIST_SUFFIX); const char * exe_name = MACRO_TO_STR(MPAS_EXE_NAME); const char * git_ver = MACRO_TO_STR(MPAS_GIT_VERSION); + const char * build_target = MACRO_TO_STR(MPAS_BUILD_TARGET); const char *modelname, *corename, *version; FILE *fd; @@ -37,6 +38,7 @@ void write_model_variables(ezxml_t registry){/*{{{*/ fortprintf(fd, " core %% modelVersion = '%s'\n", version); fortprintf(fd, " core %% executableName = '%s'\n", exe_name); fortprintf(fd, " core %% git_version = '%s'\n", git_ver); + fortprintf(fd, " core %% build_target = '%s'\n", build_target); fclose(fd); @@ -50,7 +52,7 @@ void write_model_variables(ezxml_t registry){/*{{{*/ }/*}}}*/ -int write_field_pointers(FILE* fd){/*{{{*/ +int write_field_pointer_arrays(FILE* fd){/*{{{*/ fortprintf(fd, "\n"); fortprintf(fd, " type (field0DReal), pointer :: r0Ptr\n"); fortprintf(fd, " type (field1DReal), pointer :: r1Ptr\n"); @@ -64,79 +66,80 @@ int write_field_pointers(FILE* fd){/*{{{*/ fortprintf(fd, " type (field3DInteger), pointer :: i3Ptr\n"); fortprintf(fd, " type (field0DChar), pointer :: c0Ptr\n"); fortprintf(fd, " type (field1DChar), pointer :: c1Ptr\n"); + fortprintf(fd, " type (field0DReal), dimension(:), pointer :: r0aPtr\n"); + fortprintf(fd, " type (field1DReal), dimension(:), pointer :: r1aPtr\n"); + fortprintf(fd, " type (field2DReal), dimension(:), pointer :: r2aPtr\n"); + fortprintf(fd, " type (field3DReal), dimension(:), pointer :: r3aPtr\n"); + fortprintf(fd, " type (field4DReal), dimension(:), pointer :: r4aPtr\n"); + fortprintf(fd, " type (field5DReal), dimension(:), pointer :: r5aPtr\n"); + fortprintf(fd, " type (field0DInteger), dimension(:), pointer :: i0aPtr\n"); + fortprintf(fd, " type (field1DInteger), dimension(:), pointer :: i1aPtr\n"); + fortprintf(fd, " type (field2DInteger), dimension(:), pointer :: i2aPtr\n"); + fortprintf(fd, " type (field3DInteger), dimension(:), pointer :: i3aPtr\n"); + fortprintf(fd, " type (field0DChar), dimension(:), pointer :: c0aPtr\n"); + fortprintf(fd, " type (field1DChar), dimension(:), pointer :: c1aPtr\n"); fortprintf(fd, "\n"); return 0; }/*}}}*/ -int write_field_pointer_arrays(FILE* fd){/*{{{*/ - fortprintf(fd, "\n"); - fortprintf(fd, " type (field0DReal), dimension(:), pointer :: r0Ptr\n"); - fortprintf(fd, " type (field1DReal), dimension(:), pointer :: r1Ptr\n"); - fortprintf(fd, " type (field2DReal), dimension(:), pointer :: r2Ptr\n"); - fortprintf(fd, " type (field3DReal), dimension(:), pointer :: r3Ptr\n"); - fortprintf(fd, " type (field4DReal), dimension(:), pointer :: r4Ptr\n"); - fortprintf(fd, " type (field5DReal), dimension(:), pointer :: r5Ptr\n"); - fortprintf(fd, " type (field0DInteger), dimension(:), pointer :: i0Ptr\n"); - fortprintf(fd, " type (field1DInteger), dimension(:), pointer :: i1Ptr\n"); - fortprintf(fd, " type (field2DInteger), dimension(:), pointer :: i2Ptr\n"); - fortprintf(fd, " type (field3DInteger), dimension(:), pointer :: i3Ptr\n"); - fortprintf(fd, " type (field0DChar), dimension(:), pointer :: c0Ptr\n"); - fortprintf(fd, " type (field1DChar), dimension(:), pointer :: c1Ptr\n"); - fortprintf(fd, "\n"); +int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs){/*{{{*/ - return 0; -}/*}}}*/ + char suffix[6]; + if (time_levs > 1) { + snprintf(suffix, 6, "aPtr"); + } else { + snprintf(suffix, 6, "Ptr"); + } -int set_pointer_name(int type, int ndims, char *pointer_name){/*{{{*/ if(type == REAL) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "r0Ptr"); + snprintf(pointer_name, 1024, "r0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "r1Ptr"); + snprintf(pointer_name, 1024, "r1%s", suffix); break; case 2: - snprintf(pointer_name, 1024, "r2Ptr"); + snprintf(pointer_name, 1024, "r2%s", suffix); break; case 3: - snprintf(pointer_name, 1024, "r3Ptr"); + snprintf(pointer_name, 1024, "r3%s", suffix); break; case 4: - snprintf(pointer_name, 1024, "r4Ptr"); + snprintf(pointer_name, 1024, "r4%s", suffix); break; case 5: - snprintf(pointer_name, 1024, "r5Ptr"); + snprintf(pointer_name, 1024, "r5%s", suffix); break; } } else if (type == INTEGER) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "i0Ptr"); + snprintf(pointer_name, 1024, "i0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "i1Ptr"); + snprintf(pointer_name, 1024, "i1%s", suffix); break; case 2: - snprintf(pointer_name, 1024, "i2Ptr"); + snprintf(pointer_name, 1024, "i2%s", suffix); break; case 3: - snprintf(pointer_name, 1024, "i3Ptr"); + snprintf(pointer_name, 1024, "i3%s", suffix); break; } } else if (type == CHARACTER) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "c0Ptr"); + snprintf(pointer_name, 1024, "c0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "c1Ptr"); + snprintf(pointer_name, 1024, "c1%s", suffix); break; } } @@ -530,7 +533,7 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ int in_subpool; - FILE *fd, *fd2; + FILE *fd, *fd2, *fcd, *fcg; const_core = ezxml_attr(registry, "core_abbrev"); @@ -538,6 +541,8 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fd = fopen("namelist_defines.inc", "w+"); fd2 = fopen("namelist_call.inc", "w+"); + fcd = fopen("config_declare.inc", "w+"); + fcg = fopen("config_get.inc", "w+"); fortprintf(fd2, " function %s_setup_namelists(configPool, namelistFilename, dminfo) result(iErr)\n", core_string); fortprintf(fd2, " use mpas_derived_types\n"); @@ -599,7 +604,7 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fortprintf(fd, " integer :: ierr\n"); fortprintf(fd, "\n"); - // Define variable defintions prior to reading the namelist in. + // Define variable definitions prior to reading the namelist in. for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ nmloptname = ezxml_attr(nmlopt_xml, "name"); nmlopttype = ezxml_attr(nmlopt_xml, "type"); @@ -611,9 +616,12 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ if(strncmp(nmlopttype, "real", 1024) == 0){ fortprintf(fd, " real (kind=RKIND) :: %s = %lf\n", nmloptname, (double)atof(nmloptval)); + fortprintf(fcd, " real (kind=RKIND), pointer :: %s\n", nmloptname); } else if(strncmp(nmlopttype, "integer", 1024) == 0){ fortprintf(fd, " integer :: %s = %d\n", nmloptname, atoi(nmloptval)); + fortprintf(fcd, " integer, pointer :: %s\n", nmloptname); } else if(strncmp(nmlopttype, "logical", 1024) == 0){ + fortprintf(fcd, " logical, pointer :: %s\n", nmloptname); if(strncmp(nmloptval, "true", 1024) == 0 || strncmp(nmloptval, ".true.", 1024) == 0){ fortprintf(fd, " logical :: %s = .true.\n", nmloptname); } else { @@ -621,9 +629,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ } } else if(strncmp(nmlopttype, "character", 1024) == 0){ fortprintf(fd, " character (len=StrKIND) :: %s = '%s'\n", nmloptname, nmloptval); + fortprintf(fcd, " character (len=StrKIND), pointer :: %s\n", nmloptname); } } fortprintf(fd, "\n"); + fortprintf(fcd, "\n"); // Define the namelist block, to read the namelist record in. fortprintf(fd, " namelist /%s/ &\n", nmlrecname); @@ -645,7 +655,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ } fortprintf(fd, " if (dminfo %% my_proc_id == IO_NODE) then\n"); + fortprintf(fd, "! Rewinding before each read leads to errors when the code is built with\n"); + fortprintf(fd, "! the NAG Fortran compiler. If building with NAG, be kind and don't rewind.\n"); + fortprintf(fd, "#ifndef NAG_COMPILER\n"); fortprintf(fd, " rewind(unitNumber)\n"); + fortprintf(fd, "#endif\n"); fortprintf(fd, " read(unitNumber, %s, iostat=ierr)\n", nmlrecname); fortprintf(fd, " end if\n"); @@ -704,8 +718,10 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ nmloptname = ezxml_attr(nmlopt_xml, "name"); fortprintf(fd, " call mpas_pool_add_config(%s, '%s', %s)\n", pool_name, nmloptname, nmloptname); + fortprintf(fcg, " call mpas_pool_get_config(configPool, '%s', %s)\n", nmloptname, nmloptname); } fortprintf(fd, "\n"); + fortprintf(fcg, "\n"); // End new subroutine for namelist record. fortprintf(fd, " end subroutine %s_setup_nmlrec_%s\n", core_string, nmlrecname); @@ -716,6 +732,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fortprintf(fd2, " close(unitNumber)\n"); fortprintf(fd2, " end function %s_setup_namelists\n", core_string); + fclose(fd); + fclose(fd2); + fclose(fcd); + fclose(fcg); + return 0; }/*}}}*/ @@ -1015,6 +1036,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var char *string, *tofree, *token; char temp_str[1024]; char pointer_name[1024]; + char pointer_name_arr[1024]; char spacing[1024], sub_spacing[1024]; char default_value[1024]; char missing_value[1024]; @@ -1063,13 +1085,23 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var // Determine field type and default value. get_field_information(vararrtype, vararrdefaultval, default_value, vararrmissingval, missing_value, &type); + // If a default_value is not specified, but a missing_value is, then set the + // default_value (defaultValue) to missing_value + if(!vararrdefaultval && vararrmissingval) { + snprintf(default_value, 1024, "%s ! defaultValue taking specified missing_value", missing_value); + } + // Determine ndims, hasTime, and decomp type build_dimension_information(registry, var_arr_xml, &ndims, &hasTime, &decomp); ndims++; // Add a dimension for constituents in var_array // Determine name of pointer for this field. - set_pointer_name(type, ndims, pointer_name); - fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + set_pointer_name(type, ndims, pointer_name, time_levs); + if (time_levs > 1) { + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + } else { + fortprintf(fd, " allocate(%s)\n", pointer_name); + } fortprintf(fd, " index_counter = 0\n", spacing); fortprintf(fd, " group_counter = -1\n", spacing); @@ -1243,27 +1275,32 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " end if\n"); for(time_lev = 1; time_lev <= time_levs; time_lev++){ + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } fortprintf(fd, "! Defining time level %d\n", time_lev); - fortprintf(fd, " allocate( %s(%d) %% constituentNames(numConstituents) )\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, vararrname); + fortprintf(fd, " allocate( %s %% constituentNames(numConstituents) )\n", pointer_name_arr); + fortprintf(fd, " %s %% fieldName = '%s'\n", pointer_name_arr , vararrname); if (decomp != -1) { - fortprintf(fd, " %s(%d) %% isDecomposed = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isDecomposed = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .false.\n", pointer_name_arr); } if (hasTime) { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .false.\n", pointer_name_arr); } - fortprintf(fd, " %s(%d) %% isVarArray = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isVarArray = .true.\n", pointer_name_arr); if(ndims > 0){ if(persistence == SCRATCH){ - fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .false.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .true.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } } fortprintf(fd, "\n"); @@ -1279,7 +1316,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " call mpas_pool_get_dimension(newSubPool, 'index_%s', const_index)\n", varname_in_code); fortprintf(fd, " end if\n"); fortprintf(fd, " if (const_index > 0) then\n", spacing); - fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); fortprintf(fd, " end if\n", spacing); } @@ -1288,7 +1325,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var // Setup dimensions fortprintf(fd, "! Setup dimensions for \n", vararrname); i = 1; - fortprintf(fd, " %s(%d) %% dimNames(%d) = 'num_%s'\n", pointer_name, time_lev, i, vararrname); + fortprintf(fd, " %s %% dimNames(%d) = 'num_%s'\n", pointer_name_arr, i, vararrname); string = strdup(vararrdims); tofree = string; @@ -1297,18 +1334,18 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var if(strncmp(token, "Time", 1024) != 0){ i++; if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } else { - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } } while( (token = strsep(&string, " ")) != NULL){ if(strncmp(token, "Time", 1024) != 0){ i++; if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } else { - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } } } @@ -1317,13 +1354,13 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, "\n"); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% scalar = %s\n", pointer_name_arr, default_value); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); - fortprintf(fd, " allocate(%s(%d) %% attLists(size(%s(%d) %% constituentNames, dim=1)))\n", pointer_name, time_lev, pointer_name, time_lev); + fortprintf(fd, " %s %% defaultValue = %s\n", pointer_name_arr, default_value); + fortprintf(fd, " allocate(%s %% attLists(size(%s %% constituentNames, dim=1)))\n", pointer_name_arr, pointer_name_arr); - fortprintf(fd, " do index_counter = 1, size(%s(%d) %% constituentNames, dim=1)\n", pointer_name, time_lev); - fortprintf(fd, " allocate(%s(%d) %% attLists(index_counter) %% attList)\n", pointer_name, time_lev); + fortprintf(fd, " do index_counter = 1, size(%s %% constituentNames, dim=1)\n", pointer_name_arr); + fortprintf(fd, " allocate(%s %% attLists(index_counter) %% attList)\n", pointer_name_arr); fortprintf(fd, " end do\n"); for(var_xml = ezxml_child(var_arr_xml, "var"); var_xml; var_xml = var_xml->next){ @@ -1353,7 +1390,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'long_name', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'long_name', '%s')\n", pointer_name_arr, temp_str); } if ( varunits != NULL ) { @@ -1369,21 +1406,19 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'units', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, 'units', '%s')\n", pointer_name_arr, temp_str); } if ( vararrmissingval ) { - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'missing_value', %s)\n", pointer_name, time_lev, missing_value); - // Uncomment to add _FillValue to match missing_value - // fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, '_FillValue', %s)\n", pointer_name, time_lev, missing_value); + fortprintf(fd, " call mpas_add_att(%s %% attLists(const_index) %% attList, '_FillValue', %s)\n", pointer_name_arr, missing_value); } - fortprintf(fd, " %s(%d) %% missingValue = %s\n", pointer_name, time_lev, missing_value); - fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); + fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); fortprintf(fd, " end if\n", spacing); } - fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + fortprintf(fd, " %s %% block => block\n", pointer_name_arr); } // Parse packages if they are defined @@ -1404,7 +1439,12 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var } for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, " %s%s(%d) %% isActive = .true.\n", spacing, pointer_name, time_lev); + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } + fortprintf(fd, " %s%s %% isActive = .true.\n", spacing, pointer_name_arr); } if (!no_packages) { @@ -1443,6 +1483,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa char *string, *tofree, *token; char temp_str[1024]; char pointer_name[1024]; + char pointer_name_arr[1024]; char package_spacing[1024]; char default_value[1024]; char missing_value[1024]; @@ -1489,38 +1530,52 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa // Determine field type and default value. get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); + // If a default_value is not specified, but a missing_value is, then set the + // default_value (defaultValue) to missing_value + if(!vardefaultval && varmissingval) { + snprintf(default_value, 1024, "%s ! defaultValue taking specified missing_value", missing_value); + } + // Determine ndims, hasTime, and decomp type build_dimension_information(registry, var_xml, &ndims, &hasTime, &decomp); // Determine name of pointer for this field. - set_pointer_name(type, ndims, pointer_name); - - fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + set_pointer_name(type, ndims, pointer_name, time_levs); + if (time_levs > 1) { + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + } else { + fortprintf(fd, " allocate(%s)\n", pointer_name); + } for(time_lev = 1; time_lev <= time_levs; time_lev++){ + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } fortprintf(fd, "\n"); fortprintf(fd, "! Setting up time level %d\n", time_lev); - fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, varname); - fortprintf(fd, " %s(%d) %% isVarArray = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% fieldName = '%s'\n", pointer_name_arr, varname); + fortprintf(fd, " %s %% isVarArray = .false.\n", pointer_name_arr); if (decomp != -1) { - fortprintf(fd, " %s(%d) %% isDecomposed = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isDecomposed = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .false.\n", pointer_name_arr); } if(hasTime) { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .false.\n", pointer_name_arr); } if(ndims > 0){ if(persistence == SCRATCH){ - fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .false.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .true.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } // Setup dimensions @@ -1530,24 +1585,24 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa i = 1; token = strsep(&string, " "); if(strncmp(token, "Time", 1024) != 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); i++; } while( (token = strsep(&string, " ")) != NULL){ if(strncmp(token, "Time", 1024) != 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); i++; } } free(tofree); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% defaultValue = %s\n", pointer_name_arr, default_value); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% scalar = %s\n", pointer_name_arr, default_value); } - fortprintf(fd, " allocate(%s(%d) %% attLists(1))\n", pointer_name, time_lev); - fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); + fortprintf(fd, " allocate(%s %% attLists(1))\n", pointer_name_arr); + fortprintf(fd, " allocate(%s %% attLists(1) %% attList)\n", pointer_name_arr); if ( varunits != NULL ) { string = strdup(varunits); @@ -1562,7 +1617,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'units', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'units', '%s')\n", pointer_name_arr, temp_str); } if ( vardesc != NULL ) { @@ -1578,17 +1633,15 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa free(tofree); - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'long_name', '%s')\n", pointer_name, time_lev, temp_str); + fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, 'long_name', '%s')\n", pointer_name_arr, temp_str); } if ( varmissingval != NULL ) { - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'missing_value', %s)\n", pointer_name, time_lev, missing_value); - // Uncomment to add _FillValue to match missing_value - // fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, '_FillValue', %s)\n", pointer_name, time_lev, missing_value); + fortprintf(fd, " call mpas_add_att(%s %% attLists(1) %% attList, '_FillValue', %s)\n", pointer_name_arr, missing_value); } - fortprintf(fd, " %s(%d) %% missingValue = %s\n", pointer_name, time_lev, missing_value); + fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); - fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + fortprintf(fd, " %s %% block => block\n", pointer_name_arr); } @@ -1611,7 +1664,12 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa } for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, " %s%s(%d) %% isActive = .true.\n", package_spacing, pointer_name, time_lev); + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } + fortprintf(fd, " %s%s %% isActive = .true.\n", package_spacing, pointer_name_arr); } if(varpackages != NULL){ @@ -1784,211 +1842,6 @@ int determine_struct_depth(int curLevel, ezxml_t superStruct){/*{{{*/ }/*}}}*/ -int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct, ezxml_t registry){/*{{{*/ - ezxml_t subStruct; - ezxml_t var_arr_xml, var_xml; - const char *structname; - const char *vartimelevs; - const char *varname, *vardims, *vartype; - const char *vardefaultval, *varmissingval; - const char *varname_in_code; - int depth; - int err; - int has_time; - int time_lev, time_levs; - int ndims, type; - int decomp; - char *string, *tofree, *token; - char pointer_name[1024]; - char default_value[1024]; - char missing_value[1024]; - - depth = curLevel + 1; - - for(subStruct = ezxml_child(superStruct, "var_struct"); subStruct; subStruct = subStruct->next){ - structname = ezxml_attr(subStruct, "name"); - fortprintf(fd, "! ----------- NEW STRUCT ---------\n"); - fortprintf(fd, "! Get pointers to pools for struct %s\n", structname); - fortprintf(fd, "! --------------------------------\n"); - if(curLevel == 0){ - fortprintf(fd, " call mpas_pool_get_subpool(currentBlock %% structs, '%s', poolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(prevBlock %% structs, '%s', prevPoolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(nextBlock %% structs, '%s', nextPoolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " call mpas_pool_get_subpool(poolLevel%d, '%s', poolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(prevPoolLevel%d, '%s', prevPoolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(nextPoolLevel%d, '%s', nextPoolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - } - - fortprintf(fd, "\n"); - // Link var arrays - for(var_arr_xml = ezxml_child(subStruct, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){/*{{{*/ - varname = ezxml_attr(var_arr_xml, "name"); - vardims = ezxml_attr(var_arr_xml, "dimensions"); - vartimelevs = ezxml_attr(var_arr_xml, "time_levs"); - vartype = ezxml_attr(var_arr_xml, "type"); - vardefaultval = ezxml_attr(var_arr_xml, "default_value"); - varmissingval = ezxml_attr(var_arr_xml, "missing_value"); - - if(!vartimelevs){ - vartimelevs = ezxml_attr(subStruct, "time_levs"); - } - - if(vartimelevs){ - time_levs = atoi(vartimelevs); - if(time_levs < 1){ - time_levs = 1; - } - } else { - time_levs = 1; - } - - if(!varmissingval){ - varmissingval = vardefaultval; - } - - // Determine field type and default value. - get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); - - // Determine number of dimensions - // and decomp type - build_dimension_information(registry, var_arr_xml, &ndims, &has_time, &decomp); - ndims++; // Add a dimension for var_arrays - - // Using type and ndims, determine name of pointer for field. - set_pointer_name(type, ndims, pointer_name); - - for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, "! Linking %s for time level %d\n", varname, time_lev); - fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " if(associated(%s)) then\n", pointer_name); - fortprintf(fd, "#ifdef MPAS_DEBUG\n"); - fortprintf(fd, " call mpas_log_write('Linking %s')\n", varname); - fortprintf(fd, "#endif\n"); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - - if(decomp == CELLS){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); - } else if(decomp == EDGES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); - } else if(decomp == VERTICES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); - } - - fortprintf(fd, " end if\n"); - } - - fortprintf(fd, "\n"); - }/*}}}*/ - - // Link independent vars - for(var_xml = ezxml_child(subStruct, "var"); var_xml; var_xml = var_xml->next){/*{{{*/ - varname = ezxml_attr(var_xml, "name"); - vardims = ezxml_attr(var_xml, "dimensions"); - vartimelevs = ezxml_attr(var_xml, "time_levs"); - vartype = ezxml_attr(var_xml, "type"); - vardefaultval = ezxml_attr(var_xml, "default_value"); - varmissingval = ezxml_attr(var_xml, "missing_value"); - varname_in_code = ezxml_attr(var_xml, "name_in_code"); - - if(!vartimelevs){ - vartimelevs = ezxml_attr(subStruct, "time_levs"); - } - - if(vartimelevs){ - time_levs = atoi(vartimelevs); - if(time_levs < 1){ - time_levs = 1; - } - } else { - time_levs = 1; - } - - if(!varname_in_code){ - varname_in_code = ezxml_attr(var_xml, "name"); - } - - if(!varmissingval){ - varmissingval = vardefaultval; - } - - // Determine field type and default value. - get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); - - // Determine number of dimensions - // and decomp type - build_dimension_information(registry, var_xml, &ndims, &has_time, &decomp); - - // Using type and ndims, determine name of pointer for field. - set_pointer_name(type, ndims, pointer_name); - - for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, "! Linking %s for time level %d with name\n", varname, time_lev, varname_in_code); - fortprintf(fd, "#ifdef MPAS_DEBUG\n"); - fortprintf(fd, " call mpas_log_write('Linking %s with name %s')\n", varname, varname_in_code); - fortprintf(fd, "#endif\n"); - fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " if(associated(%s)) then\n", pointer_name); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - - if(decomp == CELLS){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); - } else if(decomp == EDGES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); - } else if(decomp == VERTICES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); - } - fortprintf(fd, " end if\n"); - - fortprintf(fd, "\n"); - } - }/*}}}*/ - - err = generate_struct_links(fd, curLevel+1, subStruct, registry); - } - - return 0; -}/*}}}*/ - - int generate_immutable_struct_contents(FILE *fd, const char *streamname, ezxml_t varstruct_xml){/*{{{*/ ezxml_t var_xml, vararr_xml, substruct_xml; diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 0859823fb9..96db3de8b3 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -10,9 +10,8 @@ #include "ezxml.h" void write_model_variables(ezxml_t registry); -int write_field_pointers(FILE* fd); int write_field_pointer_arrays(FILE* fd); -int set_pointer_name(int type, int ndims, char *pointer_name); +int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs); int add_package_to_list(const char * package, const char * package_list); int build_struct_package_lists(ezxml_t currentPosition, char * out_packages); int get_dimension_information(ezxml_t registry, const char *test_dimname, int *has_time, int *decomp); @@ -27,7 +26,6 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVar, const char * corename); int parse_struct(FILE *fd, ezxml_t registry, ezxml_t superStruct, int subpool, const char *parentname, const char * corename); int determine_struct_depth(int curLevel, ezxml_t superStruct); -int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct, ezxml_t registry); int generate_field_exchanges(FILE *fd, int curLevel, ezxml_t superStruct); int generate_field_halo_exchanges_and_copies(ezxml_t registry); int generate_field_inputs(FILE *fd, int curLevel, ezxml_t superStruct); diff --git a/testing_and_setup/atmosphere/setup_atm_run_dir b/testing_and_setup/atmosphere/setup_atm_run_dir new file mode 100755 index 0000000000..b0734c2f5f --- /dev/null +++ b/testing_and_setup/atmosphere/setup_atm_run_dir @@ -0,0 +1,174 @@ +#! /bin/sh + +# Setup a run directory for the MPAS init_atmosphere, and atmosphere cores. + +###################################################################### +# usage() - Display the usage message +###################################################################### +usage() +{ + printf "Usage: setup_atm_run_dir setup-dir\n" +} + +###################################################################### +# init_atmosphere_setup() +# +# $1 - Run directory +# $2 - MPAS-Model Source Code Directory +# Setup the init_atmosphere in the run directory ($1) by linking the +# init_atmosphere exetuable and copying the init_atmosphere namelist and +# streams from the default_inputs/ directory. +# +# On error, the program will exit and will return 1, otherwise, 0 will be +# returned. +# +###################################################################### +init_atmosphere_setup() +{ + printf "Setting up the init_atmosphere core ...\n" + rundir=$1 + mpasdir=$2 + + # See if the init_amtosphere_model is compiled + if ! [ -f "${mpasdir}/init_atmosphere_model" ]; then + printf "The MPAS directory does not appear to have the init_atmosphere core compiled!\n" + return 1 + fi + + ln -s "${mpasdir}/init_atmosphere_model" $rundir + if [ $? -ne 0 ]; then + printf "Failed to link 'init_atmosphere_model' from %s\n" $mpasdir + return 1 + fi + + cp "${mpasdir}/default_inputs/namelist.init_atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'namelist.init_atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + cp "${mpasdir}/default_inputs/streams.init_atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'streams.init_atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + printf "Succesfully setup the run directory for the init_atmosphere model\n" + return 0 +} + +###################################################################### +# atmosphere_setup() +# +# $1 - Run directory +# $2 - MPAS-Model Source Code Directory +# Setup the atmosphere core in the run directory ($1) by linking the +# atmosphere_model exeutable, physics lookup tables, and by copying +# the needed namelist, streams, and stream_lists from the default_inputs/ +# directory. +# +# On error, this function 1 will be returned, otherwise, 0 will be +# returned. +# +###################################################################### +atmosphere_setup() +{ + printf "Setting up the atmosphere core ...\n" + rundir=$1 + mpasdir=$2 + + # See if the amtosphere core is compiled + if ! [ -f "${mpasdir}/atmosphere_model" ]; then + printf "The MPAS directory does not appear to have the atmosphere core compiled!\n" + return 1 + fi + + ln -s "${mpasdir}/atmosphere_model" $rundir + if [ $? -ne 0 ]; then + printf "Failed to link 'atmosphere_model' from %s\n" $mpasdir + return 1 + fi + + cp "${mpasdir}/default_inputs/namelist.atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'namelist.atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + cp "${mpasdir}/default_inputs/streams.atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'streams.atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + cp ${mpasdir}/default_inputs/stream_list.atmosphere.* $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'stream_list.atmosphere.*' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + ln -s ${mpasdir}/src/core_atmosphere/physics/physics_wrf/files/* $rundir + if [ $? -ne 0 ]; then + printf "Failed to link physics files from %s\n" "${mpasdir}/src_core_atmosphere_physics/physics_wrf/files" + return 1 + fi + + printf "Succesfully setup the run directory for the atmosphere model\n" + return 0 +} + + +######################################################## +# +# setup_run_atm_run_dir.sh +# +# \brief Copy and link the needed files for running the init_atmosphere, and +# atmosphere core. +# \details +# Given a directory, copy or link all the needed executables, namelist, +# streams, stream_lists and physics lookup tables needed for both the +# init_atmosphere and atmosphere core. +# +# Currently, this script will need to be in the +# testing_and_setup/atmosphere directory of the MPAS-Model repository that is +# desired to be setup. If either the init_atmosphere or atmosphere core is +# compiled in the MPAS-Model directory, then it will be copied into the run +# directory. If a core is not compiled, it will not be copied. +# +######################################################## + +if [ $# -ne 1 ]; then + printf "Please provide a directory to setup a MPAS run\n" + usage + exit 1 +fi + +rundir=$1 + +if ! [ -d $rundir ]; then + printf "The given directory does not appear to be a directory\n" + exit 1 +fi + +# Find the location of this script, which will be used to find the the needed +# MPAS files. Note: $0 may fail here with some shells and some uncommon +# executions, see: http://mywiki.wooledge.org/BashFAQ/028 +cwd=`pwd` +cd `dirname $0` +this_script=`pwd` +cd $cwd +mpasdir=`dirname "$this_script"` +mpasdir=`dirname "$mpasdir"` + +# See if this is an MPAS directory (Check for src/core_atmosphere, +# and src/core_init_atmosphere) +if ! [ -d "${mpasdir}/src/core_atmosphere" ] || ! [ -d "${mpasdir}/src/core_init_atmosphere" ]; then + printf "ERROR: Can't seem to locate MPAS-Model directory!\n" + printf "ERROR: Please ensure that this script is in the testing_and_setup/atmosphere directory of\n" + printf "ERROR: the MPAS-Model you want to setup\n" + exit 1 +fi + +init_atmosphere_setup $rundir $mpasdir + +atmosphere_setup $rundir $mpasdir diff --git a/testing_and_setup/compass/clean_testcase.py b/testing_and_setup/compass/clean_testcase.py index 99d4034384..9aa66f806f 100755 --- a/testing_and_setup/compass/clean_testcase.py +++ b/testing_and_setup/compass/clean_testcase.py @@ -84,7 +84,7 @@ regex = re.compile('(\d):') core_configuration = subprocess.check_output(['./list_testcases.py']) - for line in core_configuration.split('\n'): + for line in core_configuration.decode('utf-8').split('\n'): if regex.search(line) is not None: conf_arr = line.replace(":", " ").split() case_num = int(conf_arr[0]) @@ -103,7 +103,7 @@ os.chdir(os.path.dirname(os.path.realpath(__file__))) git_version = subprocess.check_output(['git', 'describe', '--tags', '--dirty']) - git_version = git_version.strip('\n') + git_version = git_version.decode('utf-8').strip('\n') os.chdir(old_dir) calling_command = "" write_history = False @@ -119,7 +119,7 @@ core_configuration = subprocess.check_output( ['./list_testcases.py', '-n', '{:d}'.format(int(case_num))]) - config_options = core_configuration.strip('\n').split(' ') + config_options = core_configuration.decode('utf-8').strip('\n').split(' ') args.core = config_options[1] args.configuration = config_options[3] args.resolution = config_options[5] @@ -194,7 +194,7 @@ core_configuration = subprocess.check_output( ['./list_testcases.py', '-n', '{:d}'.format(int(case_num))]) - config_options = core_configuration.strip('\n').split(' ') + config_options = core_configuration.decode('utf-8').strip('\n').split(' ') history_file.write('\n') history_file.write(' core: {}\n'.format(config_options[1])) history_file.write(' configuration: {}\n'.format( diff --git a/testing_and_setup/compass/manage_regression_suite.py b/testing_and_setup/compass/manage_regression_suite.py index a8ef17551a..a64e708305 100755 --- a/testing_and_setup/compass/manage_regression_suite.py +++ b/testing_and_setup/compass/manage_regression_suite.py @@ -147,7 +147,7 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, # }}} -def process_test_clean(test_tag, work_dir, suite_script): # {{{ +def process_test_clean(test_tag, work_dir): # {{{ dev_null = open('/dev/null', 'a') # Process test attributes @@ -304,15 +304,13 @@ def clean_suite(suite_tag, work_dir): # {{{ for child in suite_tag: # Process children within the if child.tag == 'test': - process_test_clean(child, work_dir, regression_script) + process_test_clean(child, work_dir) # }}} -def summarize_suite(suite_tag): # {{{ +def get_test_case_procs(suite_tag): # {{{ - max_procs = 1 - max_threads = 1 - max_cores = 1 + testcases = {} for child in suite_tag: if child.tag == 'test': @@ -367,9 +365,36 @@ def summarize_suite(suite_tag): # {{{ name = case.attrib['name'] cases.append(name) + prereqs = list() + for config_prereq in config_root.iter('prerequisite'): + prereq = dict() + for tag in ['core', 'configuration', 'resolution', 'test']: + prereq[tag] = config_prereq.attrib[tag] + + # Make sure the prerequisite is already in the test suite + found = False + for other_name, other_test in testcases.items(): + match = [prereq[tag] == other_test[tag] for tag in + ['core', 'configuration', 'resolution', 'test']] + if all(match): + found = True + prereq['name'] = other_name + break + + if not found: + raise ValueError( + 'Prerequisite of {} does not precede it in the test ' + 'suite: {} {} {} {}'.format( + test_name, prereq['core'], prereq['configuration'], + prereq['resolution'], prereq['test'])) + + prereqs.append(prereq) + del config_root del config_tree + procs = 1 + threads = 1 # Loop over all files in test_path that have the .xml extension. for file in os.listdir('{}'.format(test_path)): if fnmatch.fnmatch(file, '*.xml'): @@ -395,19 +420,33 @@ def summarize_suite(suite_tag): # {{{ except (KeyError, ValueError): threads = 1 - cores = threads * procs + del config_root + del config_tree + testcases[test_name] = {'core': test_core, + 'configuration': test_configuration, + 'resolution': test_resolution, + 'test': test_test, + 'path': test_path, + 'procs': procs, + 'threads': threads, + 'prereqs': prereqs} - if procs > max_procs: - max_procs = procs + return testcases # }}} - if threads > max_threads: - max_threads = threads - if cores > max_cores: - max_cores = cores +def summarize_suite(testcases): # {{{ - del config_root - del config_tree + max_procs = 1 + max_threads = 1 + max_cores = 1 + for name in testcases: + procs = testcases[name]['procs'] + threads = testcases[name]['threads'] + cores = threads * procs + + max_procs = max(max_procs, procs) + max_threads = max(max_threads, threads) + max_cores = max(max_cores, cores) print("\n") print(" Summary of test cases:") @@ -417,7 +456,7 @@ def summarize_suite(suite_tag): # {{{ # }}} -if __name__ == "__main__": +def main (): # {{{ # Define and process input arguments parser = argparse.ArgumentParser( description=__doc__, formatter_class=argparse.RawTextHelpFormatter) @@ -495,14 +534,15 @@ def summarize_suite(suite_tag): # {{{ if args.setup: print("\n") print("Setting Up Test Cases:") + testcases = get_test_case_procs(suite_root) setup_suite(suite_root, args.work_dir, args.model_runtime, args.config_file, args.baseline_dir, args.verbose) - summarize_suite(suite_root) + summarize_suite(testcases) if args.verbose: cmd = ['cat', args.work_dir + '/manage_regression_suite.py.out'] print('\nCase setup output:') - print(subprocess.check_output(cmd)) + print(subprocess.check_output(cmd).decode('utf-8')) write_history = True # Write the history of this command to the command_history file, for @@ -533,5 +573,10 @@ def summarize_suite(suite_tag): # {{{ history_file.write('**************************************************' '*********************\n') history_file.close() +# }}} + + +if __name__ == "__main__": + main() # vim: foldmethod=marker ai ts=4 sts=4 et sw=4 ft=python diff --git a/testing_and_setup/compass/setup_testcase.py b/testing_and_setup/compass/setup_testcase.py index d0ed603ed3..ed3538d707 100755 --- a/testing_and_setup/compass/setup_testcase.py +++ b/testing_and_setup/compass/setup_testcase.py @@ -25,6 +25,8 @@ from six.moves import configparser import textwrap import netCDF4 +import shutil +import errno try: from collections import defaultdict @@ -516,6 +518,8 @@ def generate_driver_scripts(config_file, configs): # {{{ if not os.path.exists(init_path): os.makedirs(init_path) + link_load_compass_env(init_path, configs) + # Create script file script = open('{}/{}'.format(init_path, name), 'w') @@ -1176,61 +1180,7 @@ def add_links(config_file, configs): # {{{ for child in config_root: # Process an tag if child.tag == 'add_link': - try: - source = child.attrib['source'] - except KeyError: - print(" add_link tag missing a 'source' attribute.") - print(" Exiting...") - sys.exit(1) - - try: - source_path_name = child.attrib['source_path'] - - keyword_path = False - if source_path_name.find('work_') >= 0: - keyword_path = True - elif source_path_name.find('script_') >= 0: - keyword_path = True - - if not keyword_path: - if configs.has_option('paths', source_path_name): - source_path = configs.get('paths', source_path_name) - else: - source_path = 'NONE' - - if source_path == 'NONE': - if configs.has_option('script_paths', - source_path_name): - source_path = configs.get('script_paths', - source_path_name) - else: - source_path = 'NONE' - - if source_path == 'NONE': - print("ERROR: source_path on tag is '{}' " - "which is not defined".format(source_path_name)) - print("Exiting...") - sys.exit(1) - - else: - source_arr = source_path_name.split('_') - base_name = source_arr[0] - subname = '{}_{}'.format(source_arr[1], source_arr[2]) - - if base_name == 'work': - file_base_path = 'work_dir' - elif base_name == 'script': - file_base_path = 'script_path' - - if subname in {'core_dir', 'configuration_dir', - 'resolution_dir', 'test_dir', 'case_dir'}: - source_path = '{}/{}'.format( - configs.get('script_paths', file_base_path), - configs.get('script_paths', subname)) - - source_file = '{}/{}'.format(source_path, source) - except KeyError: - source_file = '{}'.format(source) + source_file = get_source_file(child, configs) dest = child.attrib['dest'] old_cwd = os.getcwd() @@ -1240,32 +1190,95 @@ def add_links(config_file, configs): # {{{ '{}'.format(dest)], stdout=dev_null, stderr=dev_null) os.chdir(old_cwd) - del source - del dest # Process an tag elif child.tag == 'add_executable': source_attr = child.attrib['source'] dest = child.attrib['dest'] if not configs.has_option("executables", source_attr): - print('ERROR: Configuration {} requires a definition of ' + raise ValueError('Configuration {} requires a definition of ' '{}.'.format(config_file, source_attr)) - sys.exit(1) - else: - source = configs.get("executables", source_attr) + source = configs.get("executables", source_attr) subprocess.check_call(['ln', '-sf', '{}'.format(source), '{}/{}'.format(base_path, dest)], stdout=dev_null, stderr=dev_null) - del source_attr - del source - del dest - del config_tree - del config_root dev_null.close() # }}} +def get_source_file(child, config): # {{{ + try: + source = child.attrib['source'] + except KeyError: + raise KeyError("{} tag missing a 'source' attribute.".format( + child.tag)) + + try: + source_path_name = child.attrib['source_path'] + except KeyError: + return source + + keyword_path = any(substring in source_path_name for + substring in ['work_', 'script_']) + + if keyword_path: + source_arr = source_path_name.split('_') + base_name = source_arr[0] + if base_name == 'work': + file_base_path = 'work_dir' + elif base_name == 'script': + file_base_path = 'script_path' + else: + raise ValueError('Unexpected source prefix {} in {} tag'.format( + base_name, child.tag)) + + subname = '{}_{}'.format(source_arr[1], source_arr[2]) + if subname not in ['core_dir', 'configuration_dir', + 'resolution_dir', 'test_dir', 'case_dir']: + raise ValueError('Unexpected source suffix {} in {} tag'.format( + subname, child.tag)) + + source_path = '{}/{}'.format( + config.get('script_paths', file_base_path), + config.get('script_paths', subname)) + else: + if config.has_option('paths', source_path_name): + source_path = config.get('paths', source_path_name) + else: + if not config.has_option('script_paths', source_path_name): + raise ValueError('Undefined source_path on {} tag: {}'.format( + child.tag, source_path_name)) + source_path = config.get('script_paths', source_path_name) + + source_file = '{}/{}'.format(source_path, source) + return source_file +# }}} + + +def copy_files(config_file, config): # {{{ + config_tree = ET.parse(config_file) + config_root = config_tree.getroot() + + case = config_root.attrib['case'] + + # Determine the path for the case directory + test_path = '{}/{}'.format(config.get('script_paths', 'test_dir'), case) + base_path = '{}/{}'.format(config.get('script_paths', 'work_dir'), + test_path) + + # Process all children tags + for child in config_root: + # Process an tag + if child.tag == 'copy_file': + source = get_source_file(child, config) + + dest = '{}/{}'.format(base_path, child.attrib['dest']) + + shutil.copy(source, dest) +# }}} + + def make_case_dir(config_file, base_path): # {{{ config_tree = ET.parse(config_file) config_root = config_tree.getroot() @@ -1539,6 +1552,24 @@ def get_case_name(config_file): # {{{ return name # }}} + +def link_load_compass_env(init_path, configs): # {{{ + + if configs.getboolean('conda', 'link_load_compass'): + target = '{}/{}/load_compass_env.sh'.format( + configs.get('script_paths', 'script_path'), + configs.get('script_paths', 'core_dir')) + + link_name = '{}/load_compass_env.sh'.format(init_path) + try: + os.symlink(target, link_name) + except OSError as e: + if e.errno == errno.EEXIST: + os.remove(link_name) + os.symlink(target, link_name) + else: + raise e +# }}} # }}} @@ -1580,6 +1611,10 @@ def get_case_name(config_file): # {{{ help="If set, script will create case directories in " "work_dir rather than the current directory.", metavar="PATH") + parser.add_argument("--link_load_compass", dest="link_load_compass", + action="store_true", + help="If set, a link to /load_compass_env.sh is " + "included with each test case") args = parser.parse_args() @@ -1668,6 +1703,15 @@ def get_case_name(config_file): # {{{ config.set('script_input_arguments', 'model_runtime', args.model_runtime) + if not config.has_section('conda'): + config.add_section('conda') + + if not config.has_option('conda', 'link_load_compass'): + config.set('conda', 'link_load_compass', 'False') + + if args.link_load_compass: + config.set('conda', 'link_load_compass', 'True') + # Build variables for history output old_dir = os.getcwd() os.chdir(config.get('script_paths', 'script_path')) @@ -1765,6 +1809,8 @@ def get_case_name(config_file): # {{{ # Process all links for this case add_links(config_file, config) + copy_files(config_file, config) + # Generate run scripts for this case. generate_run_scripts(config_file, '{}'.format(case_path), config)