diff --git a/.github/workflows/srt.yml b/.github/workflows/srt.yml new file mode 100644 index 000000000..74859525d --- /dev/null +++ b/.github/workflows/srt.yml @@ -0,0 +1,153 @@ +# CIME scripts regression tests + +name: scripts regression tests + +# Controls when the action will run. Triggers the workflow on push or pull request +# events but only for the master branch +on: + push: + branches: main + pull_request: + branches: main + +# A workflow run is made up of one or more jobs that can run sequentially or in parallel +jobs: + # This workflow contains a single job called "build" + build: + # The type of runner that the job will run on + runs-on: ubuntu-latest + strategy: + matrix: + python-version: [3.8, 3.9] + env: + CC: mpicc + FC: mpifort + CXX: mpicxx + CPPFLAGS: "-I/usr/include -I/usr/local/include" + # Versions of all dependencies can be updated here + PNETCDF_VERSION: pnetcdf-1.12.2 + NETCDF_FORTRAN_VERSION: v4.5.2 + MCT_VERSION: MCT_2.11.0 + PARALLELIO_VERSION: pio2_5_4 + NETCDF_C_PATH: /usr + NETCDF_FORTRAN_PATH: ${HOME}/netcdf-fortran + PNETCDF_PATH: ${HOME}/pnetcdf + CIME_MODEL: cesm + CIME_DRIVER: mct + + # Steps represent a sequence of tasks that will be executed as part of the job + steps: + # Checks-out your repository under $GITHUB_WORKSPACE, so your job can access it + + - name: cime checkout + uses: actions/checkout@v2 + with: + repository: ESMCI/cime + + - name: share checkout + uses: actions/checkout@v2 + with: + repository: ESCOMP/CESM_share + path: share + + - name: cpl7 checkout + uses: actions/checkout@v2 + with: + repository: ESCOMP/CESM_CPL7andDataComps + path: components/cpl7 + + - id: load-env + run: | + sudo apt-get update + sudo apt-get install libxml2-utils pylint wget gfortran openmpi-bin netcdf-bin libopenmpi-dev cmake libnetcdf-dev + + - name: Set up Python ${{ matrix.python-version }} + uses: actions/setup-python@v2 + with: + python-version: ${{ matrix.python-version }} + + - name: mct install + run: | + git clone -b ${{ env.MCT_VERSION }} https://github.com/MCSclimate/MCT libraries/mct + ls -l libraries/mct + + - name: parallelio install + run: | + git clone -b ${{ env.PARALLELIO_VERSION }} https://github.com/NCAR/ParallelIO libraries/parallelio + ls -l libraries/parallelio + + - name: cache pnetcdf + id: cache-pnetcdf + uses: actions/cache@v2 + with: + path: ~/pnetcdf + key: ${{ runner.os }}-${{ env.PNETCDF_VERSION}}-pnetcdf-redo + + - name: pnetcdf build + if: steps.cache-pnetcdf.outputs.cache-hit != 'true' + run: | + wget https://parallel-netcdf.github.io/Release/${{ env.PNETCDF_VERSION }}.tar.gz + tar -xzvf ${{ env.PNETCDF_VERSION }}.tar.gz + ls -l + pushd ${{ env.PNETCDF_VERSION }} + ./configure --prefix=$HOME/pnetcdf --enable-shared --disable-cxx + make + make install + popd + + - name: Cache netcdf-fortran + id: cache-netcdf-fortran + uses: actions/cache@v2 + with: + path: ~/netcdf-fortran + key: ${{ runner.os }}-${{ env.NETCDF_FORTRAN_VERSION }}-netcdf-fortran-redo + + - name: netcdf fortran build + if: steps.cache-netcdf-fortran.outputs.cache-hit != 'true' + run: | + sudo apt-get install libnetcdf-dev + wget https://github.com/Unidata/netcdf-fortran/archive/${{ env.NETCDF_FORTRAN_VERSION }}.tar.gz + tar -xzvf ${{ env.NETCDF_FORTRAN_VERSION }}.tar.gz + ls -l + pushd netcdf-fortran-* + ./configure --prefix=$HOME/netcdf-fortran + make + make install + + - name: link netcdf-c to netcdf-fortran path + # link netcdf c library here to simplify build + run: | + pushd ${{ env.NETCDF_FORTRAN_PATH }}/include + ln -fs /usr/include/*netcdf* . + pushd ${{ env.NETCDF_FORTRAN_PATH }}/lib + clibdir=`nc-config --libdir` + ln -fs $clibdir/lib* . + + - name: Cache inputdata + id: cache-inputdata + uses: actions/cache@v2 + with: + path: $HOME/cesm/inputdata + key: inputdata +# +# The following can be used to ssh to the testnode for debugging +# see https://github.com/mxschmitt/action-tmate for details +# - name: Setup tmate session +# uses: mxschmitt/action-tmate@v3 + + - name: scripts regression tests + run: | + mkdir -p $HOME/cesm/scratch + mkdir -p $HOME/cesm/inputdata + cd $HOME/work/CESM_share/CESM_share/scripts/tests + ls -l $HOME/work/CESM_share/CESM_share + export NETCDF=$HOME/netcdf-fortran + export PATH=$NETCDF/bin:$PATH + export LD_LIBRARY_PATH=$NETCDF/lib:$HOME/pnetcdf/lib:$LD_LIBRARY_PATH + ./scripts_regression_tests.py --no-fortran-run --compiler gnu --mpilib openmpi --machine ubuntu-latest + +# the following can be used by developers to login to the github server in case of errors +# see https://github.com/marketplace/actions/debugging-with-tmate for further details +# - name: Setup tmate session +# if: ${{ failure() }} +# uses: mxschmitt/action-tmate@v3 diff --git a/CMakeLists.txt b/CMakeLists.txt index 363e2077a..70172df11 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -40,9 +40,9 @@ if (NOT DEFINED MPILIB OR NOT ${MPILIB} STREQUAL "mpi-serial") endif() if(BLD_STANDALONE) - add_subdirectory(util) + add_subdirectory(ufs) list(APPEND EXTRA_LIBS cmeps_share) - list(APPEND EXTRA_INCLUDES "${CMAKE_BINARY_DIR}/util") + list(APPEND EXTRA_INCLUDES "${CMAKE_BINARY_DIR}/ufs") endif() add_subdirectory(mediator) diff --git a/Makefile b/Makefile deleted file mode 100644 index 60e46b200..000000000 --- a/Makefile +++ /dev/null @@ -1,77 +0,0 @@ -# BASE_DIR points to root of CMEPS clone -BASE_DIR := $(shell dirname $(realpath $(lastword $(MAKEFILE_LIST)))) - -ifneq ($(origin ESMFMKFILE), environment) -$(error Environment variable ESMFMKFILE was not set.) -endif - -include $(ESMFMKFILE) - -ifndef FC -$(error FC not defined) -endif - -ifndef CC -$(error CC not defined) -endif - -ifndef CXX -$(error CXX not defined) -endif - -ifndef PIO_LIBDIR -$(error PIO_LIBDIR should point to PIO library directory.) -endif - -ifndef PIO_INC -$(error PIO_INC should point to PIO include directory.) -endif - -ifndef INTERNAL_PIO_INIT -INTERNAL_PIO_INIT := 1 -endif -$(info INTERNAL_PIO_INIT is set to $(INTERNAL_PIO_INIT)) - -MEDIATOR_DIR := $(BASE_DIR)/mediator -LIBRARY_MEDIATOR := $(MEDIATOR_DIR)/libcmeps.a -LIBRARY_UTIL := $(BASE_DIR)/util/libcmeps_util.a - -all default: install - -install: $(LIBRARY_MEDIATOR) -ifndef INSTALLDIR - $(error INSTALLDIR not defined for CMEPS installation location) -else - rm -f cmeps.mk.install - @echo "# ESMF self-describing build dependency makefile fragment" > cmeps.mk.install - @echo "# src location: $(PWD)" >> cmeps.mk.install - @echo >> cmeps.mk.install - @echo "ESMF_DEP_FRONT = MED" >> cmeps.mk.install - @echo "ESMF_DEP_INCPATH = $(INSTALLDIR)/include" >> cmeps.mk.install - @echo "ESMF_DEP_CMPL_OBJS = " >> cmeps.mk.install - @echo "ESMF_DEP_LINK_OBJS = $(INSTALLDIR)/libcmeps.a $(INSTALLDIR)/libcmeps_util.a $(PIO_LIBDIR)/libpiof.a $(PIO_LIBDIR)/libpioc.a $(PNETCDF_LD_OPTS)" >> cmeps.mk.install - mkdir -p $(INSTALLDIR) - mkdir -p $(INSTALLDIR)/include - cp -f $(LIBRARY_UTIL) $(INSTALLDIR) - cp -f $(LIBRARY_MEDIATOR) $(INSTALLDIR) - cp -f mediator/*.mod $(INSTALLDIR)/include - cp -f util/*.mod $(INSTALLDIR)/include - cp -f cmeps.mk.install $(INSTALLDIR)/cmeps.mk -endif - -$(LIBRARY_MEDIATOR): $(LIBRARY_UTIL) .FORCE - cd mediator ;\ - exec $(MAKE) PIO_INC=$(PIO_INC) INTERNAL_PIO_INIT=$(INTERNAL_PIO_INIT) - -$(LIBRARY_UTIL): .FORCE - cd util ;\ - exec $(MAKE) PIO_INC=$(PIO_INC) - -.FORCE: - -clean: - cd mediator; \ - exec $(MAKE) clean - cd util; \ - exec $(MAKE) clean - diff --git a/drivers/cime/ensemble_driver.F90 b/cesm/driver/ensemble_driver.F90 similarity index 100% rename from drivers/cime/ensemble_driver.F90 rename to cesm/driver/ensemble_driver.F90 diff --git a/drivers/cime/esm.F90 b/cesm/driver/esm.F90 similarity index 100% rename from drivers/cime/esm.F90 rename to cesm/driver/esm.F90 diff --git a/drivers/cime/esmApp.F90 b/cesm/driver/esmApp.F90 similarity index 100% rename from drivers/cime/esmApp.F90 rename to cesm/driver/esmApp.F90 diff --git a/drivers/cime/esm_time_mod.F90 b/cesm/driver/esm_time_mod.F90 similarity index 100% rename from drivers/cime/esm_time_mod.F90 rename to cesm/driver/esm_time_mod.F90 diff --git a/drivers/cime/esm_utils_mod.F90 b/cesm/driver/esm_utils_mod.F90 similarity index 100% rename from drivers/cime/esm_utils_mod.F90 rename to cesm/driver/esm_utils_mod.F90 diff --git a/drivers/cime/t_driver_timers_mod.F90 b/cesm/driver/t_driver_timers_mod.F90 similarity index 100% rename from drivers/cime/t_driver_timers_mod.F90 rename to cesm/driver/t_driver_timers_mod.F90 diff --git a/drivers/cime/util.F90 b/cesm/driver/util.F90 similarity index 100% rename from drivers/cime/util.F90 rename to cesm/driver/util.F90 diff --git a/cesm/flux_atmocn/shr_flux_mod.F90 b/cesm/flux_atmocn/shr_flux_mod.F90 new file mode 100644 index 000000000..87d8be9d5 --- /dev/null +++ b/cesm/flux_atmocn/shr_flux_mod.F90 @@ -0,0 +1,2299 @@ +module shr_flux_mod + + ! atm/ocn/flux calculations + + ! !USES: + + use shr_kind_mod, only : R8=>SHR_KIND_R8, IN=>SHR_KIND_IN ! shared kinds + use shr_const_mod ! shared constants + use shr_sys_mod ! shared system routines + + implicit none + + private ! default private + + ! !PUBLIC TYPES: + + ! none + + ! !PUBLIC MEMBER FUNCTIONS: + + public :: flux_atmOcn ! computes atm/ocn fluxes + public :: flux_atmOcn_diurnal ! computes atm/ocn fluxes with diurnal cycle + public :: flux_atmOcn_UA ! computes atm/ocn fluxes using University of Ariz algorithm (Zeng et al., 1998) + public :: flux_MOstability ! boundary layer stability scales/functions + public :: shr_flux_adjust_constants ! adjust constant values used in flux calculations. (used by CAM as well) + + ! !PRIVATE MEMBER FUNCTIONS: + private :: psi_ua + private :: qsat_ua + private :: rough_ua + private :: cuberoot + private :: cor30a + private :: psiuo + private :: psit_30 + + ! !PUBLIC DATA MEMBERS: + + integer(IN),parameter,public :: shr_flux_MOwScales = 1 ! w scales option + integer(IN),parameter,public :: shr_flux_MOfunctions = 2 ! functions option + real (R8),parameter,public :: shr_flux_MOgammaM = 3.59_R8 + real (R8),parameter,public :: shr_flux_MOgammaS = 7.86_R8 + + !--- rename kinds for local readability only --- + + integer,parameter :: debug = 0 ! internal debug level + + ! The follow variables are not declared as parameters so that they can be + ! adjusted to support aquaplanet and potentially other simple model modes. + ! The flux_adjust_constants subroutine is called to set the desired + ! values. The default values are from shr_const_mod. Currently they are + ! only used by the flux_atmocn routine. + real(R8) :: loc_zvir = shr_const_zvir + real(R8) :: loc_cpdair = shr_const_cpdair + real(R8) :: loc_cpvir = shr_const_cpvir + real(R8) :: loc_karman = shr_const_karman + real(R8) :: loc_g = shr_const_g + real(R8) :: loc_latvap = shr_const_latvap + real(R8) :: loc_latice = shr_const_latice + real(R8) :: loc_stebol = shr_const_stebol + real(R8) :: loc_tkfrz = shr_const_tkfrz + + ! These control convergence of the iterative flux calculation + ! (For Large and Pond scheme only; not UA or COARE). + real(r8) :: flux_con_tol = 0.0_R8 + integer(IN) :: flux_con_max_iter = 2 + + !--- cold air outbreak parameters (Mahrt & Sun 1995,MWR) ------------- + logical :: use_coldair_outbreak_mod = .false. + real(R8),parameter :: alpha = 1.4_R8 + real(R8),parameter :: maxscl =2._R8 ! maximum wind scaling for flux + real(R8),parameter :: td0 = -10._R8 ! start t-ts for scaling + + character(len=*), parameter :: sourcefile = & + __FILE__ + +!=============================================================================== +contains +!=============================================================================== + + subroutine shr_flux_adjust_constants( & + zvir, cpair, cpvir, karman, gravit, & + latvap, latice, stebol, flux_convergence_tolerance, & + flux_convergence_max_iteration, & + coldair_outbreak_mod) + + ! Adjust local constants. Used to support simple models. + + real(R8), optional, intent(in) :: zvir + real(R8), optional, intent(in) :: cpair + real(R8), optional, intent(in) :: cpvir + real(R8), optional, intent(in) :: karman + real(R8), optional, intent(in) :: gravit + real(R8), optional, intent(in) :: latvap + real(R8), optional, intent(in) :: latice + real(R8), optional, intent(in) :: stebol + real(r8), optional, intent(in) :: flux_convergence_tolerance + integer(in), optional, intent(in) :: flux_convergence_max_iteration + logical, optional, intent(in) :: coldair_outbreak_mod + !---------------------------------------------------------------------------- + + if (present(zvir)) loc_zvir = zvir + if (present(cpair)) loc_cpdair = cpair + if (present(cpvir)) loc_cpvir = cpvir + if (present(karman)) loc_karman = karman + if (present(gravit)) loc_g = gravit + if (present(latvap)) loc_latvap = latvap + if (present(latice)) loc_latice = latice + if (present(stebol)) loc_stebol = stebol + if (present(flux_convergence_tolerance)) flux_con_tol = flux_convergence_tolerance + if (present(flux_convergence_max_iteration)) flux_con_max_iter = flux_convergence_max_iteration + if (present(coldair_outbreak_mod)) use_coldair_outbreak_mod = coldair_outbreak_mod + + end subroutine shr_flux_adjust_constants + + !=============================================================================== + ! !IROUTINE: flux_atmOcn -- internal atm/ocn flux calculation + ! + ! !DESCRIPTION: + ! + ! Internal atm/ocn flux calculation + ! + ! !REVISION HISTORY: + ! 2002-Jun-10 - B. Kauffman - code migrated from cpl5 to cpl6 + ! 2003-Apr-02 - B. Kauffman - taux & tauy now utilize ocn velocity + ! 2003-Apr-02 - B. Kauffman - tref,qref,duu10n mods as per Bill Large + ! 2006-Nov-07 - B. Kauffman - code migrated from cpl6 to share + ! + ! 2011-Mar-13 - J. Nusbaumer - Water Isotope ocean flux added. + + ! 2019-May-16 - Jack Reeves Eyre (UA) and Kai Zhang (PNNL) - + ! Added COARE/Fairall surface flux scheme option + ! (ocn_surface_flux_scheme .eq. 1) based on code from + ! Thomas Toniazzo (Bjerknes Centre, Bergen) ” + !=============================================================================== + SUBROUTINE flux_atmOcn(logunit, nMax ,zbot ,ubot ,vbot ,thbot , & + & qbot ,s16O ,sHDO ,s18O ,rbot , & + & tbot ,us ,vs , & + & ts ,mask , seq_flux_atmocn_minwind, & + & sen ,lat ,lwup , & + & r16O, rhdo, r18O, & + & evap ,evap_16O, evap_HDO, evap_18O, & + & taux ,tauy ,tref ,qref , & + & ocn_surface_flux_scheme, & + & duu10n, ustar_sv ,re_sv ,ssq_sv, & + & missval) + + ! !USES: + use water_isotopes, only: wiso_flxoce !subroutine used to calculate water isotope fluxes. + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + integer(IN),intent(in) :: nMax ! data vector length + integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + integer(IN),intent(in) :: ocn_surface_flux_scheme + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) + real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) + real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) + real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd + real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd + real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + real(R8) ,intent(in) :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- local constants -------------------------------- + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + !!++ Large only + !real(R8),parameter :: cexcd = 0.0346_R8 ! ratio Ch(water)/CD + !real(R8),parameter :: chxcds = 0.018_R8 ! ratio Ch(heat)/CD for stable case + !real(R8),parameter :: chxcdu = 0.0327_R8 ! ratio Ch(heat)/CD for unstable case + !!++ COARE only + real(R8),parameter :: zpbl =700.0_R8 ! PBL depth [m] for gustiness parametriz. + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: iter + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coeff (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coeff (heat) + real(R8) :: ren ! sqrt of neutral exchange coeff (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(r8) :: ustar_prev + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! ? + real(R8) :: xqq ! ? + !!++ Large only + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: psix2 ! stability function at ztref reference height + real(R8) :: alz ! ln(zbot/zref) + real(R8) :: al2 ! ln(zref/ztref) + real(R8) :: u10n ! 10m neutral wind + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + real(R8) :: fac ! vertical interpolation factor + real(R8) :: spval ! local missing value + !!++ COARE only + real(R8) :: zo,zot,zoq ! roughness lengths + real(R8) :: hsb,hlb ! sens & lat heat flxs at zbot + real(R8) :: trf,qrf,urf,vrf ! reference-height quantities + + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + !!++ Large only (formula v*=[c4/U10+c5+c6*U10]*U10 in Large et al. 1994) + real(R8) :: cdn ! function: neutral drag coeff at 10m + !!++ Large only (stability functions) + real(R8) :: psimhu ! function: unstable part of psimh + real(R8) :: psixhu ! function: unstable part of psimx + real(R8) :: Umps ! dummy arg ~ wind velocity (m/s) + real(R8) :: Tk ! dummy arg ~ temperature (K) + real(R8) :: xd ! dummy arg ~ ? + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + cdn(Umps) = 0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn) ' + character(*),parameter :: F00 = "('(flux_atmOcn) ',4a)" + + !------------------------------------------------------------------------------- + ! PURPOSE: + ! computes atm/ocn surface fluxes + ! + ! NOTES: + ! o all fluxes are positive downward + ! o net heat flux = net sw + lw up + lw down + sen + lat + ! o here, tstar = /U*, and qstar = /U*. + ! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) + ! + ! ASSUMPTIONS: + ! Large: + ! o Neutral 10m drag coeff: cdn = .0027/U10 + .000142 + .0000764 U10 + ! o Neutral 10m stanton number: ctn = .0327 sqrt(cdn), unstable + ! ctn = .0180 sqrt(cdn), stable + ! o Neutral 10m dalton number: cen = .0346 sqrt(cdn) + ! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) + ! COARE: + ! o use COAREv3.0 function (tht 22/11/2013) + !------------------------------------------------------------------------------- + + if (debug > 0) write(logunit,F00) "enter" + + if (present(missval)) then + spval = missval + else + spval = shr_const_spval + endif + u10n = spval + rh = spval + psixh = spval + hol=spval + + !--- for cold air outbreak calc -------------------------------- + tdiff= tbot - ts + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Default CESM1.2 + !! = 1 : COARE algorithm + !! = 2 : UA algorithm (separate subroutine) + !!................................................................. + + ! Default flux scheme. + if (ocn_surface_flux_scheme .eq. 0) then + + al2 = log(zref/ztref) + DO n=1,nMax + if (mask(n) /= 0) then + + !--- compute some needed quantities --- + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + if (use_coldair_outbreak_mod) then + ! Cold Air Outbreak Modification: + ! Increase windspeed for negative tbot-ts + ! based on Mahrt & Sun 1995,MWR + + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + endif + endif + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - ts(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + alz = log(zbot(n)/zref) + cp = loc_cpdair*(1.0_R8 + loc_cpvir*ssq) + + !------------------------------------------------------------ + ! first estimate of Z/L and ustar, tstar and qstar + !------------------------------------------------------------ + !--- neutral coefficients, z/L = 0.0 --- + stable = 0.5_R8 + sign(0.5_R8 , delt) + rdn = sqrt(cdn(vmag)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + !(1.0_R8-stable) * chxcdu + stable * chxcds + ren = 0.0346_R8 !cexcd + + !--- ustar, tstar, qstar --- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + ustar_prev = ustar*2.0_R8 + iter = 0 + do while( abs((ustar - ustar_prev)/ustar) > flux_con_tol .and. iter < flux_con_max_iter) + iter = iter + 1 + ustar_prev = ustar + !--- compute stability & evaluate all stability functions --- + hol = loc_karman*loc_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/loc_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coefficient --- + rd = rdn / (1.0_R8 + max(rdn/loc_karman*(alz-psimh), -0.5_r8)) + u10n = vmag * rd / rdn + + !--- update transfer coeffs at 10m and neutral stability --- + rdn = sqrt(cdn(u10n)) + ren = 0.0346_R8 !cexcd + rhn = (1.0_R8-stable)*0.0327_R8 + stable * 0.018_R8 + !(1.0_R8-stable) * chxcdu + stable * chxcds + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/loc_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/loc_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/loc_karman*(alz-psixh)) + + !--- update ustar, tstar, qstar using updated, shifted coeffs -- + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + enddo + if (iter < 1) then + write(logunit,*) ustar,ustar_prev,flux_con_tol,flux_con_max_iter + call shr_sys_abort('No iterations performed in flux_atmocn_mod') + end if + !------------------------------------------------------------ + ! compute the fluxes + !------------------------------------------------------------ + + tau = rbot(n) * ustar * ustar + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- heat flux --- + sen (n) = cp * tau * tstar / ustar + lat (n) = loc_latvap * tau * qstar / ustar + lwup(n) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/loc_latvap + + !---water isotope flux --- + + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq,evap_16O(n), & + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n), & + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + hol = hol*ztref/zbot(n) + xsq = max( 1.0_R8, sqrt(abs(1.0_R8-16.0_R8*hol)) ) + xqq = sqrt(xsq) + psix2 = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + fac = (rh/loc_karman) * (alz + al2 - psixh + psix2 ) + tref(n) = thbot(n) - delt*fac + tref(n) = tref(n) - 0.01_R8*ztref ! pot temp to temp correction + fac = (re/loc_karman) * (alz + al2 - psixh + psix2 ) + qref(n) = qbot(n) - delq*fac + + duu10n(n) = u10n*u10n ! 10m wind speed squared + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv(n) = re + if (present(ssq_sv )) ssq_sv(n) = ssq + + else + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval !water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval !HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval !H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + endif + ENDDO + + else if (ocn_surface_flux_scheme .eq. 1) then + !!................................. + !! use COARE algorithm + !!................................. + + + DO n=1,nMax + if (mask(n) /= 0) then + + !--- compute some needed quantities --- + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + + if (use_coldair_outbreak_mod) then + ! Cold Air Outbreak Modification: + ! Increase windspeed for negative tbot-ts + ! based on Mahrt & Sun 1995,MWR + + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + endif + endif + ssq = 0.98_R8 * qsat(ts(n)) / rbot(n) ! sea surf hum (kg/kg) + + call cor30a(ubot(n),vbot(n),tbot(n),qbot(n),rbot(n) & ! in atm params + & ,us(n),vs(n),ts(n),ssq & ! in surf params + & ,zpbl,zbot(n),zbot(n),zref,ztref,ztref & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,hol,ustar,tstar,qstar & ! out: ss scales + & ,rd,rh,re & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + + ! for the sake of maintaining same defs + hol=zbot(n)/hol + rd=sqrt(rd) + rh=sqrt(rh) + re=sqrt(re) + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- heat flux --- + sen (n) = hsb + lat (n) = hlb + lwup(n) = -shr_const_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/shr_const_latvap + + !---water isotope flux --- + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq, evap_16O(n), & + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n), & + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + tref(n) = trf + qref(n) = qrf + duu10n(n) = urf**2+vrf**2 + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv(n) = re + if (present(ssq_sv )) ssq_sv(n) = ssq + + else + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval ! water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval ! HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval ! H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n (n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + endif + ENDDO + + else + + call shr_sys_abort(subName//" subroutine flux_atmOcn requires ocn_surface_flux_scheme = 0 or 1") + + endif !! ocn_surface_flux_scheme + + END subroutine flux_atmOcn + + !=============================================================================== + ! !IROUTINE: flux_atmOcn_UA -- internal atm/ocn flux calculation + ! + ! !DESCRIPTION: + ! + ! Internal atm/ocn flux calculation + ! using University of Arizona method. + ! + ! Reference: + ! Zeng, X., M. Zhao, and R.E. Dickinson, 1998: Intercomparison of Bulk + ! Aerodynamic Algorithms for the Computation of Sea Surface Fluxes + ! Using TOGA COARE and TAO Data. J. Climate, 11, 2628–2644, + ! https://doi.org/10.1175/1520-0442(1998)011<2628%3AIOBAAF>2.0.CO%3B2 + ! + ! Equation numbers are from this paper. + ! + ! !REVISION HISTORY: + ! 2017-Aug-28 - J. Reeves Eyre - code re-written for E3SM + ! 2018-Oct-30 - J. Reeves Eyre - bug fix and add + ! convective gustiness. + ! 2019-May-08 - J. Reeves Eyre - remove convective gustiness + ! and add cold air outbreak modification. + !=============================================================================== + SUBROUTINE flux_atmOcn_UA(logunit, & + & nMax ,zbot ,ubot ,vbot ,thbot , & + & qbot ,s16O ,sHDO ,s18O ,rbot , & + & tbot , pslv ,us , vs , & + & ts ,mask ,sen ,lat ,lwup , & + & r16O, rhdo, r18O, & + & evap ,evap_16O, evap_HDO, evap_18O, & + & taux ,tauy ,tref ,qref , & + & duu10n, ustar_sv ,re_sv ,ssq_sv, & + & missval) + + + ! !USES: + use water_isotopes, only: wiso_flxoce !subroutine used to calculate water isotope fluxes. + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + integer ,intent(in) :: nMax ! data vector length + integer ,intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) + real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) + real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) + real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd + real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd + real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: pslv (nMax) ! sea level pressure (Pa) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- local constants -------------------------------- + real(R8),parameter :: zetam = -1.574_R8 ! Very unstable zeta cutoff for momentum (-) + real(R8),parameter :: zetat = -0.465_R8 ! Very unstable zeta cutoff for T/q (-) + real(R8),parameter :: umin = 0.1_R8 ! minimum wind speed (m/s) + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + real(R8),parameter :: beta = 1.0_R8 ! constant used in W* calculation (-) + real(R8),parameter :: zpbl = 1000.0_R8 ! PBL height used in W* calculation (m) + real(R8),parameter :: gamma = 0.0098_R8 ! Dry adiabatic lapse rate (K/m) + real(R8),parameter :: onethird = 1.0_R8/3.0_R8 ! Used repeatedly. + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: i ! iteration loop index + real(R8) :: vmag_abs ! surface wind magnitude (m s-1) + real(R8) :: vmag_rel ! surface wind magnitude relative to + ! surface current (m s-1) + real(R8) :: vmag ! surface wind magnitude with large + ! eddy correction and minimum value (m s-1) + ! (This can change on each iteration.) + real(R8) :: thv ! virtual temperature (K) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delth ! potential T difference (K) + real(R8) :: delthv ! virtual potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: ustar ! friction velocity (m s-1) + real(R8) :: qstar ! humidity scaling parameter (kg/kg) + real(R8) :: tstar ! temperature scaling parameter (K) + real(R8) :: thvstar ! virtual temperature scaling parameter (K) + real(R8) :: wstar ! convective velocity scale (m s-1) + real(R8) :: zeta ! dimensionless height (z / Obukhov length) + real(R8) :: obu ! Obukhov length (m) + real(R8) :: tau ! magnitude of wind stress (N m-2) + real(R8) :: cp ! specific heat of moist air (J kg-1 K-1) + real(R8) :: xlv ! Latent heat of vaporization (J kg-1) + real(R8) :: visa ! Kinematic viscosity of dry air (m2 s-1) + real(R8) :: tbot_oC ! Temperature used in visa (deg C) + real(R8) :: rb ! Bulk Richardson number (-) + real(R8) :: zo ! Roughness length for momentum (m) + real(R8) :: zoq ! Roughness length for moisture (m) + real(R8) :: zot ! Roughness length for heat (m) + real(R8) :: u10 ! 10-metre wind speed (m s-1) + real(R8) :: re ! Moisture exchange coefficient for compatibility + ! with default algorithm. + real(R8) :: spval ! local missing value + real(R8) :: loc_epsilon ! Ratio of gas constants (-) + + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn) ' + character(*),parameter :: F00 = "('(flux_atmOcn) ',4a)" + + !----- + ! Straight from original subroutine. + if (debug > 0) write(logunit,F00) "enter" + + if (present(missval)) then + spval = missval + else + spval = shr_const_spval + endif + !----- + + ! Evaluate loc_epsilon. + loc_epsilon = 1.0_R8 / (1.0_R8 + loc_zvir) + + !--- for cold air outbreak calc -------------------------------- + tdiff = tbot - ts + + ! Loop over grid points. + DO n=1,nMax + if (mask(n) /= 0) then + + !-----Calculate some required near surface variables.--------- + vmag_abs = sqrt( ubot(n)**2 + vbot(n)**2 ) + vmag_rel = sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2 ) + + ! For Cold Air Outbreak Modification (based on Mahrt & Sun 1995,MWR): + if (use_coldair_outbreak_mod) then + ! Increase windspeed for negative tbot-ts + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag_rel))),maxscl) + vmag_rel=vmag_rel*vscl + endif + endif + + delth = thbot(n) - ts(n) ! Pot. temp. difference with surface (K) + ! Note this is equivalent to Zeng et al + ! (1998) version = delt + 0.0098*zbot + thv = thbot(n)*(1.0_R8+0.61_R8*qbot(n)) ! Virtual potential temperature (K) + ! EQN (17): + !ssq = 0.98_R8 * qsat_ua(ts(n),ps, & ! Surface specific humidity (kg kg-1) + ! loc_epsilon) + ssq = 0.98_R8 * qsat_ua(ts(n),pslv(n), & ! Surface specific humidity (kg kg-1) + loc_epsilon) + delq = qbot(n) - ssq ! Difference to surface (kg kg-1) + delthv = delth*(1.0_R8+0.61_R8*qbot(n)) + & ! Difference of virtual potential + & 0.61_R8*thbot(n)*delq ! temperature with surface (K) + + xlv = 1.0e+6_R8 * & ! Latent heat of vaporization (J kg-1) + & (2.501_R8 - 0.00237_R8 * (ts(n) - loc_tkfrz)) + tbot_oC = tbot(n) - loc_tkfrz + visa = 1.326e-5_R8 * (1.0_R8 + & ! Kinematic viscosity of dry + & 6.542e-3_R8*tbot_oC + & ! air (m2 s-1) from Andreas (1989) + & 8.301e-6_R8*tbot_oC*tbot_oC - & ! CRREL Rep. 89-11 + & 4.84e-9_R8*tbot_oC*tbot_oC*tbot_oC) + cp = loc_cpdair*(1.0_R8 + loc_cpvir*ssq) ! specific heat of moist air (J kg-1 K-1) + + !-----Initial values of u* and convective velocity.----------- + ustar = 0.06_R8 + wstar = 0.5_R8 + ! Update wind speed if unstable regime. + if (delthv.lt.0.0_R8) then + ! EQN (19) + vmag = sqrt( vmag_rel**2 + beta*beta*wstar*wstar ) + else + ! EQN (18) + vmag = max(umin,vmag_rel) + endif + + !-----Iterate to compute new u* and z0.----------------------- + do i = 1,5 + ! EQN (24) + zo = 0.013_R8*ustar*ustar/loc_g + 0.11_R8*visa/ustar + ! EQN (9) assuming neutral + ustar = loc_karman*vmag/log(zbot(n)/zo) + enddo + + !-----Assess stability.--------------------------------------- + rb = loc_g*zbot(n)*delthv / (thv*vmag*vmag) ! bulk Richardson number + + if(rb.ge.0.0_R8) then + ! Neutral or stable: EQNs (4), (9), (13) and definition of rb. + zeta = rb*log(zbot(n)/zo) / & + & (1.0_R8 - 5.0_R8*min(rb,0.19_R8)) + else + ! Unstable: EQNs (4), (8), (12) and definition of rb. + zeta = rb*log(zbot(n)/zo) + endif + + obu = zbot(n)/zeta ! Obukhov length + obu = sign(max(zbot(n)/10.0_R8, abs(obu)), obu) + + !-----Main iterations (2-10 iterations would be fine).------- + do i=1,10 + + ! Update roughness lengths. + call rough_ua(zo,zot,zoq,ustar,visa) + + ! Wind variables. + zeta = zbot(n) / obu + if (zeta.lt.zetam) then + ! Very unstable regime + ! EQN (7) with extra z0 term. + ustar = loc_karman * vmag / (log(zetam*obu/zo) - & + & psi_ua(1_IN, zetam) + & + & psi_ua(1_IN, zo/obu) + & + & 1.14_R8 * ((-zeta)**onethird - (-zetam)**onethird) ) + else if (zeta.lt.0.0_R8) then + ! Unstable regime + ! EQN (8) with extra z0 term. + ustar = loc_karman * vmag / (log(zbot(n)/zo) - & + & psi_ua(1_IN,zeta) + psi_ua(1_IN,zo/obu) ) + else if (zeta.le.1.0_R8) then + ! Stable regime + ! EQN (9) with extra z0 term. + ustar = loc_karman * vmag / (log(zbot(n)/zo) + & + & 5.0_R8*zeta - 5.0_R8*zo/obu) + else + ! Very stable regime + ! EQN (10) with extra z0 term. + ustar = loc_karman * vmag / (log(obu/zo) + 5.0_R8 - & + & 5.0_R8*zo/obu + & + & (5.0_R8*log(zeta) + zeta - 1.0_R8) ) + endif + + ! Temperature variables. + if(zeta.lt.zetat) then + ! Very unstable regime + ! EQN (11) with extra z0 term. + tstar = loc_karman * delth / (log(zetat*obu/zot) - & + & psi_ua(2_IN, zetat) + & + & psi_ua(2_IN, zot/obu) + & + & 0.8_R8*((-zetat)**(-onethird) - (-zeta)**(-onethird)) ) + else if (zeta.lt.0.0_R8) then + ! Unstable regime + ! EQN (12) with extra z0 term. + tstar = loc_karman * delth / & + & (log(zbot(n)/zot) - psi_ua(2_IN,zeta) + psi_ua(2_IN,zot/obu)) + else if (zeta.le.1.0_R8) then + ! Stable regime + ! EQN (13) with extra z0 term. + tstar = loc_karman * delth / (log(zbot(n)/zot) + & + & 5.0_R8*zeta - 5.0_R8*zot/obu) + else + ! Very stable regime + ! EQN (14) with extra z0 term. + tstar = loc_karman * delth / (log(obu/zot) + & + & 5.0_R8 - 5.0_R8*zot/obu + & + & (5.0_R8*log(zeta) + zeta - 1.0_R8) ) + endif + + ! Humidity variables. + ! This is done with re to give variable to save out like + ! in old algorithm. + if (zeta.lt.zetat) then + ! Very unstable regime + ! EQN (11) with extra z0 term. + re = loc_karman / (log(zetat*obu/zoq) - psi_ua(2_IN,zetat) + & + & psi_ua(2_IN,zoq/obu) + & + & 0.8_R8*((-zetat)**(-onethird) - (-zeta)**(-onethird)) ) + else if (zeta.lt.0.0_R8) then + ! Unstable regime + ! EQN (12) with extra z0 term. + re = loc_karman / & + & (log(zbot(n)/zoq) - psi_ua(2_IN,zeta) + psi_ua(2_IN,zoq/obu)) + else if (zeta.le.1.0_R8) then + ! Stable regime + ! EQN (13) with extra z0 term. + re = loc_karman / & + & (log(zbot(n)/zoq) + 5.0_R8*zeta - 5.0_R8*zoq/obu) + else + ! Very stable regime + ! EQN (14) with extra z0 term. + re = loc_karman / & + & (log(obu/zoq) + 5.0_R8 - 5.0_R8*zoq/obu + & + & (5.0_R8*log(zeta) + zeta - 1.0_R8) ) + endif + qstar = re * delq + + ! Update Obukhov length. + thvstar = tstar*(1.0_R8 + 0.61_R8*qbot(n)) + 0.61_R8*thbot(n)*qstar + ! EQN (4) + obu = ustar*ustar * thv / (loc_karman*loc_g*thvstar) + obu = sign( max(zbot(n)/10.0_R8, abs(obu)) ,obu) + + ! Update wind speed if in unstable regime. + if (delthv.lt.0.0_R8) then + ! EQN (20) + wstar = beta * (-loc_g*ustar*thvstar*zpbl/thv)**onethird + ! EQN (19) + vmag = sqrt(vmag_rel**2 + wstar*wstar) + else + ! EQN (18) + vmag = max(umin,vmag_rel) + endif + + enddo ! End of iterations for ustar, tstar, qstar etc. + + + !-----Calculate fluxes and wind stress.--------------------- + + !--- momentum flux --- + ! This should ensure zero wind stress when (relative) wind speed is zero, + ! components are consistent with total, and we don't ever divide by zero. + ! EQN (21) + tau = rbot(n) * ustar * ustar + taux(n) = tau * (ubot(n)-us(n)) / max(umin, vmag_rel) + tauy(n) = tau * (vbot(n)-vs(n)) / max(umin, vmag_rel) + + !--- heat flux --- + ! EQNs (22) and (23) + sen (n) = cp * rbot(n) * tstar * ustar + lat (n) = xlv * rbot(n) * qstar * ustar + lwup(n) = -loc_stebol * ts(n)**4 + + !--- water flux --- + evap(n) = lat(n)/xlv + + !---water isotope flux --- + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq,evap_16O(n), & + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n), & + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnositcs: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + + zeta = zbot(n) / obu + if (zeta.lt.zetat) then + if (zeta.lt.zetam) then + ! Very unstable regime for U. + ! EQN (7) + u10 = vmag_abs + (ustar/loc_karman) * & + & 1.14_R8 * ((-zref/obu)**onethird - (-zeta)**onethird) + else + ! Unstable regime for U. + ! EQN (8) + u10 = vmag_abs + (ustar/loc_karman) * & + & (log(zref/zbot(n)) - (psi_ua(1_IN,zref/obu) - psi_ua(1_IN,zeta)) ) + endif + ! Very unstable regime for T and q. + ! EQN (11) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & 0.8_R8 * ((-zeta)**(-onethird) - (-ztref/obu)**(-onethird)) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & 0.8_R8 * ((-zeta)**(-onethird) - (-ztref/obu)**(-onethird)) + + else if (zeta.lt.0.0_R8) then + ! Unstable regime. + ! EQN (8) + u10 = vmag_abs + (ustar/loc_karman) * & + & (log(zref/zbot(n)) - (psi_ua(1_IN,zref/obu) - psi_ua(1_IN,zeta)) ) + ! EQN (12) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & (log(ztref/zbot(n)) - (psi_ua(2_IN,ztref/obu) - psi_ua(2_IN,zeta)) ) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & (log(ztref/zbot(n)) - (psi_ua(2_IN,ztref/obu) - psi_ua(2_IN,zeta)) ) + else if (zeta.le.1.0_R8) then + ! Stable regime. + ! EQN (9) + u10 = vmag_abs + (ustar/loc_karman) * & + & (log(zref/zbot(n)) + 5.0_R8*zref/obu - 5.0_R8*zeta) + ! EQN (13) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & (log(ztref/zbot(n)) + 5.0_R8*ztref/obu - 5.0_R8*zeta) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & (log(ztref/zbot(n)) + 5.0_R8*ztref/obu - 5.0_R8*zeta) + else + ! Very stable regime. + ! EQN (10) + u10 = vmag_abs + (ustar/loc_karman) * & + & (5.0_R8*log(zref/zbot(n)) + zref/obu - zeta) + ! EQN (14) + tref(n) = thbot(n) + (tstar/loc_karman) * & + & (5.0_R8*log(ztref/zbot(n)) + ztref/obu - zeta) + qref(n) = qbot(n) + (qstar/loc_karman) * & + & (5.0_R8*log(ztref/zbot(n)) + ztref/obu - zeta) + + endif + + tref(n) = tref(n) - gamma*ztref ! pot. temp to temp correction + duu10n(n) = u10*u10 ! 10m wind speed squared + + !------------------------------------------------------------ + ! optional diagnostics, needed for water tracer fluxes (dcn) + !------------------------------------------------------------ + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(ssq_sv )) ssq_sv(n) = ssq + if (present(re_sv )) re_sv(n) = re + + + else + + !------------------------------------------------------------ + ! no valid data here -- out of ocean domain + !------------------------------------------------------------ + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval !water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval !HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval !H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + ! Optional diagnostics too: + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + + endif + + ENDDO ! loop over grid points + + END subroutine flux_atmOcn_UA + + !=============================================================================== + ! Functions/subroutines used by UA surface flux scheme. + !=============================================================================== + + ! Stability function for rb < 0 + + real(R8) function psi_ua(k,zeta) + + implicit none + + !-----Input variables.---------- + integer(IN), intent(in) :: k ! Indicates whether this is for momentum (k=1) + ! or for heat/moisture (k=2) + real(R8), intent(in) :: zeta ! Dimensionless height (=z/L) + + !-----Local variables.---------- + real(R8) :: chik ! Function of zeta. + + ! EQN (16) + chik = (1.0_R8 - 16.0_R8*zeta)**0.25_R8 + + if(k.eq.1) then + ! EQN (15) for momentum + psi_ua = 2.0_R8 * log((1.0_R8 + chik)*0.5_R8) + & + & log((1.0_R8 + chik*chik)*0.5_R8) - & + & 2.0_R8 * atan(chik) + 2.0_R8 * atan(1.0_R8) + else + ! EQN (15) for heat/moisture + psi_ua = 2.0_R8 * log((1.0_R8 + chik*chik)*0.5_R8) + endif + + end function psi_ua + + !=============================================================================== + ! Uses Tetens' formula for saturation vapor pressure from + ! Buck(1981) JAM 20, 1527-1532 + + real(R8) function qsat_ua(t,p,loc_epsilon) + + implicit none + + !-----Input variables.---------- + real(R8), intent(in) :: t ! temperature (K) + real(R8), intent(in) :: p ! pressure (Pa) + real(R8), intent(in) :: loc_epsilon ! Ratio of gas constants (-) + + !-----Local variables.---------- + real(R8) :: esat ! saturated vapor pressure (hPa) + + ! Calculate saturated vapor pressure in hPa. + esat = (1.0007_R8 + 0.00000346_R8 * (p/100.0_R8)) * 6.1121_R8 * & + & exp(17.502_R8 * (t - loc_tkfrz) / (240.97_R8 + (t - loc_tkfrz))) + + ! Convert to specific humidity (kg kg-1). + qsat_ua = loc_epsilon * esat / ((p/100.0_R8) - (1.0_R8 - loc_epsilon)*esat) + + end function qsat_ua + + !=============================================================================== + ! Calculate roughness lengths: zo, zot, zoq. + + subroutine rough_ua(zo,zot,zoq,ustar,visa) + + implicit none + + !-----Input variables.---------- + real(R8), intent(in) :: ustar ! friction velocity (m s-1) + real(R8), intent(in) :: visa ! kinematic viscosity of dry air (m2 s-1) + + !-----Output variables.--------- + real(R8), intent(out) :: zo ! roughness length for momentum (m) + real(R8), intent(out) :: zot ! roughness length for heat (m) + real(R8), intent(out) :: zoq ! roughness length for water vapor (m) + + !-----Local variables.---------- + real(R8) :: re_rough ! Rougness Reynold's number (-) + real(R8) :: xq ! Logarithm of roughness length ratios (moisture) + real(R8) :: xt ! Logarithm of roughness length ratios (heat) + + zo = 0.013_R8*ustar*ustar/loc_g + 0.11_R8*visa/ustar ! EQN (24) + re_rough = ustar*zo/visa ! By definition. + xq = 2.67_R8*re_rough**0.25_R8 - 2.57_R8 ! EQN (25) + xt = xq ! EQN (26) + zoq = zo/exp(xq) ! By definition of xq + zot = zo/exp(xt) ! By definition of xt + + end subroutine rough_ua + + real(R8) elemental function cuberoot(a) + real(R8), intent(in) :: a + real(R8), parameter :: one_third = 1._R8/3._R8 + cuberoot = sign(abs(a)**one_third, a) + end function cuberoot + + !=============================================================================== + ! !IROUTINE: flux_atmOcn_diurnal -- internal atm/ocn flux calculation + ! + ! !DESCRIPTION: + ! + ! Internal atm/ocn flux calculation + ! + ! !REVISION HISTORY: + ! 2002-Jun-10 - B. Kauffman - code migrated from cpl5 to cpl6 + ! 2003-Apr-02 - B. Kauffman - taux & tauy now utilize ocn velocity + ! 2003-Apr-02 - B. Kauffman - tref,qref,duu10n mods as per Bill Large + ! 2006-Nov-07 - B. Kauffman - code migrated from cpl6 to share + !=============================================================================== + SUBROUTINE flux_atmOcn_diurnal & + (logunit, nMax ,zbot ,ubot ,vbot ,thbot , & + qbot ,s16O ,sHDO ,s18O ,rbot , & + tbot ,us ,vs , & + ts ,mask , seq_flux_atmocn_minwind, & + sen ,lat ,lwup , & + r16O ,rhdo ,r18O ,evap ,evap_16O, & + evap_HDO ,evap_18O, & + taux ,tauy ,tref ,qref , & + uGust, lwdn , swdn , swup, prec , & + swpen, ocnsal, ocn_prognostic, flux_diurnal, & + ocn_surface_flux_scheme, & + latt, long , warm , salt , speed, regime, & + warmMax, windMax, qSolAvg, windAvg, & + warmMaxInc, windMaxInc, qSolInc, windInc, nInc, & + tBulk, tSkin, tSkin_day, tSkin_night, & + cSkin, cSkin_night, secs ,dt, & + duu10n, ustar_sv ,re_sv ,ssq_sv, & + missval, cold_start ) + ! !USES: + + use water_isotopes, only: wiso_flxoce !subroutine used to calculate water isotope fluxes. + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + + !--- input arguments -------------------------------- + integer ,intent(in) :: logunit + integer(IN),intent(in) :: nMax ! data vector length + integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain + real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) + real(R8) ,intent(in) :: ubot (nMax) ! atm u wind (m/s) + real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (m/s) + real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) + real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (kg/kg) + real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) + real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) + real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) + real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd + real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd + real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd + real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) + real(R8) ,intent(in) :: tbot (nMax) ! atm T (K) + real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) + real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) + real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) + + !--- new arguments ------------------------------- + real(R8),intent(inout) :: swpen (nMax) ! NEW + real(R8),intent(inout) :: ocnsal(nMax) ! NEW (kg/kg) + logical ,intent(in) :: ocn_prognostic ! NEW + logical ,intent(in) :: flux_diurnal ! NEW logical for diurnal on/off + integer(IN) ,intent(in) :: ocn_surface_flux_scheme + + real(R8),intent(in) :: uGust (nMax) ! NEW not used + real(R8),intent(in) :: lwdn (nMax) ! NEW + real(R8),intent(in) :: swdn (nMax) ! NEW + real(R8),intent(in) :: swup (nMax) ! NEW + real(R8),intent(in) :: prec (nMax) ! NEW + real(R8),intent(in) :: latt (nMax) ! NEW + real(R8),intent(in) :: long (nMax) ! NEW + real(R8),intent(inout) :: warm (nMax) ! NEW + real(R8),intent(inout) :: salt (nMax) ! NEW + real(R8),intent(inout) :: speed (nMax) ! NEW + real(R8),intent(inout) :: regime(nMax) ! NEW + real(R8),intent(out) :: warmMax(nMax) ! NEW + real(R8),intent(out) :: windMax(nMax) ! NEW + real(R8),intent(inout) :: qSolAvg(nMax) ! NEW + real(R8),intent(inout) :: windAvg(nMax) ! NEW + real(R8),intent(inout) :: warmMaxInc(nMax) ! NEW + real(R8),intent(inout) :: windMaxInc(nMax) ! NEW + real(R8),intent(inout) :: qSolInc(nMax) ! NEW + real(R8),intent(inout) :: windInc(nMax) ! NEW + real(R8),intent(inout) :: nInc(nMax) ! NEW + + real(R8),intent(out) :: tBulk (nMax) ! NEW + real(R8),intent(out) :: tSkin (nMax) ! NEW + real(R8),intent(out) :: tSkin_day (nMax) ! NEW + real(R8),intent(out) :: tSkin_night (nMax) ! NEW + real(R8),intent(out) :: cSkin (nMax) ! NEW + real(R8),intent(out) :: cSkin_night (nMax) ! NEW + integer(IN),intent(in) :: secs ! NEW elsapsed seconds in day (GMT) + integer(IN),intent(in) :: dt ! NEW + logical ,intent(in) :: cold_start ! cold start flag + real(R8),intent(in) :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) + + real(R8),intent(in) ,optional :: missval ! masked value + + !--- output arguments ------------------------------- + real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) + real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) + real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) + real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) + real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) + real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) + real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) + real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) + real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) + real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 + + real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar + real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) + real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) + + + !--- local constants -------------------------------- + real(R8),parameter :: zref = 10.0_R8 ! reference height (m) + real(R8),parameter :: ztref = 2.0_R8 ! reference height for air T (m) + + real(R8),parameter :: lambdaC = 6.0_R8 + real(R8),parameter :: lambdaL = 0.0_R8 + real(R8),parameter :: doLMax = 1.0_R8 + real(R8),parameter :: pwr = 0.2_R8 + real(R8),parameter :: Rizero = 1.0_R8 + real(R8),parameter :: NUzero = 40.0e-4_R8 + real(R8),parameter :: Prandtl = 1.0_R8 + real(R8),parameter :: kappa0 = 0.2e-4_R8 + + real(R8),parameter :: F0 = 0.5_R8 + real(R8),parameter :: F1 = 0.15_R8 + real(R8),parameter :: R1 = 10.0_R8 + + real(R8),parameter :: Ricr = 0.30_R8 + real(R8),parameter :: tiny = 1.0e-12_R8 + real(R8),parameter :: tiny2 = 1.0e-6_R8 + real(R8),parameter :: pi = SHR_CONST_PI + + !!++ COARE only + real(R8),parameter :: zpbl =700.0_R8 ! PBL depth [m] for gustiness parametriz. + + !--- local variables -------------------------------- + integer(IN) :: n ! vector loop index + integer(IN) :: iter ! iteration loop index + integer(IN) :: lsecs ! local seconds elapsed + integer(IN) :: lonsecs ! incrememnt due to lon offset + real(R8) :: vmag ! surface wind magnitude (m/s) + real(R8) :: ssq ! sea surface humidity (kg/kg) + real(R8) :: delt ! potential T difference (K) + real(R8) :: delq ! humidity difference (kg/kg) + real(R8) :: stable ! stability factor + real(R8) :: rdn ! sqrt of neutral exchange coeff (momentum) + real(R8) :: rhn ! sqrt of neutral exchange coeff (heat) + real(R8) :: ren ! sqrt of neutral exchange coeff (water) + real(R8) :: rd ! sqrt of exchange coefficient (momentum) + real(R8) :: rh ! sqrt of exchange coefficient (heat) + real(R8) :: re ! sqrt of exchange coefficient (water) + real(R8) :: ustar ! ustar + real(R8) :: ustar_prev ! ustar + real(R8) :: qstar ! qstar + real(R8) :: tstar ! tstar + real(R8) :: hol ! H (at zbot) over L + real(R8) :: xsq ! ? + real(R8) :: xqq ! ? + real(R8) :: psimh ! stability function at zbot (momentum) + real(R8) :: psixh ! stability function at zbot (heat and water) + real(R8) :: psix2 ! stability function at ztref reference height + real(R8) :: alz ! ln(zbot/zref) + real(R8) :: al2 ! ln(zref/ztref) + real(R8) :: u10n ! 10m neutral wind + real(R8) :: tau ! stress at zbot + real(R8) :: cp ! specific heat of moist air + real(R8) :: fac ! vertical interpolation factor + real(R8) :: DTiter ! + real(R8) :: DSiter ! + real(R8) :: DViter ! + + real(R8) :: Dcool ! + real(R8) :: Qdel ! net cool skin heating + real(R8) :: Hd ! net heating above -z=d + real(R8) :: Hb ! net kinematic heating above -z = delta + real(R8) :: lambdaV ! + real(R8) :: Fd ! net fresh water forcing above -z=d + real(R8) :: ustarw ! surface wind forcing of layer above -z=d + + real(R8) :: Qsol ! solar heat flux (W/m2) + real(R8) :: Qnsol ! non-solar heat flux (W/m2) + + real(R8) :: SSS ! sea surface salinity + real(R8) :: alphaT ! + real(R8) :: betaS ! + + real(R8) :: doL ! ocean forcing stablity parameter + real(R8) :: Rid ! Richardson number at depth d + real(R8) :: Ribulk ! Bulk Richardson number at depth d + real(R8) :: FofRi ! Richardon number dependent diffusivity + real(R8) :: Smult ! multiplicative term based on regime + real(R8) :: Sfact ! multiplicative term based on regime + real(R8) :: Kdiff ! diffusive term based on regime + real(R8) :: Kvisc ! viscosity term based on regime + real(R8) :: rhocn ! + real(R8) :: rcpocn ! + real(R8) :: Nreset ! value for multiplicative reset factor + logical :: lmidnight + logical :: ltwopm + logical :: ltwoam + logical :: lfullday + integer :: nsum + real(R8) :: pexp ! eqn 19 + real(R8) :: AMP ! eqn 18 + real(R8) :: dif3 + real(R8) :: phid + real(R8) :: spval + + !!++ COARE only + real(R8) :: zo,zot,zoq ! roughness lengths + real(R8) :: hsb,hlb ! sens & lat heat flxs at zbot + real(R8) :: trf,qrf,urf,vrf ! reference-height quantities + + !--- local functions -------------------------------- + real(R8) :: qsat ! function: the saturation humididty of air (kg/m^3) + real(R8) :: cdn ! function: neutral drag coeff at 10m + real(R8) :: psimhu ! function: unstable part of psimh + real(R8) :: psixhu ! function: unstable part of psimx + real(R8) :: Umps ! dummy arg ~ wind velocity (m/s) + real(R8) :: Tk ! dummy arg ~ temperature (K) + real(R8) :: xd ! dummy arg ~ ? + real(R8) :: molvisc ! molecular viscosity + real(R8) :: molPr ! molecular Prandtl number + + !--- for cold air outbreak calc -------------------------------- + real(R8) :: tdiff(nMax) ! tbot - ts + real(R8) :: vscl + + qsat(Tk) = 640380.0_R8 / exp(5107.4_R8/Tk) + cdn(Umps) = 0.0027_R8 / Umps + 0.000142_R8 + 0.0000764_R8 * Umps + psimhu(xd) = log((1.0_R8+xd*(2.0_R8+xd))*(1.0_R8+xd*xd)/8.0_R8) - 2.0_R8*atan(xd) + 1.571_R8 + psixhu(xd) = 2.0_R8 * log((1.0_R8 + xd*xd)/2.0_R8) + molvisc(Tk) = 1.623e-6_R8 * exp((-1.0_R8*(Tk-273.15_R8))/45.2_R8) + molPr(Tk) = 11.64_R8 * exp((-1.0_R8*(Tk-273.15_R8))/40.7_R8) + + !--- formats ---------------------------------------- + character(*),parameter :: subName = '(flux_atmOcn_diurnal) ' + character(*),parameter :: F00 = "('(flux_atmOcn_diurnal) ',4a)" + + !------------------------------------------------------------------------------- + ! PURPOSE: + ! computes atm/ocn surface fluxes + ! + ! NOTES: + ! o all fluxes are positive downward + ! o net heat flux = net sw + lw up + lw down + sen + lat + ! o here, tstar = /U*, and qstar = /U*. + ! o wind speeds should all be above a minimum speed (eg. 1.0 m/s) + ! + ! ASSUMPTIONS: + ! o Neutral 10m drag coeff: cdn = .0027/U10 + .000142 + .0000764 U10 + ! o Neutral 10m stanton number: ctn = .0327 sqrt(cdn), unstable + ! ctn = .0180 sqrt(cdn), stable + ! o Neutral 10m dalton number: cen = .0346 sqrt(cdn) + ! o The saturation humidity of air at T(K): qsat(T) (kg/m^3) + !------------------------------------------------------------------------------- + + if (debug > 0) write(logunit,F00) "enter" + + ! this is especially for flux_diurnal calculations + if (.not. flux_diurnal) then + write(logunit,F00) "ERROR: flux_diurnal must be true" + call shr_sys_abort(subName//"flux diurnal must be true") + endif + spval = shr_const_spval + rh = spval + dviter = spval + dtiter = spval + dsiter = spval + al2 = log(zref/ztref) + !--- for cold air outbreak calc -------------------------------- + tdiff= tbot - ts + + ! equations 18 and 19 + AMP = 1.0_R8/F0-1.0_R8 + pexp = log( (1.0_R8/F1-F0) / (1.0_R8-F0) ) / log(R1) + + if (.not. ocn_prognostic) then + ! Set swpen and ocean salinity from following analytic expressions + swpen(:) = 0.67_R8*(exp((-1._R8*shr_const_zsrflyr)/1.0_R8)) + & + 0.33_R8*exp((-1._R8*shr_const_zsrflyr)/17.0_R8) + ocnsal(:) = shr_const_ocn_ref_sal/1000.0_R8 + else + ! use swpen and ocnsal from input argument + endif + + if (cold_start) then + write(logunit,F00) "Initialize diurnal cycle fields" + warm (:) = 0.0_R8 + salt (:) = 0.0_R8 + speed (:) = 0.0_R8 + regime (:) = 0.0_R8 + qSolAvg (:) = 0.0_R8 + windAvg (:) = 0.0_R8 + warmMax (:) = 0.0_R8 + windMax (:) = 0.0_R8 + warmMaxInc (:) = 0.0_R8 + windMaxInc (:) = 0.0_R8 + qSolInc (:) = 0.0_R8 + windInc (:) = 0.0_R8 + nInc (:) = 0.0_R8 + tSkin_day (:) = ts(:) + tSkin_night(:) = ts(:) + cSkin_night(:) = 0.0_R8 + endif + + DO n=1,nMax + + if (mask(n) /= 0) then + + !--- compute some initial and useful flux quantities --- + + vmag = max(seq_flux_atmocn_minwind, sqrt( (ubot(n)-us(n))**2 + (vbot(n)-vs(n))**2) ) + if (use_coldair_outbreak_mod) then + ! Cold Air Outbreak Modification: + ! Increase windspeed for negative tbot-ts + ! based on Mahrt & Sun 1995,MWR + + if (tdiff(n).lt.td0) then + vscl=min((1._R8+alpha*(abs(tdiff(n)-td0)**0.5_R8/abs(vmag))),maxscl) + vmag=vmag*vscl + endif + endif + alz = log(zbot(n)/zref) + hol = 0.0 + psimh = 0.0 + psixh = 0.0 + rdn = sqrt(cdn(vmag)) + + tBulk(n) = ts(n)+warm(n) ! first guess for tBulk from read in ts,warm + tSkin(n) = tBulk(n) + Qsol = swdn(n) + swup(n) + SSS = 1000.0_R8*ocnsal(n)+salt(n) + lambdaV = lambdaC + + alphaT = 0.000297_R8*(1.0_R8+0.0256_R8*(ts(n)-298.15_R8)+0.003_R8*(SSS - 35.0_R8)) + betaS = 0.000756_R8*(1.0_R8-0.0016_R8*(ts(n)-298.15_R8)) + rhocn = 1023.342_R8*(1.0_R8-0.000297_R8*(ts(n)-298.15_R8)+0.000756_R8 * (SSS - 35.0_R8)) + rcpocn = rhocn * 3990.0_R8*(1.0_R8-0.0012_R8*(SSS - 35.0_R8)) + + Rid = shr_const_g * (alphaT*warm(n) - betaS*salt(n)) *pwr*shr_const_zsrflyr / & + ( pwr*MAX(tiny,speed(n)) )**2 + + Ribulk = 0.0 + + !---------------------------------------------------------- + ! convert elapsed time from GMT to local & + ! check elapsed time. reset warm if near lsecs = reset_sec + !---------------------------------------------------------- + Nreset = 1.0_R8 + + lonsecs = ceiling(long(n)/360.0_R8*86400.0) + lsecs = mod(secs + lonsecs,86400) + + lmidnight = (lsecs >= 0 .and. lsecs < dt) ! 0 = midnight + ltwopm = (lsecs >= 48600 .and. lsecs < 48600+dt) ! 48600 = 1:30pm + ltwoam = (lsecs >= 5400 .and. lsecs < 5400 +dt) ! 5400 = 1:30am + lfullday = (lsecs > 86400-dt .and. lsecs <= 86400) + nsum = nint(nInc(n)) + + if ( lmidnight ) then + Regime(n) = 1.0_R8 ! RESET DIURNAL + warm(n) = 0.0_R8 + salt(n) = 0.0_R8 + speed(n) = 0.0_R8 + endif + + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - tBulk(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + cp = shr_const_cpdair*(1.0_R8 + shr_const_cpvir*ssq) + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Default E3SMv1 + !! = 1 : COARE algorithm + !!................................................................. + if (ocn_surface_flux_scheme .eq. 0) then! use Large algorithm + stable = 0.5_R8 + sign(0.5_R8 , delt) + + + !--- shift wind speed using old coefficient and stability function + + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- initial neutral transfer coeffs at 10m + rdn = sqrt(cdn(u10n)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- initial ustar, tstar, qstar --- + ustar = rdn * vmag + tstar = rhn * delt + qstar = ren * delq + + else if (ocn_surface_flux_scheme .eq. 1) then! use COARE algorithm + + call cor30a(ubot(n),vbot(n),tbot(n),qbot(n),rbot(n) & ! in atm params + & ,us(n),vs(n),tBulk(n),ssq & ! in surf params (NB ts -> tBulk) + & ,zpbl,zbot(n),zbot(n),zref,ztref,ztref & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,hol,ustar,tstar,qstar & ! out: ss scales + & ,rd,rh,re & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + ! for the sake of maintaining same defs + hol=zbot(n)/hol + rd=sqrt(rd) + rh=sqrt(rh) + re=sqrt(re) + + ELSE ! N.B.: *no* valid ocn_surface_flux_scheme=2 option if diurnal=.true. + + call shr_sys_abort(subName//" flux_atmOcn_diurnal requires ocn_surface_flux_scheme = 0 or 1") + ENDIF + + ustar_prev = ustar * 2.0_R8 + iter = 0 + ! --- iterate --- + ! Originally this code did three iterations while the non-diurnal version did two + ! So in the new loop this is <= flux_con_max_iter instead of < so that the same defaults + ! will give the same answers in both cases. + do while( abs((ustar - ustar_prev)/ustar) > flux_con_tol .and. iter <= flux_con_max_iter) + iter = iter + 1 + ustar_prev = ustar + !------------------------------------------------------------ + ! iterate to converge on FLUXES Z/L, ustar, tstar and qstar + ! and on Rid in the DIURNAL CYCLE + !------------------------------------------------------------ + Smult = 0.0_R8 + Sfact = 0.0_R8 + Kdiff = 0.0_R8 + Kvisc = 0.0_R8 + dif3 = 0.0_R8 + + ustarw = ustar*sqrt(max(tiny,rbot(n)/rhocn)) + Qnsol = lwdn(n) - shr_const_stebol*(tSkin(n))**4 + & + rbot(n)*ustar*(cp*tstar + shr_const_latvap*qstar) + Hd = (Qnsol + Qsol*(1.0_R8-swpen(n)) ) / rcpocn + Fd = (prec(n) + rbot(n)*ustar*qstar ) * SSS / rhocn + + !--- COOL SKIN EFFECT --- + Dcool = lambdaV*molvisc(tBulk(n)) / ustarw + Qdel = Qnsol + Qsol * & + (0.137_R8 + 11.0_R8*Dcool - 6.6e-5/Dcool *(1.0_R8 - exp((-1.0_R8*Dcool)/8.0e-4))) + Hb = (Qdel/rcpocn)+(Fd*betaS/alphaT) + Hb = min(Hb , 0.0_R8) + + ! lambdaV = lambdaC*(1.0_R8 + ( (0.0_R8-Hb)*16.0_R8*molvisc(tBulk(n))* & + ! shr_const_g*alphaT*molPr(tBulk(n))**2/ustarw**4)**0.75)**(-1._R8/3._R8) + lambdaV = 6.5_R8 + cSkin(n) = MIN(0.0_R8, lambdaV * molPr(tBulk(n)) * Qdel / ustarw / rcpocn ) + + !--- REGIME --- + doL = shr_const_zsrflyr*shr_const_karman*shr_const_g* & + (alphaT*Hd + betaS*Fd ) / ustarw**3 + Rid = MAX(0.0_R8,Rid) + Smult = dt * (pwr+1.0_R8) / (shr_const_zsrflyr*pwr) + Sfact = dt * (pwr+1.0_R8) / (shr_const_zsrflyr)**2 + FofRi = 1.0_R8/(1.0_R8 + AMP*(Rid/Rizero)**pexp) + + if ( (doL.gt.0.0_R8) .and. (Qsol.gt.0.0) ) then + phid = MIN(1.0_R8 + 5.0_R8 * doL, 5.0_R8 + doL) + FofRi = 1.0_R8/(1.0_R8 + AMP*(Rid/Rizero)**pexp) + dif3 = (kappa0 + NUzero *FofRi) + + if ((doL.le.lambdaL).and.(NINT(regime(n)).le.2)) then + regime(n) = 2.0_R8 + Kdiff = shr_const_karman * ustarw * shr_const_zsrflyr / phid + Kvisc = Kdiff * (1.0_R8 - doL/lambdaL)**2 + & + dif3 * (doL/lambdaL)**2 * (3.0_R8 - 2.0_R8 * doL/lambdaL) + Kdiff = Kvisc + else + regime(n) = 3.0_R8 + Kdiff = kappa0 + NUzero * FofRi + Kvisc = Prandtl* kappa0 + NUzero * FofRi + endif + else + if (regime(n).eq.1.0_R8) then + Smult = 0.0_R8 + else + if (Ribulk .gt. Ricr) then + regime(n) = 3.0_R8 + Kdiff = kappa0 + NUzero * FofRi + Kvisc = Prandtl* kappa0 + NUzero * FofRi + else + regime(n) = 4.0_R8 + Kdiff = shr_const_karman*ustarw*shr_const_zsrflyr *cuberoot(1.0_R8-7.0_R8*doL) + Kvisc = Kdiff + endif + endif + + endif + + !--- IMPLICIT INTEGRATION --- + + DTiter = (warm(n) +(Smult*Hd)) /(1.+ Sfact*Kdiff) + DSiter = (salt(n) -(Smult*Fd)) /(1.+ Sfact*Kdiff) + DViter = (speed(n) +(Smult*ustarw*ustarw)) /(1.+ Sfact*Kvisc) + DTiter = MAX( 0.0_R8, DTiter) + DViter = MAX( 0.0_R8, DViter) + + Rid =(shr_const_g*(alphaT*DTiter-betaS*DSiter)*pwr*shr_const_zsrflyr) / & + (pwr*MAX(tiny,DViter))**2 + Ribulk = Rid * pwr + Ribulk = 0.0_R8 + tBulk(n) = ts(n) + DTiter + tSkin(n) = tBulk(n) + cskin(n) + + !--need to update ssq,delt,delq as function of tBulk ---- + + ssq = 0.98_R8 * qsat(tBulk(n)) / rbot(n) ! sea surf hum (kg/kg) + delt = thbot(n) - tBulk(n) ! pot temp diff (K) + delq = qbot(n) - ssq ! spec hum dif (kg/kg) + + !--- UPDATE FLUX ITERATION --- + + !!................................................................. + !! ocn_surface_flux_scheme = 0 : Default CESM1.2 + !! = 1 : COARE algorithm + !!................................................................. + if (ocn_surface_flux_scheme .eq. 0) then! use Large algorithm + + !--- compute stability & evaluate all stability functions --- + hol = shr_const_karman*shr_const_g*zbot(n)* & + (tstar/thbot(n)+qstar/(1.0_R8/shr_const_zvir+qbot(n)))/ustar**2 + hol = sign( min(abs(hol),10.0_R8), hol ) + stable = 0.5_R8 + sign(0.5_R8 , hol) + xsq = max(sqrt(abs(1.0_R8 - 16.0_R8*hol)) , 1.0_R8) + xqq = sqrt(xsq) + psimh = -5.0_R8*hol*stable + (1.0_R8-stable)*psimhu(xqq) + psixh = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + + !--- shift wind speed using old coefficient and stability function --- + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + u10n = vmag * rd / rdn + + !--- update neutral transfer coeffs at 10m + rdn = sqrt(cdn(u10n)) + rhn = (1.0_R8-stable) * 0.0327_R8 + stable * 0.018_R8 + ren = 0.0346_R8 + + !--- shift all coeffs to measurement height and stability --- + rd = rdn / (1.0_R8 + rdn/shr_const_karman*(alz-psimh)) + rh = rhn / (1.0_R8 + rhn/shr_const_karman*(alz-psixh)) + re = ren / (1.0_R8 + ren/shr_const_karman*(alz-psixh)) + + ustar = rd * vmag + tstar = rh * delt + qstar = re * delq + + !--- heat flux --- + + tau = rbot(n) * ustar * ustar + sen (n) = cp * tau * tstar / ustar + lat (n) = shr_const_latvap * tau * qstar / ustar + + else if (ocn_surface_flux_scheme .eq. 1) then! use COARE algorithm + + call cor30a(ubot(n),vbot(n),tbot(n),qbot(n),rbot(n) & ! in atm params + & ,us(n),vs(n),tBulk(n),ssq & ! in surf params (NB ts -> tBulk) + & ,zpbl,zbot(n),zbot(n),zref,ztref,ztref & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,hol,ustar,tstar,qstar & ! out: ss scales + & ,rd,rh,re & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + ! for the sake of maintaining same defs + hol=zbot(n)/hol + rd=sqrt(rd) + rh=sqrt(rh) + re=sqrt(re) + + !--- heat flux --- + + sen (n) = hsb + lat (n) = hlb + + else ! N.B.: NO ocn_surface_flux_scheme=2 option + call shr_sys_abort(subName//", flux_diurnal requires ocn_surface_flux_scheme = 0 or 1") + endif + + ENDDO ! end iteration loop + if (iter < 1) then + call shr_sys_abort('No iterations performed ') + end if + !--- COMPUTE FLUXES TO ATMOSPHERE AND OCEAN --- + + ! Now calculated further up in subroutine. + !tau = rbot(n) * ustar * ustar + !sen (n) = cp * tau * tstar / ustar + !lat (n) = shr_const_latvap * tau * qstar / ustar + + !--- momentum flux --- + taux(n) = tau * (ubot(n)-us(n)) / vmag + tauy(n) = tau * (vbot(n)-vs(n)) / vmag + + !--- LW radiation --- + lwup(n) = -shr_const_stebol * Tskin(n)**4 + + !--- water flux --- + evap(n) = lat(n)/shr_const_latvap + + !---water isotope flux --- + !!ZZZ bugfix to be done + call wiso_flxoce(2,rbot(n),zbot(n),s16O(n),ts(n),r16O(n),ustar,re,ssq, evap_16O(n),& + qbot(n),evap(n)) + call wiso_flxoce(3,rbot(n),zbot(n),sHDO(n),ts(n),rHDO(n),ustar,re,ssq, evap_HDO(n),& + qbot(n),evap(n)) + call wiso_flxoce(4,rbot(n),zbot(n),s18O(n),ts(n),r18O(n),ustar,re,ssq, evap_18O(n),& + qbot(n),evap(n)) + + !------------------------------------------------------------ + ! compute diagnostics: 2m ref T & Q, 10m wind speed squared + !------------------------------------------------------------ + + if (ocn_surface_flux_scheme .eq. 0) then ! use Large algorithm + + hol = hol*ztref/zbot(n) + xsq = max( 1.0_R8, sqrt(abs(1.0_R8-16.0_R8*hol)) ) + xqq = sqrt(xsq) + psix2 = -5.0_R8*hol*stable + (1.0_R8-stable)*psixhu(xqq) + fac = (rh/shr_const_karman) * (alz + al2 - psixh + psix2 ) + tref(n) = thbot(n) - delt*fac + tref(n) = tref(n) - 0.01_R8*ztref ! pot temp to temp correction + fac = (re/shr_const_karman) * (alz + al2 - psixh + psix2 ) + qref(n) = qbot(n) - delq*fac + + duu10n(n) = u10n*u10n ! 10m wind speed squared + + else if (ocn_surface_flux_scheme .eq. 1) then! use COARE algorithm + + tref(n) = trf + qref(n) = qrf + duu10n(n) = urf**2+vrf**2 + u10n = sqrt(duu10n(n)) + endif + + if (flux_diurnal) then + + !------------------------------------------------------------ + ! update new prognostic variables + !------------------------------------------------------------ + + warm (n) = DTiter + salt (n) = DSiter + speed (n) = DViter + + if (ltwopm) then + tSkin_day(n) = tSkin(n) + warmmax(n) = max(DTiter,0.0_R8) + endif + + if (ltwoam) then + tSkin_night(n) = tSkin(n) + cSkin_night(n) = cSkin(n) + endif + + if ((lmidnight).and.(lfullday)) then + qSolAvg(n) = qSolInc(n)/real(nsum+1,R8) + windAvg(n) = windInc(n)/real(nsum+1,R8) + ! warmMax(n) = max(DTiter,warmMaxInc(n)) + windMax(n) = max(u10n,windMaxInc(n)) + + nsum = 0 + + qSolInc(n) = Qsol + windInc(n) = u10n + + ! warmMaxInc(n) = 0.0_R8 + windMaxInc(n) = 0.0_R8 + + ! tSkin_night(n) = tSkin(n) + ! cSkin_night(n) = cSkin(n) + + else + + if ((lmidnight).and.(.not.(lfullday))) then + + nsum = 0 + + qSolInc(n) = Qsol + windInc(n) = u10n + + ! warmMaxInc(n) = 0.0_R8 + windMaxInc(n) = 0.0_R8 + + else + + nsum = nsum + 1 + + ! warmMaxInc (n) = max(DTiter,warmMaxInc(n)) + windMaxInc (n) = max(u10n, windMaxInc(n)) + ! windMaxInc (n) = max(Qsol, windMaxInc(n)) + qSolInc (n) = qSolInc(n)+Qsol + windInc (n) = windInc(n)+u10n + + endif + endif + + nInc(n) = real(nsum,R8) ! set nInc to incremented or reset nsum + + + if (present(ustar_sv)) ustar_sv(n) = ustar + if (present(re_sv )) re_sv (n) = re + if (present(ssq_sv )) ssq_sv (n) = ssq + + else ! mask = 0 + + !------------------------------------------------------------ + ! no valid data here -- out of domain + !------------------------------------------------------------ + warm (n) = spval ! NEW + salt (n) = spval ! NEW + speed (n) = spval ! NEW + regime (n) = spval ! NEW + tBulk (n) = spval ! NEW + tSkin (n) = spval ! NEW + tSkin_night(n) = spval ! NEW + tSkin_day (n) = spval ! NEW + cSkin (n) = spval ! NEW + cSkin_night(n) = spval ! NEW + warmMax (n) = spval ! NEW + windMax (n) = spval ! NEW + qSolAvg (n) = spval ! NEW + windAvg (n) = spval ! NEW + warmMaxInc (n) = spval ! NEW + windMaxInc (n) = spval ! NEW + qSolInc (n) = spval ! NEW + windInc (n) = spval ! NEW + nInc (n) = 0.0_R8 ! NEW + + sen (n) = spval ! sensible heat flux (W/m^2) + lat (n) = spval ! latent heat flux (W/m^2) + lwup (n) = spval ! long-wave upward heat flux (W/m^2) + evap (n) = spval ! evaporative water flux ((kg/s)/m^2) + evap_16O (n) = spval ! water tracer flux (kg/s)/m^2) + evap_HDO (n) = spval ! HDO tracer flux (kg/s)/m^2) + evap_18O (n) = spval ! H218O tracer flux (kg/s)/m^2) + taux (n) = spval ! x surface stress (N) + tauy (n) = spval ! y surface stress (N) + tref (n) = spval ! 2m reference height temperature (K) + qref (n) = spval ! 2m reference height humidity (kg/kg) + duu10n(n) = spval ! 10m wind speed squared (m/s)^2 + + if (present(ustar_sv)) ustar_sv(n) = spval + if (present(re_sv )) re_sv (n) = spval + if (present(ssq_sv )) ssq_sv (n) = spval + + endif ! mask + + endif ! flux diurnal logic + + ENDDO ! end n loop + + END subroutine flux_atmOcn_diurnal + + !=============================================================================== + ! !IROUTINE: shr_flux_MOstability -- Monin-Obukhov BL stability functions + ! + ! !DESCRIPTION: + ! + ! Monin-Obukhov boundary layer stability functions, two options: + ! turbulent velocity scales or gradient and integral functions + ! via option = shr_flux_MOwScales or shr_flux_MOfunctions + ! + ! !REVISION HISTORY: + ! 2007-Sep-19 - B. Kauffman, Bill Large - first version + !=============================================================================== + subroutine flux_MOstability(logunit,option,arg1,arg2,arg3,arg4,arg5) + + ! !USES: + + implicit none + + ! !INPUT/OUTPUT PARAMETERS: + integer ,intent(in) :: logunit + integer ,intent(in) :: option ! shr_flux_MOwScales or MOfunctions + real(R8) ,intent(in) :: arg1 ! scales: uStar (in) funct: zeta (in) + real(R8) ,intent(inout) :: arg2 ! scales: zkB (in) funct: phim (out) + real(R8) ,intent(out) :: arg3 ! scales: phim (out) funct: phis (out) + real(R8) ,intent(out) :: arg4 ! scales: phis (out) funct: psim (out) + real(R8) ,intent(out),optional :: arg5 ! scales: (unused) funct: psis (out) + + !----- local variables ----- + real(R8) :: zeta ! z/L + real(R8) :: uStar ! friction velocity + real(R8) :: zkB ! (height)*(von Karman)*(surface bouyancy flux) + real(R8) :: phim ! momentum gradient function or scale + real(R8) :: phis ! temperature gradient function or scale + real(R8) :: psim ! momentum integral function or scale + real(R8) :: psis ! temperature integral function or scale + real(R8) :: temp ! temporary-variable/partial calculation + + !----- local variables, stable case ----- + real(R8),parameter :: uStarMin = 0.001_R8 ! lower bound on uStar + real(R8),parameter :: a = 1.000_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: b = 0.667_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: c = 5.000_R8 ! constant from Holtslag & de Bruin, equation 12 + real(R8),parameter :: d = 0.350_R8 ! constant from Holtslag & de Bruin, equation 12 + + !----- local variables, unstable case ----- + real(R8),parameter :: a2 = 3.0_R8 ! constant from Wilson, equation 10 + + !----- formats ----- + character(*),parameter :: subName = '(shr_flux_MOstability) ' + character(*),parameter :: F00 = "('(shr_flux_MOstability) ',4a)" + character(*),parameter :: F01 = "('(shr_flux_MOstability) ',a,i5)" + + !------------------------------------------------------------------------------- + ! Notes:: + ! o this could be two routines, but are one to help keep them aligned + ! o the stable calculation is taken from... + ! A.A.M. HoltSlag and H.A.R. de Bruin, 1988: + ! "Applied Modeling of the Nighttime Surface Energy Balance over Land", + ! Journal of Applied Meteorology, Vol. 27, No. 6, June 1988, 659-704 + ! o the unstable calculation is taken from... + ! D. Keith Wilson, 2001: "An Alternative Function for the Wind and + ! Temperature Gradients in Unstable Surface Layers", + ! Boundary-Layer Meteorology, 99 (2001), 151-158 + !------------------------------------------------------------------------------- + + !----- check for consistancy between option and arguments ------------------ + if (debug > 1) then + if (debug > 2) write(logunit,F01) "enter, option = ",option + if ( option == shr_flux_MOwScales .and. present(arg5) ) then + write(logunit,F01) "ERROR: option1 must have four arguments" + call shr_sys_abort(subName//"option inconsistant with arguments") + else if ( option == shr_flux_MOfunctions .and. .not. present(arg5) ) then + write(logunit,F01) "ERROR: option2 must have five arguments" + call shr_sys_abort(subName//"option inconsistant with arguments") + else + write(logunit,F01) "invalid option = ",option + call shr_sys_abort(subName//"invalid option") + end if + end if + + !------ velocity scales option ---------------------------------------------- + if (option == shr_flux_MOwScales) then + + !--- input --- + uStar = arg1 + zkB = arg2 + + if (zkB >= 0.0_R8) then ! ----- stable ----- + zeta = zkB/(max(uStar,uStarMin)**3) + temp = exp(-d*zeta) + phim = uStar/(1.0_R8 + zeta*(a + b*(1.0_R8 + c - d*zeta)*temp)) + phis = phim + else ! ----- unstable ----- + temp = (zkB*zkB)**(1.0_R8/a2) ! note: zkB < 0, zkB*zkB > 0 + phim = sqrt(uStar**2 + shr_flux_MOgammaM*temp) + phis = sqrt(uStar**2 + shr_flux_MOgammaS*temp) + end if + + !--- output --- + arg3 = phim + arg4 = phis + ! arg5 = + + !------ stability function option ------------------------------------------- + else if (option == shr_flux_MOfunctions) then + + !--- input --- + zeta = arg1 + + if (zeta >= 0.0_R8) then ! ----- stable ----- + temp = exp(-d*zeta) + phim = 1.0_R8 + zeta*(a + b*(1.0_R8 + c - d*zeta)*temp) + phis = phim + psim = -a*zeta - b*(zeta - c/d)*temp - b*c/d + psis = psim + else ! ----- unstable ---- + temp = (zeta*zeta)**(1.0_R8/a2) ! note: zeta < 0, zeta*zeta > 0 + phim = 1.0_R8/sqrt(1.0_R8 + shr_flux_MOgammaM*temp) + phis = 1.0_R8/sqrt(1.0_R8 + shr_flux_MOgammaS*temp) + psim = a2*log(0.5_R8 + 0.5_R8/phim) + psis = a2*log(0.5_R8 + 0.5_R8/phis) + end if + + !--- output --- + arg2 = phim + arg3 = phis + arg4 = psim + arg5 = psis + !---------------------------------------------------------------------------- + else + write(logunit,F01) "invalid option = ",option + call shr_sys_abort(subName//"invalid option") + endif + + end subroutine flux_MOstability + + !=============================================================================== + ! !DESCRIPTION: + ! + ! COARE v3.0 parametrisation + ! + ! !REVISION HISTORY: + ! 2013-Nov-22: Thomas Toniazzo's adaptation of Chris Fairall's code, + ! downloaded from + ! ftp://ftp1.esrl.noaa.gov/users/cfairall/wcrp_wgsf/computer_programs/cor3_0/ + ! * no wave, standard coare 2.6 charnock + ! * skin parametrisation also off (would require radiative fluxes and + ! rainrate in input) + ! * added diagnostics, comments and references + !=============================================================================== + subroutine cor30a(ubt,vbt,tbt,qbt,rbt & ! in atm params + & ,uss,vss,tss,qss & ! in surf params + & ,zbl,zbu,zbt,zrfu,zrfq,zrft & ! in heights + & ,tau,hsb,hlb & ! out: fluxes + & ,zo,zot,zoq,L,usr,tsr,qsr & ! out: ss scales + & ,Cd,Ch,Ce & ! out: exch. coeffs + & ,trf,qrf,urf,vrf) ! out: reference-height params + + ! !USES: + + IMPLICIT NONE + + ! !INPUT/OUTPUT PARAMETERS: + + real(R8),intent(in) :: ubt,vbt,tbt,qbt,rbt,uss,vss,tss,qss + real(R8),intent(in) :: zbl,zbu,zbt,zrfu,zrfq,zrft + real(R8),intent(out):: tau,hsb,hlb,zo,zot,zoq,L,usr,tsr,qsr,Cd,Ch,Ce & + & ,trf,qrf,urf,vrf + + real(R8) ua,va,ta,q,rb,us,vs,ts,qs,zi,zu,zt,zq,zru,zrq,zrt ! internal vars + + real(R8):: cpa,rgas,grav,pi,von,beta ! phys. params + real(R8):: le,rhoa,cpv ! derived phys. params + real(R8):: t,visa,du,dq,dt ! params of problem + + real(R8):: u10,zo10,zot10,cd10,ch10,ct10,ct,cc,ribu,zetu,l10,charn ! init vars + real(R8):: zet,rr,bf,ug,ut ! loop iter vars + real(R8):: cdn_10,chn_10,cen_10 ! aux. output vars + + integer(IN):: i,nits ! iter loop counters + + integer(IN):: jcool ! aux. cool-skin vars + real(R8):: dter,wetc,dqer + + ua=ubt !wind components (m/s) at height zu (m) + va=vbt + ta=tbt !bulk air temperature (K), height zt + Q =qbt !bulk air spec hum (kg/kg), height zq + rb=rbt ! air density + us=uss !surface current components (m/s) + vs=vss + ts=tss !bulk water temperature (K) if jcool=1, interface water T if jcool=0 + qs=qss !bulk water spec hum (kg/kg) if jcool=1 etc + zi=zbl !PBL depth (m) + zu=zbu !wind speed measurement height (m) + zt=zbt !air T measurement height (m) + zq=zbt !air q measurement height (m) + zru=zrfu ! reference height for st.diagn.U + zrq=zrfq ! reference height for st.diagn.T,q + zrt=zrft ! reference height for st.diagn.T,q + + !**** constants + Beta= 1.2_R8 + von = 0.4_R8 + pi = 3.141593_R8 + grav= SHR_CONST_G + Rgas= SHR_CONST_RGAS + cpa = SHR_CONST_CPDAIR + + !*** physical parameters + Le = SHR_CONST_LATVAP -.00237e6_R8*(ts-273.16_R8) + ! cpv = shr_const_cpdair*(1.0_R8 + shr_const_cpvir*Qs) ! form in NCAR code + cpv = cpa*(1.0_R8+0.84_R8*Q) + ! rhoa= P/(Rgas*ta*(1+0.61*Q)) ! if input were pressure + rhoa= rb + + ! parametrisation for air kinematic viscosity (Andreas 1989,p.31) + t = ta-273.16_R8 + visa= 1.326e-5_R8*(1.0_R8+6.542e-3_R8*t+8.301e-6_R8*t*t-4.84e-9_R8*t*t*t) + + du = sqrt((ua-us)**2+(va-vs)**2) + dt = ts-ta -.0098_R8*zt + dq = Qs-Q + + !*** don't use cool-skin params for now, but assign values to Ter and Qer + jcool=0_IN + dter=0.3_R8 + wetc=0.622_R8*Le*Qs/(Rgas*ts**2) + dqer=wetc*dter + + !***************** Begin bulk-model calculations *************** + + !*************** first guess + ug=0.5_R8 + + ut = sqrt(du*du+ug*ug) + u10 = ut*log(10.0_R8/1.0e-4_R8)/log(zu/1.0e-4_R8) + usr = .035_R8*u10 + zo10 = 0.011_R8*usr*usr/grav+0.11_R8*visa/usr + Cd10 = (von/log(10.0_R8/zo10))**2 + Ch10 = 0.00115_R8 + Ct10 = Ch10/sqrt(Cd10) + zot10= 10.0_R8/exp(von/Ct10) + Cd =(von/log(zu/zo10))**2 + Ct = von/log(zt/zot10) + CC = von*Ct/Cd + + ! Bulk Richardson number + Ribu=-grav*zu/ta*((dt-dter*jcool)+.61_R8*ta*dq)/ut**2 + ! initial guess for stability parameter... + if (Ribu .LT. 0.0_R8) then + ! pbl-height dependent + zetu=CC*Ribu/( 1.0_R8 - (.004_R8*Beta**3*zi/zu) * Ribu ) + else + zetu=CC*Ribu*(1.0_R8 + 27.0_R8/9.0_R8*Ribu/CC) + endif + ! ...and MO length + L10=zu/zetu + + if (zetu .GT. 50.0_R8) then + nits=1_IN + else + nits=3_IN + endif + + usr = ut*von/(log(zu/zo10)-psiuo(zu/L10)) + tsr = (dt-dter*jcool)*von/(log(zt/zot10)-psit_30(zt/L10)) + qsr = (dq-dqer*jcool)*von/(log(zq/zot10)-psit_30(zq/L10)) + + ! parametrisation for Charney parameter (section 3c of Fairall et al. 2003) + charn=0.011_R8 + if (ut .GT. 10.0_R8) then + charn=0.011_R8+(ut-10.0_R8)/(18.0_R8-10.0_R8)*(0.018_R8-0.011_R8) + endif + if (ut .GT. 18.0_R8) then + charn=0.018_R8 + endif + + !*************** iteration loop ************ + do i=1, nits + + ! stability parameter + zet=-von*grav*zu/ta*(tsr*(1.0_R8+0.61_R8*Q)+.61_R8*ta*qsr)/(usr*usr)/(1.0_R8+0.61_R8*Q) + + ! momentum roughness length... + zo = charn*usr*usr/grav+0.11_R8*visa/usr + ! ...& MO length + L = zu/zet + + ! tracer roughness length + rr = zo*usr/visa + zoq= min(1.15e-4_R8,5.5e-5_R8/rr**.6_R8) + zot= zoq ! N.B. same for vapour and heat + + ! new surface-layer scales + usr = ut *von/(log(zu/zo )-psiuo(zu/L)) + tsr = (dt-dter*jcool)*von/(log(zt/zot)-psit_30(zt/L)) + qsr = (dq-dqer*jcool)*von/(log(zq/zoq)-psit_30(zq/L)) + + ! gustiness parametrisation + Bf=-grav/ta*usr*(tsr+.61_R8*ta*qsr) + if (Bf .GT. 0.0_R8) then + ug=Beta*(Bf*zi)**.333_R8 + else + ug=.2_R8 + endif + ut=sqrt(du*du+ug*ug) + + enddo + !*************** end loop ************ + + !******** fluxes @ measurement heights zu,zt,zq ******** + tau= rhoa*usr*usr*du/ut !stress magnitude + hsb=-rhoa*cpa*usr*tsr !heat downwards + hlb=-rhoa*Le*usr*qsr !wv downwards + + !****** transfer coeffs relative to ut @meas. hts ****** + Cd= tau/rhoa/ut/max(.1_R8,du) + if (tsr.ne.0._r8) then + Ch= usr/ut*tsr/(dt-dter*jcool) + else + Ch= usr/ut* von/(log(zt/zot)-psit_30(zt/L)) + endif + if (qsr.ne.0.0_R8) then + Ce= usr/ut*qsr/(dq-dqer*jcool) + else + Ce= usr/ut* von/(log(zq/zoq)-psit_30(zq/L)) + endif + + !********** 10-m neutral coeff relative to ut ********* + Cdn_10=von*von/log(10.0_R8/zo)/log(10.0_R8/zo) + Chn_10=von*von/log(10.0_R8/zo)/log(10.0_R8/zot) + Cen_10=von*von/log(10.0_R8/zo)/log(10.0_R8/zoq) + + !********** reference-height values for u,q,T ********* + urf=us+(ua-us)*(log(zru/zo)-psiuo(zru/L))/(log(zu/zo)-psiuo(zu/L)) + vrf=vs+(va-vs)*(log(zru/zo)-psiuo(zru/L))/(log(zu/zo)-psiuo(zu/L)) + qrf=qs-dq*(log(zrq/zoq)-psit_30(zrq/L))/(log(zq/zoq)-psit_30(zq/L)) + trf=ts-dt*(log(zrt/zot)-psit_30(zrt/L))/(log(zt/zot)-psit_30(zt/L)) + trf=trf+.0098_R8*zrt + + end subroutine cor30a + + !=============================================================================== + ! !IROUTINE: PSIUo + ! + ! !DESCRIPTION: + ! + ! momentum stability functions adopted in COARE v3.0 parametrisation. + ! Chris Fairall's code (see cor30a) + ! + ! !REVISION HISTORY: + ! 22/11/2013: Thomas Toniazzo: comments added + !=============================================================================== + + real (R8) function psiuo(zet) + ! !INPUT/OUTPUT PARAMETERS: + real(R8),intent(in) :: zet + real(R8) ::c,x,psik,psic,f + !----------------------------------------------------------------- + ! N.B.: z0/L always neglected compared to z/L and to 1 + !----------------------------------------------------------------- + if(zet>0.0_R8)then + ! Beljaars & Holtslag (1991) + c=min(50._R8,.35_R8*zet) + psiuo=-((1.0_R8+1.0_R8*zet)**1.0_R8+.667_R8*(zet-14.28_R8)/exp(c)+8.525_R8) + else + ! Dyer & Hicks (1974) for weak instability + x=(1.0_R8-15.0_R8*zet)**.25_R8 ! 15 instead of 16 + psik=2.0_R8*log((1.0_R8+x)/2.0_R8)+log((1.0_R8+x*x)/2.0_R8)-2.0_R8*atan(x)+2.0_R8*atan(1.0_R8) + ! Fairall et al. (1996) for strong instability (Eq.(13)) + x=(1.0_R8-10.15_R8*zet)**.3333_R8 + psic= 1.5_R8*log((1.0_R8+x+x*x)/3.0_R8)-sqrt(3.0_R8)*atan((1.0_R8+2.0_R8*x)/sqrt(3.0_R8)) & + & +4.0_R8*atan(1.0_R8)/sqrt(3.0_R8) + f=zet*zet/(1.0_R8+zet*zet) + psiuo=(1.0_R8-f)*psik+f*psic + endif + END FUNCTION psiuo + + !=============================================================================== + ! !IROUTINE: PSIT_30 + ! + ! !DESCRIPTION: + ! + ! momentum stability functions adopted in COARE v3.0 parametrisation. + ! Chris Fairall's code (see cor30a) + ! + ! !REVISION HISTORY: + ! 22/11/2013: Thomas Toniazzo: comments added + !=============================================================================== + real (R8) function psit_30(zet) + ! !INPUT/OUTPUT PARAMETERS: + real(R8),intent(in) :: zet + ! !EOP + real(R8) ::c,x,psik,psic,f + !----------------------------------------------------------------- + ! N.B.: z0/L always neglected compared to z/L and to 1 + !----------------------------------------------------------------- + if(zet>0.0_R8)then + ! Beljaars & Holtslag (1991) + c=min(50._R8,.35_R8*zet) + psit_30=-((1.0_R8+2.0_R8/3.0_R8*zet)**1.5_R8+.667_R8*(zet-14.28_R8)/exp(c)+8.525_R8) + else + ! Dyer & Hicks (1974) for weak instability + x=(1.0_R8-15.0_R8*zet)**.5_R8 ! 15 instead of 16 + psik=2.0_R8*log((1.0_R8+x)/2.0_R8) + ! Fairall et al. (1996) for strong instability + x=(1.0_R8-(34.15_R8*zet))**.3333_R8 + psic= 1.5_R8*log((1.0_R8+x+x*x)/3.0_R8)-sqrt(3.0_R8)*atan((1.0_R8+2.0_R8*x)/sqrt(3.0_R8)) & + & +4.0_R8*atan(1.0_R8)/sqrt(3.0_R8) + f=zet*zet/(1.0_R8+zet*zet) + psit_30=(1.0_R8-f)*psik+f*psic + endif + end FUNCTION psit_30 + +end module shr_flux_mod diff --git a/cesm/nuopc_cap_share/glc_elevclass_mod.F90 b/cesm/nuopc_cap_share/glc_elevclass_mod.F90 new file mode 100644 index 000000000..3a984f642 --- /dev/null +++ b/cesm/nuopc_cap_share/glc_elevclass_mod.F90 @@ -0,0 +1,569 @@ +module glc_elevclass_mod + + !--------------------------------------------------------------------- + ! + ! Purpose: + ! + ! This module contains data and routines for operating on GLC elevation classes. + !--------------------------------------------------------------------- + +#include "shr_assert.h" + use shr_kind_mod , only : r8=>shr_kind_r8 + use shr_sys_mod , only : shr_sys_abort + + implicit none + private + + !-------------------------------------------------------------------------- + ! Public interfaces + !-------------------------------------------------------------------------- + + public :: glc_elevclass_init ! initialize GLC elevation class data + public :: glc_elevclass_clean ! deallocate memory allocated here + public :: glc_get_num_elevation_classes ! get the number of elevation classes + public :: glc_get_elevation_classes ! get elevation class of each grid cell on the glc grid. + public :: glc_get_elevation_class ! get the elevation class index for a given elevation + public :: glc_get_elevclass_bounds ! get the boundaries of all elevation classes + public :: glc_mean_elevation_virtual ! get the mean elevation of a virtual elevation class + public :: glc_elevclass_as_string ! returns a string corresponding to a given elevation class + public :: glc_get_fractional_icecov ! get the fractional ice cover for each glc elevation class + public :: glc_errcode_to_string ! convert an error code into a string describing the error + + interface glc_elevclass_init + module procedure glc_elevclass_init_default + module procedure glc_elevclass_init_override + end interface glc_elevclass_init + + interface glc_get_elevation_classes + module procedure glc_get_elevation_classes_with_bareland + module procedure glc_get_elevation_classes_without_bareland + end interface glc_get_elevation_classes + + !-------------------------------------------------------------------------- + ! Public data + !-------------------------------------------------------------------------- + + ! Possible error code values + integer, parameter, public :: GLC_ELEVCLASS_ERR_NONE = 0 ! err_code indicating no error + integer, parameter, public :: GLC_ELEVCLASS_ERR_UNDEFINED = 1 ! err_code indicating elevation classes have not been defined + integer, parameter, public :: GLC_ELEVCLASS_ERR_TOO_LOW = 2 ! err_code indicating topo below lowest elevation class + integer, parameter, public :: GLC_ELEVCLASS_ERR_TOO_HIGH = 3 ! err_code indicating topo above highest elevation class + + ! String length for glc elevation classes represented as strings + integer, parameter, public :: GLC_ELEVCLASS_STRLEN = 2 + + !-------------------------------------------------------------------------- + ! Private data + !-------------------------------------------------------------------------- + + ! number of elevation classes + integer :: glc_nec + + ! upper elevation limit of each class (m) + ! indexing starts at 0, with topomax(0) giving the lower elevation limit of EC 1 + real(r8), allocatable :: topomax(:) + +contains + + !----------------------------------------------------------------------- + subroutine glc_elevclass_init_default(my_glc_nec, logunit) + ! + ! !DESCRIPTION: + ! Initialize GLC elevation class data to default boundaries, based on given glc_nec + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: my_glc_nec ! number of GLC elevation classes + integer, intent(in), optional :: logunit + ! + ! !LOCAL VARIABLES: + character(len=*), parameter :: subname = 'glc_elevclass_init' + !----------------------------------------------------------------------- + + glc_nec = my_glc_nec + if (.not. allocated(topomax)) allocate(topomax(0:glc_nec)) + + select case (glc_nec) + case(0) + ! do nothing + case(1) + topomax = [0._r8, 10000._r8] + case(3) + topomax = [0._r8, 1000._r8, 2000._r8, 10000._r8] + case(5) + topomax = [0._r8, 500._r8, 1000._r8, 1500._r8, 2000._r8, 10000._r8] + case(10) + topomax = [0._r8, 200._r8, 400._r8, 700._r8, 1000._r8, 1300._r8, & + 1600._r8, 2000._r8, 2500._r8, 3000._r8, 10000._r8] + case(36) + topomax = [ 0._r8, 200._r8, 400._r8, 600._r8, 800._r8, & + 1000._r8, 1200._r8, 1400._r8, 1600._r8, 1800._r8, & + 2000._r8, 2200._r8, 2400._r8, 2600._r8, 2800._r8, & + 3000._r8, 3200._r8, 3400._r8, 3600._r8, 3800._r8, & + 4000._r8, 4200._r8, 4400._r8, 4600._r8, 4800._r8, & + 5000._r8, 5200._r8, 5400._r8, 5600._r8, 5800._r8, & + 6000._r8, 6200._r8, 6400._r8, 6600._r8, 6800._r8, & + 7000._r8, 10000._r8] + case default + if (present(logunit)) then + write(logunit,*) subname,' ERROR: unknown glc_nec: ', glc_nec + end if + call shr_sys_abort(subname//' ERROR: unknown glc_nec') + end select + + end subroutine glc_elevclass_init_default + + !----------------------------------------------------------------------- + subroutine glc_elevclass_init_override(my_glc_nec, my_topomax) + ! + ! !DESCRIPTION: + ! Initialize GLC elevation class data to the given elevation class boundaries. + ! + ! The input, my_topomax, should have (my_glc_nec + 1) elements. + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: my_glc_nec ! number of GLC elevation classes + real(r8), intent(in) :: my_topomax(0:) ! elevation class boundaries (m) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_elevclass_init_override' + !----------------------------------------------------------------------- + + SHR_ASSERT_ALL_FL((ubound(my_topomax) == (/my_glc_nec/)), __FILE__, __LINE__) + + glc_nec = my_glc_nec + allocate(topomax(0:glc_nec)) + topomax = my_topomax + + end subroutine glc_elevclass_init_override + + !----------------------------------------------------------------------- + subroutine glc_elevclass_clean() + ! + ! !DESCRIPTION: + ! Deallocate memory allocated in this module + + character(len=*), parameter :: subname = 'glc_elevclass_clean' + !----------------------------------------------------------------------- + + if (allocated(topomax)) then + deallocate(topomax) + end if + glc_nec = 0 + + end subroutine glc_elevclass_clean + + !----------------------------------------------------------------------- + function glc_get_num_elevation_classes() result(num_elevation_classes) + ! + ! !DESCRIPTION: + ! Get the number of GLC elevation classes + ! + ! !ARGUMENTS: + integer :: num_elevation_classes ! function result + integer :: rc + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_get_num_elevation_classes' + !----------------------------------------------------------------------- + + num_elevation_classes = glc_nec + + end function glc_get_num_elevation_classes + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_classes_without_bareland(glc_topo, glc_elevclass, logunit) + ! + ! !DESCRIPTION: + ! Get elevation class of each grid cell on the glc grid. + ! + ! This does not consider glc_frac: it simply gives the elevation class that the grid + ! cell would be in if it were ice-covered. So it never returns an elevation class of + ! 0 (bare land). (This design would allow us, in the future, to have glc grid cells + ! that are part ice-covered, part ice-free.) + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_topo(:) ! topographic height + integer , intent(out) :: glc_elevclass(:) ! elevation class + integer , intent(in) :: logunit + ! + ! !LOCAL VARIABLES: + integer :: npts + integer :: glc_pt + integer :: err_code + + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_elevclass) + SHR_ASSERT_FL((size(glc_topo) == npts), __FILE__, __LINE__) + + do glc_pt = 1, npts + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + ! Do nothing + case (GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH) + write(logunit,*) subname, ': WARNING, for glc_pt, topo = ', glc_pt, glc_topo(glc_pt) + write(logunit,*) glc_errcode_to_string(err_code) + case default + write(logunit,*) subname, ': ERROR getting elevation class for glc_pt = ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end select + end do + + end subroutine glc_get_elevation_classes_without_bareland + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_classes_with_bareland(glc_ice_covered, glc_topo, glc_elevclass, logunit) + ! + ! !DESCRIPTION: + ! Get the elevation class of each point on the glc grid. + ! For grid cells that are ice-free, the elevation class is set to 0. + ! All arguments (glc_ice_covered, glc_topo and glc_elevclass) must be the same size. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: glc_ice_covered(:) ! ice-covered (1) vs. ice-free (0) + real(r8), intent(in) :: glc_topo(:) ! ice topographic height + integer , intent(out) :: glc_elevclass(:) ! elevation class + integer , intent(in) :: logunit + ! + ! !LOCAL VARIABLES: + integer :: npts + integer :: glc_pt + integer :: err_code + + ! Tolerance for checking whether ice_covered is 0 or 1 + real(r8), parameter :: ice_covered_tol = 1.e-13 + + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_elevclass) + SHR_ASSERT_FL((size(glc_ice_covered) == npts), __FILE__, __LINE__) + SHR_ASSERT_FL((size(glc_topo) == npts), __FILE__, __LINE__) + + do glc_pt = 1, npts + if (abs(glc_ice_covered(glc_pt) - 1._r8) < ice_covered_tol) then + ! This is an ice-covered point + + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + if ( err_code == GLC_ELEVCLASS_ERR_NONE .or. & + err_code == GLC_ELEVCLASS_ERR_TOO_LOW .or. & + err_code == GLC_ELEVCLASS_ERR_TOO_HIGH) then + ! These are all acceptable "errors" - it is even okay for these purposes if + ! the elevation is lower than the lower bound of elevation class 1, or + ! higher than the upper bound of the top elevation class. + + ! Do nothing + else + write(logunit,*) subname, ': ERROR getting elevation class for ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end if + else if (abs(glc_ice_covered(glc_pt) - 0._r8) < ice_covered_tol) then + ! This is a bare land point (no ice) + glc_elevclass(glc_pt) = 0 + else + ! glc_ice_covered is some value other than 0 or 1 + ! The lnd -> glc downscaling code would need to be reworked if we wanted to + ! handle a continuous fraction between 0 and 1. + write(logunit,*) subname, ': ERROR: glc_ice_covered must be 0 or 1' + write(logunit,*) 'glc_pt, glc_ice_covered = ', glc_pt, glc_ice_covered(glc_pt) + call shr_sys_abort(subname//': ERROR: glc_ice_covered must be 0 or 1') + end if + end do + + end subroutine glc_get_elevation_classes_with_bareland + + !----------------------------------------------------------------------- + subroutine glc_get_elevation_class(topo, elevation_class, err_code) + ! + ! !DESCRIPTION: + ! Get the elevation class index associated with a given topographic height. + ! + ! The returned elevation_class will be between 1 and num_elevation_classes, if this + ! topographic height is contained in an elevation class. In this case, err_code will + ! be GLC_ELEVCLASS_ERR_NONE (no error). + ! + ! If there are no elevation classes defined, the returned value will be 0, and + ! err_code will be GLC_ELEVCLASS_ERR_UNDEFINED + ! + ! If this topographic height is below the lowest elevation class, the returned value + ! will be 1, and err_code will be GLC_ELEVCLASS_ERR_TOO_LOW. + ! + ! If this topographic height is above the highest elevation class, the returned value + ! will be (num_elevation_classes), and err_code will be GLC_ELEVCLASS_ERR_TOO_HIGH. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: topo ! topographic height (m) + integer, intent(out) :: elevation_class ! elevation class index + integer, intent(out) :: err_code ! error code (see above for possible codes) + ! + ! !LOCAL VARIABLES: + integer :: ec ! temporary elevation class + + character(len=*), parameter :: subname = 'glc_get_elevation_class' + !----------------------------------------------------------------------- + + if (glc_nec < 1) then + elevation_class = 0 + err_code = GLC_ELEVCLASS_ERR_UNDEFINED + else if (topo < topomax(0)) then + elevation_class = 1 + err_code = GLC_ELEVCLASS_ERR_TOO_LOW + else if (topo >= topomax(glc_nec)) then + elevation_class = glc_nec + err_code = GLC_ELEVCLASS_ERR_TOO_HIGH + else + err_code = GLC_ELEVCLASS_ERR_NONE + elevation_class = 0 + do ec = 1, glc_nec + if (topo >= topomax(ec - 1) .and. topo < topomax(ec)) then + elevation_class = ec + exit + end if + end do + + SHR_ASSERT(elevation_class > 0, subname//' elevation class was not assigned') + + end if + + end subroutine glc_get_elevation_class + + !----------------------------------------------------------------------- + function glc_get_elevclass_bounds() result(elevclass_bounds) + ! + ! !DESCRIPTION: + ! Get the boundaries of all elevation classes. + ! + ! This returns an array of size glc_nec+1, since it contains both the lower and upper + ! bounds of each elevation class. + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8) :: elevclass_bounds(0:glc_nec) ! function result + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_get_elevclass_bounds' + !----------------------------------------------------------------------- + + elevclass_bounds(:) = topomax(:) + + end function glc_get_elevclass_bounds + + !----------------------------------------------------------------------- + function glc_elevclass_as_string(elevation_class) result(ec_string) + ! + ! !DESCRIPTION: + ! Returns a string corresponding to a given elevation class. + ! + ! This string can be used as a suffix for fields in MCT attribute vectors. + ! This is still needed by dlnd in the data models - even if they have nuopc caps. + ! + ! ! NOTE(wjs, 2015-01-19) This function doesn't fully belong in this module, since it + ! doesn't refer to the data stored in this module. However, I can't think of a more + ! appropriate place for it. + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=GLC_ELEVCLASS_STRLEN) :: ec_string ! function result + integer, intent(in) :: elevation_class + ! + ! !LOCAL VARIABLES: + character(len=16) :: format_string + + character(len=*), parameter :: subname = 'glc_elevclass_as_string' + !----------------------------------------------------------------------- + + ! e.g., for GLC_ELEVCLASS_STRLEN = 2, format_string will be '(i2.2)' + write(format_string,'(a,i0,a,i0,a)') '(i', GLC_ELEVCLASS_STRLEN, '.', GLC_ELEVCLASS_STRLEN, ')' + + write(ec_string,trim(format_string)) elevation_class + end function glc_elevclass_as_string + + !----------------------------------------------------------------------- + function glc_mean_elevation_virtual(elevation_class, logunit) result(mean_elevation) + ! + ! !DESCRIPTION: + ! Returns the mean elevation of a virtual elevation class + ! + ! !ARGUMENTS: + real(r8) :: mean_elevation ! function result + integer, intent(in) :: elevation_class + integer, optional, intent(in) :: logunit + ! + ! !LOCAL VARIABLES: + integer :: resulting_elevation_class + integer :: err_code + + character(len=*), parameter :: subname = 'glc_mean_elevation_virtual' + !----------------------------------------------------------------------- + + if (elevation_class == 0) then + ! Bare land "elevation class" + mean_elevation = 0._r8 + else + if (elevation_class < glc_nec) then + ! Normal case + mean_elevation = (topomax(elevation_class - 1) + topomax(elevation_class)) / 2._r8 + else if (elevation_class == glc_nec) then + ! In the top elevation class; in this case, assignment of a "mean" elevation is + ! somewhat arbitrary (because we expect the upper bound of the top elevation + ! class to be very high). + + if (glc_nec > 1) then + mean_elevation = 2._r8 * topomax(elevation_class - 1) - topomax(elevation_class - 2) + else + ! entirely arbitrary + mean_elevation = 1000._r8 + end if + else + if (present(logunit)) then + write(logunit,*) subname,' ERROR: elevation class out of bounds: ', elevation_class + end if + call shr_sys_abort(subname // ' ERROR: elevation class out of bounds') + end if + end if + + ! Ensure that the resulting elevation is within the given elevation class + if (elevation_class > 0) then + call glc_get_elevation_class(mean_elevation, resulting_elevation_class, err_code) + if (err_code /= GLC_ELEVCLASS_ERR_NONE) then + if (present(logunit)) then + write(logunit,*) subname, ' ERROR: generated elevation that results in an error' + write(logunit,*) 'when trying to determine the resulting elevation class' + write(logunit,*) glc_errcode_to_string(err_code) + write(logunit,*) 'elevation_class, mean_elevation = ', elevation_class, mean_elevation + end if + call shr_sys_abort(subname // ' ERROR: generated elevation that results in an error') + else if (resulting_elevation_class /= elevation_class) then + if (present(logunit)) then + write(logunit,*) subname, ' ERROR: generated elevation outside the given elevation class' + write(logunit,*) 'elevation_class, mean_elevation, resulting_elevation_class = ', & + elevation_class, mean_elevation, resulting_elevation_class + end if + call shr_sys_abort(subname // ' ERROR: generated elevation outside the given elevation class') + end if + end if + + end function glc_mean_elevation_virtual + + !----------------------------------------------------------------------- + function glc_errcode_to_string(err_code) result(err_string) + ! + ! !DESCRIPTION: + ! + ! + ! !USES: + ! + ! !ARGUMENTS: + character(len=256) :: err_string ! function result + integer, intent(in) :: err_code ! error code (one of the GLC_ELEVCLASS_ERR* values) + ! + ! !LOCAL VARIABLES: + + character(len=*), parameter :: subname = 'glc_errcode_to_string' + !----------------------------------------------------------------------- + + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + err_string = '(no error)' + case (GLC_ELEVCLASS_ERR_UNDEFINED) + err_string = 'Elevation classes have not yet been defined' + case (GLC_ELEVCLASS_ERR_TOO_LOW) + err_string = 'Topographic height below the lower bound of the lowest elevation class' + case (GLC_ELEVCLASS_ERR_TOO_HIGH) + err_string = 'Topographic height above the upper bound of the highest elevation class' + case default + err_string = 'UNKNOWN ERROR' + end select + + end function glc_errcode_to_string + + !----------------------------------------------------------------------- + subroutine glc_get_fractional_icecov(nec, glc_topo, glc_icefrac, glc_icefrac_ec, logunit) + + !------------------ + ! Get the fractional ice cover for each glc elevation class + ! + ! First get elevation class of each grid cell on the glc grid. + ! This does not consider glc_frac: it simply gives the elevation class that the grid + ! cell would be in if it were ice-covered. So it never returns an elevation class of + ! 0 (bare land). (This design would allow us, in the future, to have glc grid cells + ! that are part ice-covered, part ice-free.) + !------------------ + + ! input/output variables + integer , intent(in) :: nec ! number of elevation classes + real(r8), intent(in) :: glc_topo(:) ! topographic height + real(r8), intent(in) :: glc_icefrac(:) + real(r8), intent(out) :: glc_icefrac_ec(:,:) + integer , intent(in) :: logunit + ! + ! local variables + integer , allocatable :: glc_elevclass(:) ! elevation class + integer :: npts + integer :: ec + integer :: glc_pt + integer :: err_code + character(len=*), parameter :: subname = 'get_glc_elevation_classes' + !----------------------------------------------------------------------- + + npts = size(glc_topo) + allocate(glc_elevclass(npts)) + + do glc_pt = 1, npts + call glc_get_elevation_class(glc_topo(glc_pt), glc_elevclass(glc_pt), err_code) + select case (err_code) + case (GLC_ELEVCLASS_ERR_NONE) + ! Do nothing + case (GLC_ELEVCLASS_ERR_TOO_LOW, GLC_ELEVCLASS_ERR_TOO_HIGH) + write(logunit,*) subname, ': WARNING, for glc_pt, topo = ', glc_pt, glc_topo(glc_pt) + write(logunit,*) glc_errcode_to_string(err_code) + case default + write(logunit,*) subname, ': ERROR getting elevation class for glc_pt = ', glc_pt + write(logunit,*) glc_errcode_to_string(err_code) + call shr_sys_abort(subname//': ERROR getting elevation class') + end select + end do + + ! note that glc_elevclass gives the elevation class of each glc + ! grid cell, assuming that the grid cell is ice-covered. + ! glc_elevclass for a given glc gridcell spans [0 -> nec] + ! the first and undistributed dimension of glc_icefrac_ec spans [1 -> nec+1] + + do ec = 0, nec + do glc_pt = 1,npts + if (ec == 0) then + glc_icefrac_ec(ec+1,glc_pt) = 1._r8 - glc_icefrac(glc_pt) + else + if (glc_elevclass(glc_pt) == ec) then + glc_icefrac_ec(ec+1,glc_pt) = glc_icefrac(glc_pt) + else + glc_icefrac_ec(ec+1,glc_pt) = 0._r8 + end if + end if + end do + end do + + deallocate(glc_elevclass) + + end subroutine glc_get_fractional_icecov + +end module glc_elevclass_mod diff --git a/nuopc_cap_share/nuopc_shr_methods.F90 b/cesm/nuopc_cap_share/nuopc_shr_methods.F90 similarity index 100% rename from nuopc_cap_share/nuopc_shr_methods.F90 rename to cesm/nuopc_cap_share/nuopc_shr_methods.F90 diff --git a/cesm/nuopc_cap_share/seq_drydep_mod.F90 b/cesm/nuopc_cap_share/seq_drydep_mod.F90 new file mode 100644 index 000000000..34bb1423c --- /dev/null +++ b/cesm/nuopc_cap_share/seq_drydep_mod.F90 @@ -0,0 +1,1220 @@ +module seq_drydep_mod + + !======================================================================== + ! Module for handling dry depostion of tracers. + ! This module is shared by land and atmosphere models for the computations of + ! dry deposition of tracers + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_kind_mod , only : r8 => shr_kind_r8, CS => SHR_KIND_CS, CX => SHR_KIND_CX + use shr_const_mod , only : SHR_CONST_G, SHR_CONST_RDAIR, SHR_CONST_CPDAIR, SHR_CONST_MWWV + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_log_mod , only : s_logunit => shr_log_Unit + use shr_infnan_mod , only : shr_infnan_posinf, assignment(=) + + implicit none + private + + ! public member functions + public :: seq_drydep_readnl ! Read namelist + public :: seq_drydep_init ! Initialization of drydep data + public :: seq_drydep_setHCoeff ! Calculate Henry's law coefficients + + ! private array sizes + integer, public, parameter :: n_species_table = 192 ! Number of species to work with + integer, private, parameter :: maxspc = 210 ! Maximum number of species + integer, private, parameter :: NSeas = 5 ! Number of seasons + integer, private, parameter :: NLUse = 11 ! Number of land-use types + + logical, private :: drydep_initialized = .false. + + ! public data members: + ! method specification + character(16),public,parameter :: DD_XATM = 'xactive_atm' ! dry-dep atmosphere + character(16),public,parameter :: DD_XLND = 'xactive_lnd' ! dry-dep land + character(16),public,parameter :: DD_TABL = 'table' ! dry-dep table (atm and lnd) + character(16),public :: drydep_method = DD_XLND ! Which option choosen + + real(r8), public, parameter :: ph = 1.e-5_r8 ! measure of the acidity (dimensionless) + + logical, public :: lnd_drydep ! If dry-dep fields passed + integer, public :: n_drydep = 0 ! Number in drypdep list + logical :: drydep_init = .false. ! has seq_drydep_init been called? + character(len=CS), public, dimension(maxspc) :: drydep_list = '' ! List of dry-dep species + + real(r8), public, allocatable, dimension(:) :: foxd ! reactivity factor for oxidation (dimensioness) + real(r8), public, allocatable, dimension(:) :: drat ! ratio of molecular diffusivity (D_H2O/D_species; dimensionless) + integer, public, allocatable, dimension(:) :: mapping ! mapping to species table + + ! --- Indices for each species --- + integer, public :: h2_ndx, ch4_ndx, co_ndx, pan_ndx, mpan_ndx, so2_ndx, o3_ndx, o3a_ndx, xpan_ndx + + !--------------------------------------------------------------------------- + ! Table 1 from Wesely, Atmos. Environment, 1989, p1293 + ! Table 2 from Sheih, microfiche PB86-218104 and Walcek, Atmos. Environment, 1986, p949 + ! Table 3-5 compiled by P. Hess + ! + ! index #1 : season + ! 1 -> midsummer with lush vegetation + ! 2 -> autumn with unharvested cropland + ! 3 -> late autumn after frost, no snow + ! 4 -> winter, snow on ground, and subfreezing + ! 5 -> transitional spring with partially green short annuals + ! + ! index #2 : landuse type + ! 1 -> urban land + ! 2 -> agricultural land + ! 3 -> range land + ! 4 -> deciduous forest + ! 5 -> coniferous forest + ! 6 -> mixed forest including wetland + ! 7 -> water, both salt and fresh + ! 8 -> barren land, mostly desert + ! 9 -> nonforested wetland + ! 10 -> mixed agricultural and range land + ! 11 -> rocky open areas with low growing shrubs + ! + ! JFL August 2000 + !--------------------------------------------------------------------------- + + !--------------------------------------------------------------------------- + ! table to parameterize the impact of soil moisture on the deposition of H2 and + ! CO on soils (from Sanderson et al., J. Atmos. Chem., 46, 15-28, 2003). + !--------------------------------------------------------------------------- + + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_a(NLUse) = & + (/ 0.000_r8, 0.000_r8, 0.270_r8, 0.000_r8, 0.000_r8, & + 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.000_r8/) + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_b(NLUse) = & + (/ 0.000_r8,-41.390_r8, -0.472_r8,-41.900_r8,-41.900_r8, & + -41.900_r8, 0.000_r8, 0.000_r8, 0.000_r8,-41.390_r8, 0.000_r8/) + !--- deposition of h2 and CO on soils --- + real(r8), parameter, public :: h2_c(NLUse) = & + (/ 0.000_r8, 16.850_r8, 1.235_r8, 19.700_r8, 19.700_r8, & + 19.700_r8, 0.000_r8, 0.000_r8, 0.000_r8, 17.700_r8, 1.000_r8/) + + !--- deposition of h2 and CO on soils + ! + !--- ri: Richardson number (dimensionless) + !--- rlu: Resistance of leaves in upper canopy (s.m-1) + !--- rac: Aerodynamic resistance to lower canopy (s.m-1) + !--- rgss: Ground surface resistance for SO2 (s.m-1) + !--- rgso: Ground surface resistance for O3 (s.m-1) + !--- rcls: Lower canopy resistance for SO2 (s.m-1) + !--- rclo: Lower canopy resistance for O3 (s.m-1) + ! + real(r8), public, dimension(NSeas,NLUse) :: ri, rlu, rac, rgss, rgso, rcls, rclo + + data ri (1,1:NLUse) & + /1.e36_r8, 60._r8, 120._r8, 70._r8, 130._r8, 100._r8,1.e36_r8,1.e36_r8, 80._r8, 100._r8, 150._r8/ + data rlu (1,1:NLUse) & + /1.e36_r8,2000._r8,2000._r8,2000._r8,2000._r8,2000._r8,1.e36_r8,1.e36_r8,2500._r8,2000._r8,4000._r8/ + data rac (1,1:NLUse) & + / 100._r8, 200._r8, 100._r8,2000._r8,2000._r8,2000._r8, 0._r8, 0._r8, 300._r8, 150._r8, 200._r8/ + data rgss(1,1:NLUse) & + / 400._r8, 150._r8, 350._r8, 500._r8, 500._r8, 100._r8, 0._r8,1000._r8, 0._r8, 220._r8, 400._r8/ + data rgso(1,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(1,1:NLUse) & + /1.e36_r8,2000._r8,2000._r8,2000._r8,2000._r8,2000._r8,1.e36_r8,1.e36_r8,2500._r8,2000._r8,4000._r8/ + data rclo(1,1:NLUse) & + /1.e36_r8,1000._r8,1000._r8,1000._r8,1000._r8,1000._r8,1.e36_r8,1.e36_r8,1000._r8,1000._r8,1000._r8/ + + data ri (2,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 250._r8, 500._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (2,1:NLUse) & + /1.e36_r8,9000._r8,9000._r8,9000._r8,4000._r8,8000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (2,1:NLUse) & + / 100._r8, 150._r8, 100._r8,1500._r8,2000._r8,1700._r8, 0._r8, 0._r8, 200._r8, 120._r8, 140._r8/ + data rgss(2,1:NLUse) & + / 400._r8, 200._r8, 350._r8, 500._r8, 500._r8, 100._r8, 0._r8,1000._r8, 0._r8, 300._r8, 400._r8/ + data rgso(2,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8, 800._r8, 180._r8, 200._r8/ + data rcls(2,1:NLUse) & + /1.e36_r8,9000._r8,9000._r8,9000._r8,2000._r8,4000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rclo(2,1:NLUse) & + /1.e36_r8, 400._r8, 400._r8, 400._r8,1000._r8, 600._r8,1.e36_r8,1.e36_r8, 400._r8, 400._r8, 400._r8/ + + data ri (3,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 250._r8, 500._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (3,1:NLUse) & + /1.e36_r8,1.e36_r8,9000._r8,9000._r8,4000._r8,8000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (3,1:NLUse) & + / 100._r8, 10._r8, 100._r8,1000._r8,2000._r8,1500._r8, 0._r8, 0._r8, 100._r8, 50._r8, 120._r8/ + data rgss(3,1:NLUse) & + / 400._r8, 150._r8, 350._r8, 500._r8, 500._r8, 200._r8, 0._r8,1000._r8, 0._r8, 200._r8, 400._r8/ + data rgso(3,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(3,1:NLUse) & + /1.e36_r8,1.e36_r8,9000._r8,9000._r8,3000._r8,6000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rclo(3,1:NLUse) & + /1.e36_r8,1000._r8, 400._r8, 400._r8,1000._r8, 600._r8,1.e36_r8,1.e36_r8, 800._r8, 600._r8, 600._r8/ + + data ri (4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8, 400._r8, 800._r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8/ + data rlu (4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,1.e36_r8,6000._r8,9000._r8,1.e36_r8,1.e36_r8,9000._r8,9000._r8,9000._r8/ + data rac (4,1:NLUse) & + / 100._r8, 10._r8, 10._r8,1000._r8,2000._r8,1500._r8, 0._r8, 0._r8, 50._r8, 10._r8, 50._r8/ + data rgss(4,1:NLUse) & + / 100._r8, 100._r8, 100._r8, 100._r8, 100._r8, 100._r8, 0._r8,1000._r8, 100._r8, 100._r8, 50._r8/ + data rgso(4,1:NLUse) & + / 600._r8,3500._r8,3500._r8,3500._r8,3500._r8,3500._r8,2000._r8, 400._r8,3500._r8,3500._r8,3500._r8/ + data rcls(4,1:NLUse) & + /1.e36_r8,1.e36_r8,1.e36_r8,9000._r8, 200._r8, 400._r8,1.e36_r8,1.e36_r8,9000._r8,1.e36_r8,9000._r8/ + data rclo(4,1:NLUse) & + /1.e36_r8,1000._r8,1000._r8, 400._r8,1500._r8, 600._r8,1.e36_r8,1.e36_r8, 800._r8,1000._r8, 800._r8/ + + data ri (5,1:NLUse) & + /1.e36_r8, 120._r8, 240._r8, 140._r8, 250._r8, 190._r8,1.e36_r8,1.e36_r8, 160._r8, 200._r8, 300._r8/ + data rlu (5,1:NLUse) & + /1.e36_r8,4000._r8,4000._r8,4000._r8,2000._r8,3000._r8,1.e36_r8,1.e36_r8,4000._r8,4000._r8,8000._r8/ + data rac (5,1:NLUse) & + / 100._r8, 50._r8, 80._r8,1200._r8,2000._r8,1500._r8, 0._r8, 0._r8, 200._r8, 60._r8, 120._r8/ + data rgss(5,1:NLUse) & + / 500._r8, 150._r8, 350._r8, 500._r8, 500._r8, 200._r8, 0._r8,1000._r8, 0._r8, 250._r8, 400._r8/ + data rgso(5,1:NLUse) & + / 300._r8, 150._r8, 200._r8, 200._r8, 200._r8, 300._r8,2000._r8, 400._r8,1000._r8, 180._r8, 200._r8/ + data rcls(5,1:NLUse) & + /1.e36_r8,4000._r8,4000._r8,4000._r8,2000._r8,3000._r8,1.e36_r8,1.e36_r8,4000._r8,4000._r8,8000._r8/ + data rclo(5,1:NLUse) & + /1.e36_r8,1000._r8, 500._r8, 500._r8,1500._r8, 700._r8,1.e36_r8,1.e36_r8, 600._r8, 800._r8, 800._r8/ + + !--------------------------------------------------------------------------- + ! ... roughness length + !--------------------------------------------------------------------------- + real(r8), public, dimension(NSeas,NLUse) :: z0 + + data z0 (1,1:NLUse) & + /1.000_r8,0.250_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.150_r8,0.100_r8,0.100_r8/ + data z0 (2,1:NLUse) & + /1.000_r8,0.100_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.100_r8,0.080_r8,0.080_r8/ + data z0 (3,1:NLUse) & + /1.000_r8,0.005_r8,0.050_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.100_r8,0.020_r8,0.060_r8/ + data z0 (4,1:NLUse) & + /1.000_r8,0.001_r8,0.001_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.001_r8,0.001_r8,0.040_r8/ + data z0 (5,1:NLUse) & + /1.000_r8,0.030_r8,0.020_r8,1.000_r8,1.000_r8,1.000_r8,0.0006_r8,0.002_r8,0.010_r8,0.030_r8,0.060_r8/ + + !real(r8), private, dimension(11,5), parameter :: z0xxx = reshape ( & + ! (/ 1.000,0.250,0.050,1.000,1.000,1.000,0.0006,0.002,0.150,0.100,0.100 , & + ! 1.000,0.100,0.050,1.000,1.000,1.000,0.0006,0.002,0.100,0.080,0.080 , & + ! 1.000,0.005,0.050,1.000,1.000,1.000,0.0006,0.002,0.100,0.020,0.060 , & + ! 1.000,0.001,0.001,1.000,1.000,1.000,0.0006,0.002,0.001,0.001,0.040 , & + ! 1.000,0.030,0.020,1.000,1.000,1.000,0.0006,0.002,0.010,0.030,0.060 /), (/11,5/) ) + + !--------------------------------------------------------------------------- + ! public chemical data + !--------------------------------------------------------------------------- + + !--- data for foxd (reactivity factor for oxidation) ---- + real(r8), public, parameter :: dfoxd(n_species_table) = & + (/ 1._r8 & ! OX + ,1._r8 & ! H2O2 + ,1._r8 & ! OH + ,.1_r8 & ! HO2 + ,1.e-36_r8 & ! CO + ,1.e-36_r8 & ! CH4 + ,1._r8 & ! CH3O2 + ,1._r8 & ! CH3OOH + ,1._r8 & ! CH2O + ,1._r8 & ! HCOOH + ,0._r8 & ! NO + ,.1_r8 & ! NO2 + ,1.e-36_r8 & ! HNO3 + ,1.e-36_r8 & ! CO2 + ,1.e-36_r8 & ! NH3 + ,.1_r8 & ! N2O5 + ,1._r8 & ! NO3 + ,1._r8 & ! CH3OH + ,.1_r8 & ! HO2NO2 + ,1._r8 & ! O1D + ,1.e-36_r8 & ! C2H6 + ,.1_r8 & ! C2H5O2 + ,.1_r8 & ! PO2 + ,.1_r8 & ! MACRO2 + ,.1_r8 & ! ISOPO2 + ,1.e-36_r8 & ! C4H10 + ,1._r8 & ! CH3CHO + ,1._r8 & ! C2H5OOH + ,1.e-36_r8 & ! C3H6 + ,1._r8 & ! POOH + ,1.e-36_r8 & ! C2H4 + ,.1_r8 & ! PAN + ,1._r8 & ! CH3COOOH + ,1.e-36_r8 & ! MTERP + ,1._r8 & ! GLYOXAL + ,1._r8 & ! CH3COCHO + ,1._r8 & ! GLYALD + ,.1_r8 & ! CH3CO3 + ,1.e-36_r8 & ! C3H8 + ,.1_r8 & ! C3H7O2 + ,1._r8 & ! CH3COCH3 + ,1._r8 & ! C3H7OOH + ,.1_r8 & ! RO2 + ,1._r8 & ! ROOH + ,1.e-36_r8 & ! Rn + ,1.e-36_r8 & ! ISOP + ,1._r8 & ! MVK + ,1._r8 & ! MACR + ,1._r8 & ! C2H5OH + ,1._r8 & ! ONITR + ,.1_r8 & ! ONIT + ,.1_r8 & ! ISOPNO3 + ,1._r8 & ! HYDRALD + ,1.e-36_r8 & ! HCN + ,1.e-36_r8 & ! CH3CN + ,1.e-36_r8 & ! SO2 + ,0.1_r8 & ! SOAGff0 + ,0.1_r8 & ! SOAGff1 + ,0.1_r8 & ! SOAGff2 + ,0.1_r8 & ! SOAGff3 + ,0.1_r8 & ! SOAGff4 + ,0.1_r8 & ! SOAGbg0 + ,0.1_r8 & ! SOAGbg1 + ,0.1_r8 & ! SOAGbg2 + ,0.1_r8 & ! SOAGbg3 + ,0.1_r8 & ! SOAGbg4 + ,0.1_r8 & ! SOAG0 + ,0.1_r8 & ! SOAG1 + ,0.1_r8 & ! SOAG2 + ,0.1_r8 & ! SOAG3 + ,0.1_r8 & ! SOAG4 + ,0.1_r8 & ! IVOC + ,0.1_r8 & ! SVOC + ,0.1_r8 & ! IVOCbb + ,0.1_r8 & ! IVOCff + ,0.1_r8 & ! SVOCbb + ,0.1_r8 & ! SVOCff + ,1.e-36_r8 & ! N2O + ,1.e-36_r8 & ! H2 + ,1.e-36_r8 & ! C2H2 + ,1._r8 & ! CH3COOH + ,1._r8 & ! EOOH + ,1._r8 & ! HYAC + ,1.e-36_r8 & ! BIGENE + ,1.e-36_r8 & ! BIGALK + ,1._r8 & ! MEK + ,1._r8 & ! MEKOOH + ,1._r8 & ! MACROOH + ,1._r8 & ! MPAN + ,1._r8 & ! ALKNIT + ,1._r8 & ! NOA + ,1._r8 & ! ISOPNITA + ,1._r8 & ! ISOPNITB + ,1._r8 & ! ISOPNOOH + ,1._r8 & ! NC4CHO + ,1._r8 & ! NC4CH2OH + ,1._r8 & ! TERPNIT + ,1._r8 & ! NTERPOOH + ,1._r8 & ! ALKOOH + ,1._r8 & ! BIGALD + ,1._r8 & ! HPALD + ,1._r8 & ! IEPOX + ,1._r8 & ! XOOH + ,1._r8 & ! ISOPOOH + ,1.e-36_r8 & ! TOLUENE + ,1._r8 & ! CRESOL + ,1._r8 & ! TOLOOH + ,1.e-36_r8 & ! BENZENE + ,1._r8 & ! PHENOL + ,1._r8 & ! BEPOMUC + ,1._r8 & ! PHENOOH + ,1._r8 & ! C6H5OOH + ,1._r8 & ! BENZOOH + ,1._r8 & ! BIGALD1 + ,1._r8 & ! BIGALD2 + ,1._r8 & ! BIGALD3 + ,1._r8 & ! BIGALD4 + ,1._r8 & ! TEPOMUC + ,1._r8 & ! BZOOH + ,1._r8 & ! BZALD + ,1._r8 & ! PBZNIT + ,1.e-36_r8 & ! XYLENES + ,1._r8 & ! XYLOL + ,1._r8 & ! XYLOLOOH + ,1._r8 & ! XYLENOOH + ,1.e-36_r8 & ! BCARY + ,1._r8 & ! TERPOOH + ,1._r8 & ! TERPROD1 + ,1._r8 & ! TERPROD2 + ,1._r8 & ! TERP2OOH + ,1.e-36_r8 & ! DMS + ,1.e-36_r8 & ! H2SO4 + ,1._r8 & ! HONITR + ,1._r8 & ! MACRN + ,1._r8 & ! MVKN + ,1._r8 & ! ISOPN2B + ,1._r8 & ! ISOPN3B + ,1._r8 & ! ISOPN4D + ,1._r8 & ! ISOPN1D + ,1._r8 & ! ISOPNOOHD + ,1._r8 & ! ISOPNOOHB + ,1._r8 & ! ISOPNBNO3 + ,1._r8 & ! NO3CH2CHO + ,1._r8 & ! HYPERACET + ,1._r8 & ! HCOCH2OOH + ,1._r8 & ! DHPMPAL + ,1._r8 & ! MVKOOH + ,1._r8 & ! ISOPOH + ,1._r8 & ! ISOPFDN + ,1._r8 & ! ISOPFNP + ,1._r8 & ! INHEB + ,1._r8 & ! HMHP + ,1._r8 & ! HPALD1 + ,1._r8 & ! INHED + ,1._r8 & ! HPALD4 + ,1._r8 & ! ISOPHFP + ,1._r8 & ! HPALDB1C + ,1._r8 & ! HPALDB4C + ,1._r8 & ! ICHE + ,1._r8 & ! ISOPFDNC + ,1._r8 & ! ISOPFNC + ,1._r8 & ! TERPNT + ,1._r8 & ! TERPNS + ,1._r8 & ! TERPNT1 + ,1._r8 & ! TERPNS1 + ,1._r8 & ! TERPNPT + ,1._r8 & ! TERPNPS + ,1._r8 & ! TERPNPT1 + ,1._r8 & ! TERPNPS1 + ,1._r8 & ! TERPFDN + ,1._r8 & ! SQTN + ,1._r8 & ! TERPHFN + ,1._r8 & ! TERP1OOH + ,1._r8 & ! TERPDHDP + ,1._r8 & ! TERPF2 + ,1._r8 & ! TERPF1 + ,1._r8 & ! TERPA + ,1._r8 & ! TERPA2 + ,1._r8 & ! TERPK + ,1._r8 & ! TERPAPAN + ,1._r8 & ! TERPACID + ,1._r8 & ! TERPA2PAN + ,1.e-36_r8 & ! APIN + ,1.e-36_r8 & ! BPIN + ,1.e-36_r8 & ! LIMON + ,1.e-36_r8 & ! MYRC + ,1._r8 & ! TERPACID2 + ,1._r8 & ! TERPACID3 + ,1._r8 & ! TERPA3PAN + ,1._r8 & ! TERPOOHL + ,1._r8 & ! TERPA3 + ,1._r8 & ! TERP2AOOH + /) + + ! PRIVATE DATA: + + Interface seq_drydep_setHCoeff ! overload subroutine + Module Procedure set_hcoeff_scalar + Module Procedure set_hcoeff_vector + End Interface + + real(r8), private, parameter :: small_value = 1.e-36_r8 !--- smallest value to use --- + + !--------------------------------------------------------------------------- + ! private chemical data + !--------------------------------------------------------------------------- + + !--- Names of species that can work with --- + character(len=20), public, parameter :: species_name_table(n_species_table) = & + (/ 'OX ' & + ,'H2O2 ' & + ,'OH ' & + ,'HO2 ' & + ,'CO ' & + ,'CH4 ' & + ,'CH3O2 ' & + ,'CH3OOH ' & + ,'CH2O ' & + ,'HCOOH ' & + ,'NO ' & + ,'NO2 ' & + ,'HNO3 ' & + ,'CO2 ' & + ,'NH3 ' & + ,'N2O5 ' & + ,'NO3 ' & + ,'CH3OH ' & + ,'HO2NO2 ' & + ,'O1D ' & + ,'C2H6 ' & + ,'C2H5O2 ' & + ,'PO2 ' & + ,'MACRO2 ' & + ,'ISOPO2 ' & + ,'C4H10 ' & + ,'CH3CHO ' & + ,'C2H5OOH ' & + ,'C3H6 ' & + ,'POOH ' & + ,'C2H4 ' & + ,'PAN ' & + ,'CH3COOOH ' & + ,'MTERP ' & + ,'GLYOXAL ' & + ,'CH3COCHO ' & + ,'GLYALD ' & + ,'CH3CO3 ' & + ,'C3H8 ' & + ,'C3H7O2 ' & + ,'CH3COCH3 ' & + ,'C3H7OOH ' & + ,'RO2 ' & + ,'ROOH ' & + ,'Rn ' & + ,'ISOP ' & + ,'MVK ' & + ,'MACR ' & + ,'C2H5OH ' & + ,'ONITR ' & + ,'ONIT ' & + ,'ISOPNO3 ' & + ,'HYDRALD ' & + ,'HCN ' & + ,'CH3CN ' & + ,'SO2 ' & + ,'SOAGff0 ' & + ,'SOAGff1 ' & + ,'SOAGff2 ' & + ,'SOAGff3 ' & + ,'SOAGff4 ' & + ,'SOAGbg0 ' & + ,'SOAGbg1 ' & + ,'SOAGbg2 ' & + ,'SOAGbg3 ' & + ,'SOAGbg4 ' & + ,'SOAG0 ' & + ,'SOAG1 ' & + ,'SOAG2 ' & + ,'SOAG3 ' & + ,'SOAG4 ' & + ,'IVOC ' & + ,'SVOC ' & + ,'IVOCbb ' & + ,'IVOCff ' & + ,'SVOCbb ' & + ,'SVOCff ' & + ,'N2O ' & + ,'H2 ' & + ,'C2H2 ' & + ,'CH3COOH ' & + ,'EOOH ' & + ,'HYAC ' & + ,'BIGENE ' & + ,'BIGALK ' & + ,'MEK ' & + ,'MEKOOH ' & + ,'MACROOH ' & + ,'MPAN ' & + ,'ALKNIT ' & + ,'NOA ' & + ,'ISOPNITA ' & + ,'ISOPNITB ' & + ,'ISOPNOOH ' & + ,'NC4CHO ' & + ,'NC4CH2OH ' & + ,'TERPNIT ' & + ,'NTERPOOH ' & + ,'ALKOOH ' & + ,'BIGALD ' & + ,'HPALD ' & + ,'IEPOX ' & + ,'XOOH ' & + ,'ISOPOOH ' & + ,'TOLUENE ' & + ,'CRESOL ' & + ,'TOLOOH ' & + ,'BENZENE ' & + ,'PHENOL ' & + ,'BEPOMUC ' & + ,'PHENOOH ' & + ,'C6H5OOH ' & + ,'BENZOOH ' & + ,'BIGALD1 ' & + ,'BIGALD2 ' & + ,'BIGALD3 ' & + ,'BIGALD4 ' & + ,'TEPOMUC ' & + ,'BZOOH ' & + ,'BZALD ' & + ,'PBZNIT ' & + ,'XYLENES ' & + ,'XYLOL ' & + ,'XYLOLOOH ' & + ,'XYLENOOH ' & + ,'BCARY ' & + ,'TERPOOH ' & + ,'TERPROD1 ' & + ,'TERPROD2 ' & + ,'TERP2OOH ' & + ,'DMS ' & + ,'H2SO4 ' & + ,'HONITR ' & + ,'MACRN ' & + ,'MVKN ' & + ,'ISOPN2B ' & + ,'ISOPN3B ' & + ,'ISOPN4D ' & + ,'ISOPN1D ' & + ,'ISOPNOOHD' & + ,'ISOPNOOHB' & + ,'ISOPNBNO3' & + ,'NO3CH2CHO' & + ,'HYPERACET' & + ,'HCOCH2OOH' & + ,'DHPMPAL ' & + ,'MVKOOH ' & + ,'ISOPOH ' & + ,'ISOPFDN ' & + ,'ISOPFNP ' & + ,'INHEB ' & + ,'HMHP ' & + ,'HPALD1 ' & + ,'INHED ' & + ,'HPALD4 ' & + ,'ISOPHFP ' & + ,'HPALDB1C ' & + ,'HPALDB4C ' & + ,'ICHE ' & + ,'ISOPFDNC ' & + ,'ISOPFNC ' & + ,'TERPNT ' & + ,'TERPNS ' & + ,'TERPNT1 ' & + ,'TERPNS1 ' & + ,'TERPNPT ' & + ,'TERPNPS ' & + ,'TERPNPT1 ' & + ,'TERPNPS1 ' & + ,'TERPFDN ' & + ,'SQTN ' & + ,'TERPHFN ' & + ,'TERP1OOH ' & + ,'TERPDHDP ' & + ,'TERPF2 ' & + ,'TERPF1 ' & + ,'TERPA ' & + ,'TERPA2 ' & + ,'TERPK ' & + ,'TERPAPAN ' & + ,'TERPACID ' & + ,'TERPA2PAN' & + ,'APIN ' & + ,'BPIN ' & + ,'LIMON ' & + ,'MYRC ' & + ,'TERPACID2' & + ,'TERPACID3' & + ,'TERPA3PAN' & + ,'TERPOOHL ' & + ,'TERPA3 ' & + ,'TERP2AOOH' & + /) + + !--- data for effective Henry's Law coefficient --- + real(r8), public, parameter :: dheff(n_species_table*6) = & + (/1.03e-02_r8, 2830._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! OX + ,8.70e+04_r8, 7320._r8,2.2e-12_r8,-3730._r8,0._r8 , 0._r8 & ! H2O2 + ,3.90e+01_r8, 4300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! OH + ,6.90e+02_r8, 5900._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HO2 + ,9.81e-04_r8, 1650._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CO + ,1.41e-03_r8, 1820._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH4 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3O2 + ,3.00e+02_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3OOH + ,3.23e+03_r8, 7100._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH2O + ,8.90e+03_r8, 6100._r8,1.8e-04_r8, -20._r8,0._r8 , 0._r8 & ! HCOOH + ,1.92e-03_r8, 1762._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO + ,1.20e-02_r8, 2440._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO2 + ,2.10e+05_r8, 8700._r8,2.2e+01_r8, 0._r8,0._r8 , 0._r8 & ! HNO3 + ,3.44e-02_r8, 2715._r8,4.3e-07_r8,-1000._r8,4.7e-11_r8,-1760._r8 & ! CO2 + ,6.02e+01_r8, 4160._r8,1.7e-05_r8,-4325._r8,1.0e-14_r8,-6716._r8 & ! NH3 + ,2.14e+00_r8, 3362._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! N2O5 + ,3.80e-02_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO3 + ,2.03e+02_r8, 5645._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3OH + ,4.00e+01_r8, 8400._r8,1.3e-06_r8, 0._r8,0._r8 , 0._r8 & ! HO2NO2 + ,1.00e-16_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! O1D + ,1.88e-03_r8, 2750._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H6 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H5O2 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PO2 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACRO2 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPO2 + ,1.70e-03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C4H10 + ,1.29e+01_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3CHO + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H5OOH + ,5.57e-03_r8, 2800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H6 + ,1.50e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! POOH + ,5.96e-03_r8, 2200._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H4 + ,2.80e+00_r8, 5730._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PAN + ,8.37e+02_r8, 5310._r8,1.8e-04_r8, -20._r8,0._r8 , 0._r8 & ! CH3COOOH + ,2.94e-02_r8, 1800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MTERP + ,4.19e+05_r8, 7480._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! GLYOXAL + ,3.50e+03_r8, 7545._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3COCHO + ,4.00e+04_r8, 4630._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! GLYALD + ,1.00e-01_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3CO3 + ,1.51e-03_r8, 3120._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H8 + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H7O2 + ,2.78e+01_r8, 5530._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3COCH3 + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C3H7OOH + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! RO2 + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ROOH + ,0.00e+00_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! Rn + ,3.45e-02_r8, 4400._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOP + ,4.10e+01_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MVK + ,6.50e+00_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACR + ,1.90e+02_r8, 6500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H5OH + ,1.44e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ONITR + ,1.00e+03_r8, 6000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ONIT + ,2.38e+00_r8, 5280._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNO3 + ,1.10e+05_r8, 6000._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HYDRALD + ,9.02e+00_r8, 8258._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HCN + ,5.28e+01_r8, 3970._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3CN + ,1.36e+00_r8, 3100._r8,1.30e-02_r8,1960._r8,6.6e-08_r8, 1500._r8 & ! SO2 + ,1.3e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff0 + ,3.2e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff1 + ,4.0e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff2 + ,1.3e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff3 + ,1.6e+05_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGff4 + ,7.9e+11_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg0 + ,6.3e+10_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg1 + ,3.2e+09_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg2 + ,6.3e+08_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg3 + ,3.2e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAGbg4 + ,4.0e+11_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG0 + ,3.2e+10_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG1 + ,1.6e+09_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG2 + ,3.2e+08_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG3 + ,1.6e+07_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SOAG4 + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IVOC + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SVOC + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IVOCbb + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IVOCff + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SVOCbb + ,1.e+03_r8, 0._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SVOCff + ,2.42e-02_r8, 2710._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! N2O + ,7.9e-04_r8, 530._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! H2 + ,4.14e-02_r8, 1890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C2H2 + ,4.1e+03_r8, 6200._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CH3COOH + ,1.9e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! EOOH + ,1.46e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HYAC + ,5.96e-03_r8, 2365._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGENE + ,1.24e-03_r8, 3010._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALK + ,1.80e+01_r8, 5740._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MEK + ,6.4e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MEKOOH + ,4.4e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACROOH + ,1.72e+00_r8, 5700._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MPAN + ,1.01e+00_r8, 5790._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ALKNIT + ,1.e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NOA + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNITA + ,4.82e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNITB + ,8.75e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNOOH + ,1.46e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NC4CHO + ,4.02e+04_r8, 9500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NC4CH2OH + ,8.41e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNIT + ,6.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NTERPOOH + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ALKOOH + ,9.6e+00_r8, 6220._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD + ,2.30e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALD + ,3.e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! IEPOX + ,1.e+11_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XOOH + ,3.5e+06_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPOOH + ,1.5e-01_r8, 4300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TOLUENE + ,5.67e+02_r8, 5800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! CRESOL + ,2.30e+04_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TOLOOH + ,1.8e-01_r8, 3800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BENZENE + ,2.84e+03_r8, 2700._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PHENOL + ,3.e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BEPOMUC + ,1.5e+06_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PHENOOH + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! C6H5OOH + ,2.3e+03_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BENZOOH + ,1.e+05_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD1 + ,2.9e+04_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD2 + ,2.2e+04_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD3 + ,2.2e+04_r8, 5890._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BIGALD4 + ,2.5e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TEPOMUC + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BZOOH + ,3.24e+01_r8, 6300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BZALD + ,2.8e+00_r8, 5730._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! PBZNIT + ,2.e-01_r8, 4300._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLENES + ,1.01e+03_r8, 6800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLOL + ,1.9e+06_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLOLOOH + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! XYLENOOH + ,5.57e-03_r8, 2800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BCARY + ,3.6e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPOOH + ,3.92e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPROD1 + ,7.20e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPROD2 + ,3.36e+02_r8, 5995._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERP2OOH + ,5.4e-01_r8, 3460._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! DMS + ,1.e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! H2SO4 + ,2.64e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HONITR + ,4.14e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MACRN + ,1.84e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MVKN + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN2B + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN3B + ,4.82e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN4D + ,4.82e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPN1D + ,9.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNOOHD + ,6.61e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNOOHB + ,8.34e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPNBNO3 + ,3.39e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! NO3CH2CHO + ,1.16e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HYPERACET + ,2.99e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HCOCH2OOH + ,9.37e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! DHPMPAL + ,1.24e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MVKOOH + ,8.77e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPOH + ,5.02e+08_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFDN + ,2.97e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFNP + ,1.05e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! INHEB + ,1.70e+06_r8, 9870._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HMHP + ,2.30e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALD1 + ,1.51e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! INHED + ,2.30e+05_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALD4 + ,7.60e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPHFP + ,5.43e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALDB1C + ,5.43e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! HPALDB4C + ,2.09e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ICHE + ,7.16e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFDNC + ,1.41e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! ISOPFNC + ,8.41e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNT + ,8.41e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNS + ,8.55e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNT1 + ,8.55e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNS1 + ,6.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPT + ,6.67e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPS + ,6.78e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPT1 + ,6.78e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPNPS1 + ,1.65e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPFDN + ,9.04e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! SQTN + ,7.53e+11_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPHFN + ,3.64e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERP1OOH + ,3.41e+14_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPDHDP + ,6.54e+01_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPF2 + ,4.05e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPF1 + ,3.92e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA + ,7.20e+04_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA2 + ,6.39e+01_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPK + ,7.94e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPAPAN + ,5.63e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPACID + ,9.59e+03_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA2PAN + ,2.94e-02_r8, 1800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! APIN + ,1.52e-02_r8, 4500._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! BPIN + ,4.86e-02_r8, 4600._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! LIMON + ,7.30e-02_r8, 2800._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! MYRC + ,2.64e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPACID2 + ,3.38e+09_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPACID3 + ,1.23e+07_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA3PAN + ,4.41e+12_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPOOHL + ,1.04e+08_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERPA3 + ,3.67e+06_r8, 6014._r8,0._r8 , 0._r8,0._r8 , 0._r8 & ! TERP2AOOH + /) + + real(r8), private, parameter :: wh2o = SHR_CONST_MWWV + real(r8), private, parameter :: mol_wgts(n_species_table) = & + (/ 47.9981995_r8, 34.0135994_r8, 17.0067997_r8, 33.0061989_r8, 28.0104008_r8, & + 16.0405998_r8, 47.0320015_r8, 48.0393982_r8, 30.0251999_r8, 46.0246010_r8, & + 30.0061398_r8, 46.0055389_r8, 63.0123405_r8, 44.0098000_r8, 17.0289402_r8, & + 108.010483_r8, 62.0049400_r8, 32.0400009_r8, 79.0117416_r8, 15.9994001_r8, & + 30.0664005_r8, 61.0578003_r8, 91.0830002_r8, 119.093399_r8, 117.119797_r8, & + 58.1180000_r8, 44.0509987_r8, 62.0652008_r8, 42.0774002_r8, 92.0904007_r8, & + 28.0515995_r8, 121.047943_r8, 76.0497971_r8, 136.228394_r8, 58.0355988_r8, & + 72.0614014_r8, 60.0503998_r8, 75.0423965_r8, 44.0922012_r8, 75.0836029_r8, & + 58.0768013_r8, 76.0910034_r8, 89.070126_r8, 90.078067_r8, 222.000000_r8, & + 68.1141968_r8, 70.0877991_r8, 70.0877991_r8, 46.0657997_r8, 147.125946_r8, & + 119.074341_r8, 162.117935_r8, 100.112999_r8, 27.0256_r8 , 41.0524_r8 , & + 64.064800_r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 250._r8, 250._r8, 250._r8, 250._r8, & + 250._r8, 170.3_r8, 170.3_r8, 170.3_r8, 170.3_r8, & + 170.3_r8, 170.3_r8, 44.0129_r8, 2.0148_r8, 26.0368_r8, & + 60.0504_r8, 78.0646_r8, 74.0762_r8, 56.1032_r8, 72.1438_r8, & + 72.1026_r8, 104.101_r8, 120.101_r8, 147.085_r8, 133.141_r8, & + 119.074_r8, 147.126_r8, 147.126_r8, 163.125_r8, 145.111_r8, & + 147.126_r8, 215.24_r8, 231.24_r8, 104.143_r8, 98.0982_r8, & + 116.112_r8, 118.127_r8, 150.126_r8, 118.127_r8, 92.1362_r8, & + 108.136_r8, 174.148_r8, 78.1104_r8, 94.1098_r8, 126.109_r8, & + 176.122_r8, 110.109_r8, 160.122_r8, 84.0724_r8, 98.0982_r8, & + 98.0982_r8, 112.124_r8, 140.134_r8, 124.135_r8, 106.121_r8, & + 183.118_r8, 106.162_r8, 122.161_r8, 204.173_r8, 188.174_r8, & + 204.343_r8, 186.241_r8, 168.227_r8, 154.201_r8, 200.226_r8, & + 62.1324_r8, 98.0784_r8, 135.118733_r8, 149.102257_r8, 149.102257_r8, & + 147.129469_r8, 147.129469_r8, 147.129469_r8, 147.129469_r8, 163.128874_r8, & + 163.128874_r8, 147.129469_r8, 105.049617_r8, 90.078067_r8, 76.05145_r8, & + 136.103494_r8, 120.104089_r8, 102.131897_r8, 226.141733_r8, 197.143565_r8, & + 163.128874_r8, 64.040714_r8, 116.11542_r8, 163.128874_r8, 116.11542_r8, & + 150.130112_r8, 116.11542_r8, 116.11542_r8, 116.11542_r8, 224.125851_r8, & + 195.127684_r8, 215.246675_r8, 215.246675_r8, 215.246675_r8, 215.246675_r8, & + 231.24608_r8, 231.24608_r8, 231.24608_r8, 231.24608_r8, 294.258938_r8, & + 283.36388_r8, 265.260771_r8, 186.248507_r8, 236.262604_r8, 110.153964_r8, & + 168.233221_r8, 168.233221_r8, 154.206603_r8, 138.207199_r8, 245.229603_r8, & + 200.232031_r8, 231.202986_r8, 136.228394_r8, 136.228394_r8, 136.228394_r8, & + 136.228394_r8, 186.205413_r8, 202.204818_r8, 247.202391_r8, 218.247317_r8, & + 170.206008_r8, 186.248507_r8 /) + + +!=============================================================================== +CONTAINS +!=============================================================================== + + subroutine seq_drydep_readnl(NLFilename, drydep_nflds) + + !======================================================================== + ! reads drydep_inparm namelist and determines the number of drydep velocity + ! fields that are sent from the land component + !======================================================================== + + character(len=*), intent(in) :: NLFilename ! Namelist filename + integer, intent(out) :: drydep_nflds + + !----- local ----- + integer :: i ! Indices + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: rc + character(*),parameter :: F00 = "('(seq_drydep_read) ',8a)" + character(*),parameter :: FI1 = "('(seq_drydep_init) ',a,I2)" + character(*),parameter :: subName = '(seq_drydep_read) ' + !----------------------------------------------------------------------------- + + namelist /drydep_inparm/ drydep_list, drydep_method + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the drydep field list to pass + ! First check if file exists and if not, n_drydep will be zero + !----------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 )then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(s_logunit,F00) 'Read in drydep_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'drydep_inparm', ierr) + if (ierr == 0) then + ! Note that ierr /= 0, no namelist is present. + read(unitn, drydep_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of drydep_inparm namelist in seq_drydep_readnl') + end if + endif + close( unitn ) + end if + end if + call shr_mpi_bcast( drydep_list, mpicom ) + call shr_mpi_bcast( drydep_method, mpicom ) + + do i=1,maxspc + if(len_trim(drydep_list(i)) > 0) then + drydep_nflds=drydep_nflds+1 + endif + enddo + + ! set module variable + n_drydep = drydep_nflds + + ! Make sure method is valid and determine if land is passing drydep fields + lnd_drydep = (drydep_nflds>0 .and. drydep_method == DD_XLND) + if (localpet==0) then + write(s_logunit,*) 'seq_drydep_read: drydep_method: ', trim(drydep_method) + if ( drydep_nflds == 0 )then + write(s_logunit,F00) 'No dry deposition fields will be transfered' + else + write(s_logunit,FI1) 'Number of dry deposition fields transfered is ', drydep_nflds + end if + end if + + if ( trim(drydep_method)/=trim(DD_XATM) .and. & + trim(drydep_method)/=trim(DD_XLND) .and. & + trim(drydep_method)/=trim(DD_TABL) ) then + write(s_logunit,*) 'seq_drydep_read: drydep_method : ', trim(drydep_method) + write(s_logunit,*) 'seq_drydep_read: drydep_method must be set to : ', & + DD_XATM,', ', DD_XLND,', or ', DD_TABL + call shr_sys_abort('seq_drydep_read: incorrect dry deposition method specification') + endif + + if (.not. drydep_initialized) then + call seq_drydep_init() + end if + + end subroutine seq_drydep_readnl + +!==================================================================================== + + subroutine seq_drydep_init( ) + + !======================================================================== + ! Initialization of dry deposition fields + ! reads drydep_inparm namelist and sets up CCSM driver list of fields for + ! land-atmosphere communications. + !======================================================================== + + !----- local ----- + integer :: i, l ! Indices + character(len=32) :: test_name ! field test name + + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_init) ' + character(*),parameter :: F00 = "('(seq_drydep_init) ',8a)" + + !----------------------------------------------------------------------------- + ! Return if this routine has already been called (e.g. cam and clm both call this) + !----------------------------------------------------------------------------- + if(allocated(foxd)) return + !----------------------------------------------------------------------------- + ! Allocate and fill foxd, drat and mapping as well as species indices + !----------------------------------------------------------------------------- + + if ( n_drydep > 0 ) then + + allocate( foxd(n_drydep) ) + allocate( drat(n_drydep) ) + allocate( mapping(n_drydep) ) + + ! This initializes these variables to infinity. + foxd = shr_infnan_posinf + drat = shr_infnan_posinf + + mapping(:) = 0 + + end if + + h2_ndx=-1; ch4_ndx=-1; co_ndx=-1; mpan_ndx = -1; pan_ndx = -1; so2_ndx=-1; o3_ndx=-1; xpan_ndx=-1 + + !--- Loop over drydep species that need to be worked with --- + do i=1,n_drydep + if ( len_trim(drydep_list(i))==0 ) exit + + test_name = drydep_list(i) + + if( trim(test_name) == 'O3' ) then + test_name = 'OX' + end if + + !--- Figure out if species maps to a species in the species table --- + do l = 1,n_species_table + if( trim( test_name ) == trim( species_name_table(l) ) ) then + mapping(i) = l + exit + end if + end do + + !--- If it doesn't map to a species in the species table find species close enough --- + if( mapping(i) < 1 ) then + select case( trim(test_name) ) + case( 'O3S', 'O3INERT' ) + test_name = 'OX' + case( 'Pb' ) + test_name = 'HNO3' + case( 'SOGM','SOGI','SOGT','SOGB','SOGX' ) + test_name = 'CH3OOH' + case( 'SOA', 'SO4', 'CB1', 'CB2', 'OC1', 'OC2', 'NH4', 'SA1', 'SA2', 'SA3', 'SA4' ) + test_name = 'OX' ! this is just a place holder. values are explicitly set below + case( 'SOAM', 'SOAI', 'SOAT', 'SOAB', 'SOAX' ) + test_name = 'OX' ! this is just a place holder. values are explicitly set below + case( 'SOAGbb0' ) + test_name = 'SOAGff0' + case( 'SOAGbb1' ) + test_name = 'SOAGff1' + case( 'SOAGbb2' ) + test_name = 'SOAGff2' + case( 'SOAGbb3' ) + test_name = 'SOAGff3' + case( 'SOAGbb4' ) + test_name = 'SOAGff4' + case( 'O3A' ) + test_name = 'OX' + case( 'XMPAN' ) + test_name = 'MPAN' + case( 'XPAN' ) + test_name = 'PAN' + case( 'XNO' ) + test_name = 'NO' + case( 'XNO2' ) + test_name = 'NO2' + case( 'XHNO3' ) + test_name = 'HNO3' + case( 'XONIT' ) + test_name = 'ONIT' + case( 'XONITR' ) + test_name = 'ONITR' + case( 'XHO2NO2') + test_name = 'HO2NO2' + case( 'XNH4NO3' ) + test_name = 'HNO3' + case( 'NH4NO3' ) + test_name = 'HNO3' + case default + test_name = 'blank' + end select + + !--- If found a match check the species table again --- + if( trim(test_name) /= 'blank' ) then + do l = 1,n_species_table + if( trim( test_name ) == trim( species_name_table(l) ) ) then + mapping(i) = l + exit + end if + end do + else + write(s_logunit,F00) trim(drydep_list(i)),' not in tables; will have dep vel = 0' + call shr_sys_abort( subName//': '//trim(drydep_list(i))//' is not in tables' ) + end if + end if + + !--- Figure out the specific species indices --- + if ( trim(drydep_list(i)) == 'H2' ) h2_ndx = i + if ( trim(drydep_list(i)) == 'CO' ) co_ndx = i + if ( trim(drydep_list(i)) == 'CH4' ) ch4_ndx = i + if ( trim(drydep_list(i)) == 'MPAN' ) mpan_ndx = i + if ( trim(drydep_list(i)) == 'PAN' ) pan_ndx = i + if ( trim(drydep_list(i)) == 'SO2' ) so2_ndx = i + if ( trim(drydep_list(i)) == 'OX' .or. trim(drydep_list(i)) == 'O3' ) o3_ndx = i + if ( trim(drydep_list(i)) == 'O3A' ) o3a_ndx = i + if ( trim(drydep_list(i)) == 'XPAN' ) xpan_ndx = i + + if( mapping(i) > 0) then + l = mapping(i) + foxd(i) = dfoxd(l) + drat(i) = sqrt(mol_wgts(l)/wh2o) + endif + + enddo + + where( rgss < 1._r8 ) + rgss = 1._r8 + endwhere + + where( rac < small_value) + rac = small_value + endwhere + + drydep_initialized = .true. + + end subroutine seq_drydep_init + +!==================================================================================== + + subroutine set_hcoeff_scalar( sfc_temp, heff ) + + !======================================================================== + ! Interface to seq_drydep_setHCoeff when input is scalar + ! wrapper routine used when surface temperature is a scalar (single column) rather + ! than an array (multiple columns). + ! + ! !REVISION HISTORY: + ! 2008-Nov-12 - F. Vitt - first version + !======================================================================== + + implicit none + + real(r8), intent(in) :: sfc_temp ! Input surface temperature + real(r8), intent(out) :: heff(n_drydep) ! Output Henry's law coefficients + + !----- local ----- + real(r8) :: sfc_temp_tmp(1) ! surface temp + + sfc_temp_tmp(:) = sfc_temp + call set_hcoeff_vector( 1, sfc_temp_tmp, heff(:n_drydep) ) + + end subroutine set_hcoeff_scalar + +!==================================================================================== + + subroutine set_hcoeff_vector( ncol, sfc_temp, heff ) + + !======================================================================== + ! Interface to seq_drydep_setHCoeff when input is vector + ! sets dry depositions coefficients -- used by both land and atmosphere models + !======================================================================== + + integer, intent(in) :: ncol ! Input size of surface-temp vector + real(r8), intent(in) :: sfc_temp(ncol) ! Surface temperature + real(r8), intent(out) :: heff(ncol,n_drydep) ! Henry's law coefficients + + !----- local ----- + real(r8), parameter :: t0 = 298._r8 ! Standard Temperature + real(r8), parameter :: ph_inv = 1._r8/ph ! Inverse of PH + integer :: m, l, id ! indices + real(r8) :: e298 ! Henry's law coefficient @ standard temperature (298K) + real(r8) :: dhr ! temperature dependence of Henry's law coefficient + real(r8) :: dk1s(ncol) ! DK Work array 1 + real(r8) :: dk2s(ncol) ! DK Work array 2 + real(r8) :: wrk(ncol) ! Work array + + !----- formats ----- + character(*),parameter :: subName = '(seq_drydep_set_hcoeff) ' + character(*),parameter :: F00 = "('(seq_drydep_set_hcoeff) ',8a)" + + !------------------------------------------------------------------------------- + ! notes: + !------------------------------------------------------------------------------- + + wrk(:) = (t0 - sfc_temp(:))/(t0*sfc_temp(:)) + do m = 1,n_drydep + l = mapping(m) + id = 6*(l - 1) + e298 = dheff(id+1) + dhr = dheff(id+2) + heff(:,m) = e298*exp( dhr*wrk(:) ) + !--- Calculate coefficients based on the drydep tables --- + if( dheff(id+3) /= 0._r8 .and. dheff(id+5) == 0._r8 ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + where( heff(:,m) /= 0._r8 ) + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph_inv) + elsewhere + heff(:,m) = dk1s(:)*ph_inv + endwhere + end if + !--- For coefficients that are non-zero AND CO2 or NH3 handle things this way --- + if( dheff(id+5) /= 0._r8 ) then + if( trim( drydep_list(m) ) == 'CO2' .or. trim( drydep_list(m) ) == 'NH3' & + .or. trim( drydep_list(m) ) == 'SO2' ) then + e298 = dheff(id+3) + dhr = dheff(id+4) + dk1s(:) = e298*exp( dhr*wrk(:) ) + e298 = dheff(id+5) + dhr = dheff(id+6) + dk2s(:) = e298*exp( dhr*wrk(:) ) + !--- For Carbon dioxide --- + if( trim(drydep_list(m)) == 'CO2'.or. trim( drydep_list(m) ) == 'SO2' ) then + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph_inv*(1._r8 + dk2s(:)*ph_inv)) + !--- For NH3 --- + else if( trim( drydep_list(m) ) == 'NH3' ) then + heff(:,m) = heff(:,m)*(1._r8 + dk1s(:)*ph/dk2s(:)) + !--- This can't happen --- + else + write(s_logunit,F00) 'Bad species ',drydep_list(m) + call shr_sys_abort( subName//'ERROR: in assigning coefficients' ) + end if + end if + end if + end do + + end subroutine set_hcoeff_vector + +!=============================================================================== + +end module seq_drydep_mod diff --git a/cesm/nuopc_cap_share/shr_carma_mod.F90 b/cesm/nuopc_cap_share/shr_carma_mod.F90 new file mode 100644 index 000000000..3946b8878 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_carma_mod.F90 @@ -0,0 +1,76 @@ +module shr_carma_mod + + !================================================================================ + ! This reads the carma_inparm namelist in drv_flds_in and makes the relavent + ! information available to CAM, CLM, and driver. + !================================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8, CX => SHR_KIND_CX + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : logunit => shr_log_Unit + use shr_nl_mod , only : shr_nl_find_group_name + + implicit none + private + + public :: shr_carma_readnl ! reads carma_inparm namelist + +!------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------- + + subroutine shr_carma_readnl( NLFileName, carma_fields) + + !------------------------------------------------------------------------- + ! This reads the carma_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + !------------------------------------------------------------------------- + + use ESMF, only : ESMF_VM, ESMF_VMGetCurrent, ESMF_VMGet, ESMF_VMBroadcast + + character(len=*) , intent(in) :: NLFileName + character(len=CX), intent(out) :: carma_fields + + type(ESMF_VM) :: vm + integer :: localPet + integer :: rc + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: i, tmp(1) + character(*),parameter :: F00 = "('(shr_carma_readnl) ',2a)" + + namelist /carma_inparm/ carma_fields + + carma_fields = ' ' + call ESMF_VMGetCurrent(vm, rc=rc) + call ESMF_VMGet(vm, localpet=localpet, rc=rc) + tmp = 0 + if (localpet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(logunit,F00) 'Read in carma_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'carma_inparm', status=ierr) + if (ierr == 0) then + read(unitn, carma_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of carma_inparm namelist in shr_carma_readnl' ) + endif + else + write(logunit,*) 'shr_carma_readnl: no carma_inparm namelist found in ',NLFilename + end if + close( unitn ) + else + write(logunit,*) 'shr_carma_readnl: no file ',NLFilename, ' found' + end if + if (len_trim(carma_fields) > 0) tmp(1)=1 + end if + call ESMF_VMBroadcast(vm, tmp, 1, 0, rc=rc) + if(tmp(1) == 1) then + call ESMF_VMBroadcast(vm, carma_fields, CX, 0, rc=rc) + endif + + end subroutine shr_carma_readnl + +endmodule shr_carma_mod diff --git a/cesm/nuopc_cap_share/shr_expr_parser_mod.F90 b/cesm/nuopc_cap_share/shr_expr_parser_mod.F90 new file mode 100644 index 000000000..f37a4ac3c --- /dev/null +++ b/cesm/nuopc_cap_share/shr_expr_parser_mod.F90 @@ -0,0 +1,185 @@ +!============================================================================= +! expression parser utility -- +! for parsing simple linear mathematical expressions of the form +! X = a*Y + b*Z + ... +! +!============================================================================= +module shr_expr_parser_mod + use shr_kind_mod,only : r8 => shr_kind_r8 + use shr_kind_mod,only : cx => shr_kind_cx + + implicit none + private + + public :: shr_exp_parse ! parses simple strings which contain expressions + public :: shr_exp_item_t ! user defined type which contains an expression component + public :: shr_exp_list_destroy ! destroy the linked list returned by shr_exp_parse + + ! contains componets of expression + type shr_exp_item_t + character(len=64) :: name + character(len=64),pointer :: vars(:) => null() + real(r8) ,pointer :: coeffs(:) => null() + integer :: n_terms = 0 + type(shr_exp_item_t), pointer :: next_item => null() + end type shr_exp_item_t + +contains + + ! ----------------------------------------------------------------- + ! parses expressions provided in array of strings + ! ----------------------------------------------------------------- + function shr_exp_parse( exp_array, nitems ) result(exp_items_list) + + character(len=*), intent(in) :: exp_array(:) ! contains a expressions + integer, optional, intent(out) :: nitems ! number of expressions parsed + type(shr_exp_item_t), pointer :: exp_items_list ! linked list of items returned + + integer :: i,j, jj, nmax, nterms, n_exp_items + character(len=cx) :: tmp_str + type(shr_exp_item_t), pointer :: exp_item, list_item + + nullify( exp_items_list ) + nullify( exp_item ) + nullify( list_item ) + + n_exp_items = 0 + nmax = size( exp_array ) + + do i = 1,nmax + if (len_trim(exp_array(i))>0) then + + j = scan( exp_array(i), '=' ) + + if ( j>0 ) then + + n_exp_items = n_exp_items + 1 + + allocate( exp_item ) + exp_item%n_terms = 0 + exp_item%name = trim(adjustl(exp_array(i)(:j-1))) + + tmp_str = trim(adjustl(exp_array(i)(j+1:))) + + nterms = 1 + jj = scan( tmp_str, '+' ) + do while(jj>0) + nterms = nterms + 1 + tmp_str = tmp_str(jj+1:) + jj = scan( tmp_str, '+' ) + enddo + + allocate( exp_item%vars(nterms) ) + allocate( exp_item%coeffs(nterms) ) + + tmp_str = trim(adjustl(exp_array(i)(j+1:))) + + j = scan( tmp_str, '+' ) + + if (j>0) then + call set_coefvar( tmp_str(:j-1), exp_item ) + tmp_str = tmp_str(j-1:) + else + call set_coefvar( tmp_str, exp_item ) + endif + + else + + tmp_str = trim(adjustl(exp_array(i))) ! assumed to begin with '+' + + endif + + ! at this point tmp_str begins with '+' + j = scan( tmp_str, '+' ) + + if (j>0) then + + ! remove the leading + ... + tmp_str = tmp_str(j+1:) + j = scan( tmp_str, '+' ) + + do while(j>0) + + call set_coefvar( tmp_str(:j-1), exp_item ) + + tmp_str = tmp_str(j+1:) + j = scan( tmp_str, '+' ) + + enddo + + call set_coefvar( tmp_str, exp_item ) + + endif + + + if (associated(exp_item)) then + if (associated(exp_items_list)) then + list_item => exp_items_list + do while(associated(list_item%next_item)) + list_item => list_item%next_item + enddo + list_item%next_item => exp_item + else + exp_items_list => exp_item + endif + endif + + endif + enddo + + if ( present(nitems) ) then + nitems = n_exp_items + endif + + end function shr_exp_parse + + ! ----------------------------------------------------------------- + ! deallocates memory occupied by linked list + ! ----------------------------------------------------------------- + subroutine shr_exp_list_destroy( list ) + type(shr_exp_item_t), pointer, intent(inout) :: list + + type(shr_exp_item_t), pointer :: item, next + + item => list + do while(associated(item)) + next => item%next_item + if (associated(item%vars)) then + deallocate(item%vars) + nullify(item%vars) + deallocate(item%coeffs) + nullify(item%coeffs) + endif + deallocate(item) + nullify(item) + item => next + enddo + + end subroutine shr_exp_list_destroy + + !========================== + ! Private Methods + + ! ----------------------------------------------------------------- + ! ----------------------------------------------------------------- + subroutine set_coefvar( term, item ) + character(len=*), intent(in) :: term + type(shr_exp_item_t) , intent(inout) :: item + + integer :: k, n + + item%n_terms = item%n_terms + 1 + n = item%n_terms + + k = scan( term, '*' ) + if (k>0) then + item%vars(n) = trim(adjustl(term(k+1:))) + read( term(:k-1), *) item%coeffs(n) + else + item%vars(n) = trim(adjustl(term)) + item%coeffs(n) = 1.0_r8 + endif + + end subroutine set_coefvar + +end module shr_expr_parser_mod diff --git a/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 b/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 new file mode 100644 index 000000000..30931271e --- /dev/null +++ b/cesm/nuopc_cap_share/shr_fire_emis_mod.F90 @@ -0,0 +1,297 @@ +module shr_fire_emis_mod + + !================================================================================ + ! Coordinates carbon emissions fluxes from CLM fires for use as sources of + ! chemical constituents in CAM + ! + ! This module reads fire_emis_nl namelist which specifies the compound fluxes + ! that are to be passed through the model coupler. + !================================================================================ + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cx=>shr_kind_cx, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : logunit => shr_log_Unit + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_expr_parser_mod , only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + implicit none + private + + public :: shr_fire_emis_readnl ! reads fire_emis_nl namelist + public :: shr_fire_emis_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) than have fire emissions + public :: shr_fire_emis_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have fire emissions + public :: shr_fire_emis_comps_n ! number of unique emissions components + public :: shr_fire_emis_linkedlist ! points to linked list of shr_fire_emis_comp_t objects + public :: shr_fire_emis_elevated ! elevated emissions in ATM + public :: shr_fire_emis_comp_ptr ! user defined type that points to fire emis data obj (shr_fire_emis_comp_t) + public :: shr_fire_emis_comp_t ! emission component data type + public :: shr_fire_emis_mechcomp_t ! data type for chemical compound in CAM mechanism than has fire emissions + + logical :: fire_emis_initialized = .false. ! true => shr_fire_emis_readnl alreay called + logical :: shr_fire_emis_elevated = .true. + + character(len=CL), public :: shr_fire_emis_factors_file = '' ! a table of basic fire emissions compounds + character(len=CS), public :: shr_fire_emis_ztop_token = 'Sl_fztop' ! token for emissions top of vertical distribution + integer, parameter :: name_len=16 + + ! fire emissions component data structure (or user defined type) + type shr_fire_emis_comp_t + character(len=name_len) :: name ! emissions component name (in fire emissions input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the fire emissions compound (g/mole) + type(shr_fire_emis_comp_t), pointer :: next_emiscomp ! points to next member in the linked list + endtype shr_fire_emis_comp_t + + type shr_fire_emis_comp_ptr + type(shr_fire_emis_comp_t), pointer :: ptr ! points to fire emis data obj (shr_fire_emis_comp_t) + endtype shr_fire_emis_comp_ptr + + ! chemical compound in CAM mechanism that has fire emissions + type shr_fire_emis_mechcomp_t + character(len=16) :: name ! compound name + type(shr_fire_emis_comp_ptr), pointer :: emis_comps(:) ! an array of pointers to fire emis components + integer :: n_emis_comps ! number of fire emis compounds that make up the emissions for this mechanis compound + end type shr_fire_emis_mechcomp_t + + type(shr_fire_emis_mechcomp_t), pointer :: shr_fire_emis_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have fire emissions + type(shr_fire_emis_comp_t), pointer :: shr_fire_emis_linkedlist ! points to linked list top + + integer :: shr_fire_emis_comps_n = 0 ! number of unique fire components + integer :: shr_fire_emis_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have fire emissions + +!------------------------------------------------------------------------- +contains +!------------------------------------------------------------------------- + + subroutine shr_fire_emis_readnl( NLFileName, emis_nflds ) + + !------------------------------------------------------------------------- + ! + ! This reads the fire_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + ! + ! fire_emis_specifier (array of strings) -- Each array element specifies + ! how CAM-Chem constituents are mapped to basic smoke compounds in + ! the fire emissions factors table (fire_emis_factors_file). Each + ! chemistry constituent name (left of '=' sign) is mapped to one or more + ! smoke compound (separated by + sign if more than one), which can be + ! proceeded by a multiplication factor (separated by '*'). + ! Example: + ! fire_emis_specifier = 'bc_a1 = BC','pom_a1 = 1.4*OC','SO2 = SO2' + ! + ! fire_emis_factors_file (string) -- Input file that contains the table + ! of basic compounds that make up the smoke from the CLM fires. This is + ! used in CLM module FireEmisFactorsMod. + ! + ! fire_emis_elevated (locical) -- If true then CAM-Chem treats the fire + ! emission sources as 3-D vertically distributed forcings for the + ! corresponding chemical tracers. + ! + !------------------------------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: NLFileName ! name of namelist file + integer , intent(out) :: emis_nflds + + ! local variables + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: rc + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer, parameter :: maxspc = 100 + character(len=2*CX) :: fire_emis_specifier(maxspc) = ' ' + character(len=CL) :: fire_emis_factors_file = ' ' + logical :: fire_emis_elevated = .true. + integer :: i, tmp(1) + character(*),parameter :: F00 = "('(shr_fire_emis_readnl) ',2a)" + character(len=*), parameter :: subname='(shr_fire_emis_readnl)' + !------------------------------------------------------------------ + + namelist /fire_emis_nl/ fire_emis_specifier, fire_emis_factors_file, fire_emis_elevated + + rc = ESMF_SUCCESS + + ! If other processes have already initialized megan - then the info will just be re-initialized + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(logunit,F00) 'Read in fire_emis_readnl namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'fire_emis_nl', status=ierr) + ! If ierr /= 0, no namelist present. + if (ierr == 0) then + read(unitn, fire_emis_nl, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of fire_emis_nl namelist in shr_fire_emis_readnl' ) + endif + endif + close( unitn ) + end if + end if + call shr_mpi_bcast(fire_emis_specifier , mpicom) + call shr_mpi_bcast(fire_emis_factors_file , mpicom) + call shr_mpi_bcast(fire_emis_elevated , mpicom) + + shr_fire_emis_factors_file = fire_emis_factors_file + shr_fire_emis_elevated = fire_emis_elevated + + ! parse the namelist info and initialize the module data - only if it has not been initialized + if (.not. fire_emis_initialized) then + call shr_fire_emis_init( fire_emis_specifier ) + end if + emis_nflds = shr_fire_emis_mechcomps_n + + end subroutine shr_fire_emis_readnl + +!------------------------------------------------------------------------- +! private methods... +!------------------------------------------------------------------------- + + subroutine shr_fire_emis_init( specifier ) + + !-------------------------------------------------- + ! module data initializer + !-------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: specifier(:) + + ! local variables + integer :: n_entries + integer :: i, j, k + type(shr_exp_item_t), pointer :: items_list, item + !------------------------------------------------------ + + nullify(shr_fire_emis_linkedlist) + + items_list => shr_exp_parse( specifier, nitems=n_entries ) + + allocate(shr_fire_emis_mechcomps(n_entries)) + shr_fire_emis_mechcomps(:)%n_emis_comps = 0 + + item => items_list + i = 1 + do while(associated(item)) + + do k=1,shr_fire_emis_mechcomps_n + if ( trim(shr_fire_emis_mechcomps(k)%name) == trim(item%name) ) then + call shr_sys_abort( 'shr_fire_emis_init : multiple emissions definitions specified for : '//trim(item%name)) + endif + enddo + if (len_trim(item%name) .le. name_len) then + shr_fire_emis_mechcomps(i)%name = item%name(1:name_len) + else + call shr_sys_abort("shr_file_emis_init : name too long for data structure :"//trim(item%name)) + endif + shr_fire_emis_mechcomps(i)%n_emis_comps = item%n_terms + allocate(shr_fire_emis_mechcomps(i)%emis_comps(item%n_terms)) + + do j = 1,item%n_terms + shr_fire_emis_mechcomps(i)%emis_comps(j)%ptr => add_emis_comp( item%vars(j), item%coeffs(j) ) + enddo + shr_fire_emis_mechcomps_n = shr_fire_emis_mechcomps_n+1 + + item => item%next_item + i = i+1 + enddo + if (associated(items_list)) call shr_exp_list_destroy(items_list) + + ! Need to explicitly add Fl_ based on naming convention + + fire_emis_initialized = .true. + + end subroutine shr_fire_emis_init + + !------------------------------------------------------------------------- + + function add_emis_comp( name, coeff ) result(emis_comp) + + character(len=*), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_fire_emis_comp_t), pointer :: emis_comp + + emis_comp => get_emis_comp_by_name(shr_fire_emis_linkedlist, name) + if(associated(emis_comp)) then + ! already in the list so return... + return + endif + + ! create new emissions component and add it to the list + allocate(emis_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + emis_comp%index = shr_fire_emis_comps_n+1 + + emis_comp%name = trim(name) + emis_comp%coeff = coeff + nullify(emis_comp%next_emiscomp) + + call add_emis_comp_to_list(emis_comp) + + end function add_emis_comp + + !------------------------------------------------------------------------- + + recursive function get_emis_comp_by_name(list_comp, name) result(emis_comp) + + type(shr_fire_emis_comp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_fire_emis_comp_t), pointer :: emis_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + emis_comp => list_comp + else + emis_comp => get_emis_comp_by_name(list_comp%next_emiscomp, name) + end if + else + nullify(emis_comp) + end if + + end function get_emis_comp_by_name + + !------------------------------------------------------------------------- + + subroutine add_emis_comp_to_list( new_emis_comp ) + + type(shr_fire_emis_comp_t), target, intent(in) :: new_emis_comp + + type(shr_fire_emis_comp_t), pointer :: list_comp + + if(associated(shr_fire_emis_linkedlist)) then + list_comp => shr_fire_emis_linkedlist + do while(associated(list_comp%next_emiscomp)) + list_comp => list_comp%next_emiscomp + end do + list_comp%next_emiscomp => new_emis_comp + else + shr_fire_emis_linkedlist => new_emis_comp + end if + + shr_fire_emis_comps_n = shr_fire_emis_comps_n + 1 + + end subroutine add_emis_comp_to_list + +endmodule shr_fire_emis_mod diff --git a/cesm/nuopc_cap_share/shr_megan_mod.F90 b/cesm/nuopc_cap_share/shr_megan_mod.F90 new file mode 100644 index 000000000..4273217c0 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_megan_mod.F90 @@ -0,0 +1,310 @@ +module shr_megan_mod + + !================================================================================ + ! Handles MEGAN VOC emissions metadata for CLM produced chemical emissions + ! MEGAN = Model of Emissions of Gases and Aerosols from Nature + ! + ! This reads the megan_emis_nl namelist in drv_flds_in and makes the relavent + ! information available to CAM, CLM, and driver. + ! - The driver sets up CLM to CAM communication for the VOC flux fields. + ! - CLM needs to know what specific VOC fluxes need to be passed to the coupler + ! and how to assemble the fluxes. + ! - CAM needs to know what specific VOC fluxes to expect from CLM. + !================================================================================ + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_kind_mod , only : r8 => shr_kind_r8, cl=>shr_kind_cl, cx=>shr_kind_cx, cs=>shr_kind_cs + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : logunit => shr_log_Unit + use shr_mpi_mod , only : shr_mpi_bcast + use shr_nl_mod , only : shr_nl_find_group_name + use shr_expr_parser_mod , only : shr_exp_parse, shr_exp_item_t, shr_exp_list_destroy + + implicit none + private + + public :: shr_megan_readnl ! reads megan_emis_nl namelist + public :: shr_megan_mechcomps ! points to an array of chemical compounds (in CAM-Chem mechanism) that have MEGAN emissions + public :: shr_megan_mechcomps_n ! number of unique compounds in the CAM chemical mechanism that have MEGAN emissions + public :: shr_megan_megcomps_n ! number of unique MEGAN compounds + public :: shr_megan_megcomp_t ! MEGAN compound data type + public :: shr_megan_mechcomp_t ! data type for chemical compound in CAM mechanism that has MEGAN emissions + public :: shr_megan_linkedlist ! points to linked list of shr_megan_comp_t objects + public :: shr_megan_mapped_emisfctrs ! switch to use mapped emission factors + public :: shr_megan_comp_ptr + + logical , public :: megan_initialized = .false. ! true => shr_megan_readnl alreay called + character(len=CL), public :: shr_megan_factors_file = '' + + ! MEGAN compound data structure (or user defined type) + type shr_megan_megcomp_t + character(len=16) :: name ! MEGAN compound name (in MEGAN input table) + integer :: index + real(r8), pointer :: emis_factors(:) ! function of plant-function-type (PFT) + integer :: class_number ! MEGAN class number + real(r8) :: coeff ! emissions component coeffecient + real(r8) :: molec_weight ! molecular weight of the MEGAN compound (g/mole) + type(shr_megan_megcomp_t), pointer :: next_megcomp ! points to next member in the linked list + endtype shr_megan_megcomp_t + + type shr_megan_comp_ptr + type(shr_megan_megcomp_t), pointer :: ptr + endtype shr_megan_comp_ptr + + ! chemical compound in CAM mechanism that has MEGAN emissions + type shr_megan_mechcomp_t + character(len=16) :: name ! compound name + type(shr_megan_comp_ptr), pointer :: megan_comps(:) ! an array of pointers to megan emis compounds + integer :: n_megan_comps ! number of megan emis compounds that make up the emissions for this mechanis compound + end type shr_megan_mechcomp_t + + type(shr_megan_mechcomp_t), pointer :: shr_megan_mechcomps(:) ! array of chemical compounds (in CAM mechanism) that have MEGAN emissions + type(shr_megan_megcomp_t), pointer :: shr_megan_linkedlist ! points to linked list top + + integer :: shr_megan_megcomps_n = 0 ! number of unique megan compounds + integer :: shr_megan_mechcomps_n = 0 ! number of unique compounds in the CAM chemical mechanism that have MEGAN emissions + + ! switch to use mapped emission factors + logical :: shr_megan_mapped_emisfctrs = .false. + +!-------------------------------------------------------- +contains +!-------------------------------------------------------- + + subroutine shr_megan_readnl( NLFileName, megan_nflds) + + !------------------------------------------------------------------------- + ! + ! This reads the megan_emis_nl namelist group in drv_flds_in and parses the + ! namelist information for the driver, CLM, and CAM. + ! + ! Namelist variables: + ! megan_specifier, megan_mapped_emisfctrs, megan_factors_file + ! + ! megan_specifier is a series of strings where each string contains one + ! CAM chemistry constituent name (left of = sign) and one or more MEGAN + ! compound (separated by + sign if more than one). Each MEGAN compound + ! can be proceeded by a multiplication factor (separated by *). The + ! specification of the MEGAN compounds to the right of the = signs tells + ! the MEGAN VOC model within CLM how to construct the VOC fluxes using + ! the factors in megan_factors_file and land surface state. + ! + ! megan_factors_file read by CLM contains valid MEGAN compound names, + ! MEGAN class groupings and scalar emission factors + ! + ! megan_mapped_emisfctrs switch is used to tell the MEGAN model to use + ! mapped emission factors read in from the CLM surface data input file + ! rather than the scalar factors from megan_factors_file + ! + ! Example: + ! &megan_emis_nl + ! megan_specifier = 'ISOP = isoprene', + ! 'C10H16 = myrcene + sabinene + limonene + carene_3 + ocimene_t_b + pinene_b + ...', + ! 'CH3OH = methanol', + ! 'C2H5OH = ethanol', + ! 'CH2O = formaldehyde', + ! 'CH3CHO = acetaldehyde', + ! ... + ! megan_factors_file = '$datapath/megan_emis_factors.nc' + ! / + !------------------------------------------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: NLFileName + integer, intent(out) :: megan_nflds + + ! local variables + type(ESMF_VM) :: vm + integer :: localPet + integer :: mpicom + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer, parameter :: maxspc = 100 + character(len=2*CX) :: megan_specifier(maxspc) = ' ' + logical :: megan_mapped_emisfctrs = .false. + character(len=CL) :: megan_factors_file = ' ' + integer :: rc + integer :: i, tmp(1) + character(*), parameter :: F00 = "('(shr_megan_readnl) ',2a)" + character(len=*), parameter :: subname='(shr_megan_readnl)' + !-------------------------------------------------------------- + + namelist /megan_emis_nl/ megan_specifier, megan_factors_file, megan_mapped_emisfctrs + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localPet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(logunit,F00) 'Read in megan_emis_readnl namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'megan_emis_nl', status=ierr) + if (ierr == 0) then + ! Note that ierr /= 0, no namelist is present. + read (unitn, megan_emis_nl, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort( 'problem on read of megan_emis_nl namelist in shr_megan_readnl' ) + endif + endif + close( unitn ) + end if + end if + call shr_mpi_bcast( megan_specifier , mpicom ) + call shr_mpi_bcast( megan_factors_file , mpicom ) + call shr_mpi_bcast( megan_mapped_emisfctrs , mpicom ) + + shr_megan_factors_file = megan_factors_file + shr_megan_mapped_emisfctrs = megan_mapped_emisfctrs + + ! parse the namelist info and initialize the module data - only if it has not been initialized + if (.not. megan_initialized) then + call shr_megan_init( megan_specifier ) + end if + megan_nflds = shr_megan_mechcomps_n + + end subroutine shr_megan_readnl + +!------------------------------------------------------------------------- +! private methods... +!------------------------------------------------------------------------- + + subroutine shr_megan_init( specifier) + + !----------------------------------------- + ! Initialize module data + !----------------------------------------- + + ! input/output variables + character(len=*), intent(in) :: specifier(:) + + ! local variables + integer :: n_entries + integer :: i, j, k + type(shr_exp_item_t), pointer :: items_list, item + !-------------------------------------------------------------- + + nullify(shr_megan_linkedlist) + + items_list => shr_exp_parse( specifier, nitems=n_entries ) + + allocate(shr_megan_mechcomps(n_entries)) + shr_megan_mechcomps(:)%n_megan_comps = 0 + + item => items_list + i = 1 + do while(associated(item)) + + do k=1,shr_megan_mechcomps_n + if ( trim(shr_megan_mechcomps(k)%name) == trim(item%name) ) then + call shr_sys_abort( 'shr_megan_init : duplicate compound names : '//trim(item%name)) + endif + enddo + if (len_trim(item%name) .le. len(shr_megan_mechcomps(i)%name)) then + shr_megan_mechcomps(i)%name = item%name(1:len(shr_megan_mechcomps(i)%name)) + else + call shr_sys_abort( 'shr_megan_init : name too long for data structure : '//trim(item%name)) + endif + shr_megan_mechcomps(i)%n_megan_comps = item%n_terms + allocate(shr_megan_mechcomps(i)%megan_comps(item%n_terms)) + + do j = 1,item%n_terms + shr_megan_mechcomps(i)%megan_comps(j)%ptr => add_megan_comp( item%vars(j), item%coeffs(j) ) + enddo + shr_megan_mechcomps_n = shr_megan_mechcomps_n+1 + + item => item%next_item + i = i+1 + + enddo + if (associated(items_list)) call shr_exp_list_destroy(items_list) + + megan_initialized = .true. + + end subroutine shr_megan_init + + !------------------------------------------------------------------------- + + function add_megan_comp( name, coeff ) result(megan_comp) + + character(len=16), intent(in) :: name + real(r8), intent(in) :: coeff + type(shr_megan_megcomp_t), pointer :: megan_comp + + megan_comp => get_megan_comp_by_name(shr_megan_linkedlist, name) + if(associated(megan_comp)) then + ! already in the list so return... + return + endif + + ! create new megan compound and add it to the list + allocate(megan_comp) + + ! element%index = lookup_element( name ) + ! element%emis_factors = get_factors( list_elem%index ) + + megan_comp%index = shr_megan_megcomps_n+1 + + megan_comp%name = trim(name) + megan_comp%coeff = coeff + nullify(megan_comp%next_megcomp) + + call add_megan_comp_to_list(megan_comp) + + end function add_megan_comp + + !------------------------------------------------------------------------- + + recursive function get_megan_comp_by_name(list_comp, name) result(megan_comp) + + type(shr_megan_megcomp_t), pointer :: list_comp + character(len=*), intent(in) :: name ! variable name + type(shr_megan_megcomp_t), pointer :: megan_comp ! returned object + + if(associated(list_comp)) then + if(list_comp%name .eq. name) then + megan_comp => list_comp + else + megan_comp => get_megan_comp_by_name(list_comp%next_megcomp, name) + end if + else + nullify(megan_comp) + end if + + end function get_megan_comp_by_name + + !------------------------------------------------------------------------- + + subroutine add_megan_comp_to_list( new_megan_comp ) + + type(shr_megan_megcomp_t), target, intent(in) :: new_megan_comp + + type(shr_megan_megcomp_t), pointer :: list_comp + + if(associated(shr_megan_linkedlist)) then + list_comp => shr_megan_linkedlist + do while(associated(list_comp%next_megcomp)) + list_comp => list_comp%next_megcomp + end do + list_comp%next_megcomp => new_megan_comp + else + shr_megan_linkedlist => new_megan_comp + end if + + shr_megan_megcomps_n = shr_megan_megcomps_n + 1 + + end subroutine add_megan_comp_to_list + +endmodule shr_megan_mod diff --git a/cesm/nuopc_cap_share/shr_ndep_mod.F90 b/cesm/nuopc_cap_share/shr_ndep_mod.F90 new file mode 100644 index 000000000..d3a9f9801 --- /dev/null +++ b/cesm/nuopc_cap_share/shr_ndep_mod.F90 @@ -0,0 +1,106 @@ +module shr_ndep_mod + + !======================================================================== + ! Module for handling nitrogen depostion of tracers. + ! This module is shared by land and atmosphere models for the computations of + ! dry deposition of tracers + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : s_logunit => shr_log_Unit + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_nl_mod , only : shr_nl_find_group_name + use shr_mpi_mod , only : shr_mpi_bcast + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS + public :: shr_ndep_readnl ! Read namelist + + character(len=*), parameter :: & + u_FILE_u=__FILE__ + +!==================================================================================== +CONTAINS +!==================================================================================== + + subroutine shr_ndep_readnl(NLFilename, ndep_nflds) + + !======================================================================== + ! reads ndep_inparm namelist and sets up driver list of fields for + ! atmosphere -> land and atmosphere -> ocn communications. + !======================================================================== + + ! input/output variables + character(len=*), intent(in) :: NLFilename ! Namelist filename + integer , intent(out) :: ndep_nflds + + !----- local ----- + type(ESMF_VM) :: vm + integer :: i ! Indices + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: rc + integer, parameter :: maxspc = 100 ! Maximum number of species + character(len=32) :: ndep_list(maxspc) = '' ! List of ndep species + integer :: localpet + integer :: mpicom + character(*),parameter :: F00 = "('(shr_ndep_read) ',8a)" + character(*),parameter :: FI1 = "('(shr_ndep_init) ',a,I2)" + character(*),parameter :: subName = '(shr_ndep_read) ' + ! ------------------------------------------------------------------ + + namelist /ndep_inparm/ ndep_list + + !----------------------------------------------------------------------------- + ! Read namelist and figure out the ndep field list to pass + ! First check if file exists and if not, n_ndep will be zero + !----------------------------------------------------------------------------- + + rc = ESMF_SUCCESS + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subName//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localPet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + ! Note the following still needs to be called on all processors since the mpi_bcast is a collective + ! call on all the pes of mpicom + if (localpet==0) then + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(s_logunit,F00) 'Read in ndep_inparm namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'ndep_inparm', ierr) + if (ierr == 0) then + ! Note that ierr /= 0, no namelist is present. + read(unitn, ndep_inparm, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort(trim(subName) //'problem of read of ndep_inparm ') + endif + endif + close( unitn ) + end if + end if + call shr_mpi_bcast( ndep_list, mpicom ) + + ndep_nflds = 0 + do i=1,maxspc + if (len_trim(ndep_list(i)) > 0) then + ndep_nflds = ndep_nflds+1 + endif + enddo + + end subroutine shr_ndep_readnl + +end module shr_ndep_mod diff --git a/cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 b/cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 new file mode 100644 index 000000000..fbd601c3c --- /dev/null +++ b/cesm/nuopc_cap_share/shr_ozone_coupling_mod.F90 @@ -0,0 +1,124 @@ +module shr_ozone_coupling_mod + + !======================================================================== + ! Module for handling namelist variables related to ozone coupling + !======================================================================== + + use ESMF , only : ESMF_VMGetCurrent, ESMF_VM, ESMF_VMGet + use ESMF , only : ESMF_LogFoundError, ESMF_LOGERR_PASSTHRU, ESMF_SUCCESS + use shr_sys_mod , only : shr_sys_abort + use shr_log_mod , only : s_logunit => shr_log_Unit + use shr_nl_mod , only : shr_nl_find_group_name + use shr_mpi_mod , only : shr_mpi_bcast + + implicit none + private + + ! !PUBLIC MEMBER FUNCTIONS + public shr_ozone_coupling_readnl ! Read namelist + + ! !PUBLIC DATA MEMBERS + ! atm_ozone_frequency can be one of the following values + integer, parameter, public :: atm_ozone_frequency_unset = 0 + integer, parameter, public :: atm_ozone_frequency_subdaily = 1 + integer, parameter, public :: atm_ozone_frequency_multiday_average = 2 + + character(len=*), parameter :: & + u_FILE_u=__FILE__ + + !==================================================================================== +CONTAINS + !==================================================================================== + + subroutine shr_ozone_coupling_readnl(NLFilename, atm_ozone_frequency_val) + + !======================================================================== + ! reads ozone_coupling_nl namelist and returns a variable specifying the frequency at + ! which the atmosphere model computes surface ozone + !======================================================================== + + ! input/output variables + character(len=*), intent(in) :: NLFilename ! Namelist filename + ! atm_ozone_frequency will be one of the above constants (atm_ozone_frequency_*), + ! specifying the frequency at which the atmosphere model computes surface ozone + integer , intent(out) :: atm_ozone_frequency_val + + !----- local ----- + character(len=64) :: atm_ozone_frequency + type(ESMF_VM) :: vm + integer :: unitn ! namelist unit number + integer :: ierr ! error code + logical :: exists ! if file exists or not + integer :: rc + integer :: localpet + integer :: mpicom + + character(len=*), parameter :: atm_ozone_frequency_not_present = 'NOT_PRESENT' + character(len=*), parameter :: subname = '(shr_ozone_coupling_readnl) ' + ! ------------------------------------------------------------------ + + namelist /ozone_coupling_nl/ atm_ozone_frequency + + rc = ESMF_SUCCESS + + !--- Open and read namelist --- + if ( len_trim(NLFilename) == 0 ) then + call shr_sys_abort( subname//'ERROR: nlfilename not set' ) + end if + + call ESMF_VMGetCurrent(vm, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_VMGet(vm, localPet=localpet, mpiCommunicator=mpicom, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if (localpet==0) then + ! ------------------------------------------------------------------------ + ! Set default values in case namelist file doesn't exist, ozone_coupling_nl group + ! doesn't exist within the file, or a given variable isn't present in the namelist + ! group in the file. + ! ------------------------------------------------------------------------ + atm_ozone_frequency = atm_ozone_frequency_not_present + + ! ------------------------------------------------------------------------ + ! Read namelist file + ! ------------------------------------------------------------------------ + inquire( file=trim(NLFileName), exist=exists) + if ( exists ) then + open(newunit=unitn, file=trim(NLFilename), status='old' ) + write(s_logunit,'(a)') '(shr_ozone_coupling_readnl) Read in ozone_coupling_nl namelist from: ', trim(NLFilename) + call shr_nl_find_group_name(unitn, 'ozone_coupling_nl', ierr) + if (ierr == 0) then + ! Note that ierr /= 0 means no namelist is present. + read(unitn, ozone_coupling_nl, iostat=ierr) + if (ierr > 0) then + call shr_sys_abort(trim(subname)//'problem reading ozone_coupling_nl ') + end if + end if + close( unitn ) + end if + + ! ------------------------------------------------------------------------ + ! Translate read-in values to appropriate return values + ! ------------------------------------------------------------------------ + select case(atm_ozone_frequency) + case(atm_ozone_frequency_not_present) + atm_ozone_frequency_val = atm_ozone_frequency_unset + case("subdaily") + atm_ozone_frequency_val = atm_ozone_frequency_subdaily + case("multiday_average") + atm_ozone_frequency_val = atm_ozone_frequency_multiday_average + case default + call shr_sys_abort(trim(subname)//'unknown value for atm_ozone_frequency: '// & + trim(atm_ozone_frequency)) + end select + end if + + ! ------------------------------------------------------------------------ + ! Broadcast values to all processors + ! ------------------------------------------------------------------------ + call shr_mpi_bcast(atm_ozone_frequency_val, mpicom) + + end subroutine shr_ozone_coupling_readnl + +end module shr_ozone_coupling_mod diff --git a/cime_config/buildexe b/cime_config/buildexe index e76fc7344..f02d0a399 100755 --- a/cime_config/buildexe +++ b/cime_config/buildexe @@ -90,7 +90,8 @@ def _main_func(): out.write(os.path.join(caseroot, "SourceMods", "src.drv") + "\n") if not skip_mediator: out.write(os.path.join(cmeps_dir, "mediator") + "\n") - out.write(os.path.join(cmeps_dir, "drivers", "cime") + "\n") + out.write(os.path.join(cmeps_dir, "cesm", "flux_atmocn") + "\n") + out.write(os.path.join(cmeps_dir, "cesm", "driver") + "\n") # build model executable makefile = os.path.join(casetools, "Makefile") diff --git a/cime_config/buildnml b/cime_config/buildnml index f8a43852b..11c20e276 100755 --- a/cime_config/buildnml +++ b/cime_config/buildnml @@ -33,7 +33,6 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): config['iyear'] = case.get_value('COMPSET').split('_')[0] config['BGC_MODE'] = case.get_value("CCSM_BGC") config['CPL_I2O_PER_CAT'] = case.get_value('CPL_I2O_PER_CAT') - config['COMP_RUN_BARRIERS'] = case.get_value('COMP_RUN_BARRIERS') config['DRV_THREADING'] = case.get_value('DRV_THREADING') config['CPL_ALBAV'] = case.get_value('CPL_ALBAV') config['CPL_EPBAL'] = case.get_value('CPL_EPBAL') @@ -44,11 +43,11 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files): config['OS'] = case.get_value('OS') config['glc_nec'] = 0 if case.get_value('GLC_NEC') == 0 else case.get_value('GLC_NEC') config['timer_level'] = 'pos' if case.get_value('TIMER_LEVEL') >= 1 else 'neg' - config['bfbflag'] = 'on' if case.get_value('BFBFLAG') else 'off' config['continue_run'] = '.true.' if case.get_value('CONTINUE_RUN') else '.false.' config['flux_epbal'] = 'ocn' if case.get_value('CPL_EPBAL') == 'ocn' else 'off' config['mask_grid'] = case.get_value('MASK_GRID') config['rest_option'] = case.get_value('REST_OPTION') + config['comp_ocn'] = case.get_value('COMP_OCN') atm_grid = case.get_value('ATM_GRID') lnd_grid = case.get_value('LND_GRID') diff --git a/cime_config/namelist_definition_drv.xml b/cime_config/namelist_definition_drv.xml index e909eaf9b..a38cfed1c 100644 --- a/cime_config/namelist_definition_drv.xml +++ b/cime_config/namelist_definition_drv.xml @@ -919,6 +919,21 @@ + + char + budget + MED_attributes + v0,v1 + + currently v0 refers to budgets using POP and v1 refers to budgets using MOM6 + + + v0 + v1 + v0 + + + integer budget @@ -2250,18 +2265,6 @@ - - integer - expdef - ALLCOMP_attributes - - number of glc ice sheets - - - 1 - - - logical flds @@ -2319,7 +2322,7 @@ ALLCOMP_attributes If set to .true. BGC fields will be passed back and forth between the ocean and seaice - via the coupler. + via the mediator. .false. @@ -3895,7 +3898,7 @@ char mapping - GLC_attributes + ALLCOMP_attributes MESH description of glc grid diff --git a/mediator/CMakeLists.txt b/mediator/CMakeLists.txt index 5ee25a5cb..a851018ba 100644 --- a/mediator/CMakeLists.txt +++ b/mediator/CMakeLists.txt @@ -32,7 +32,7 @@ if(BLD_STANDALONE) endif() target_include_directories (cmeps PUBLIC ${ESMF_F90COMPILEPATHS}) -target_include_directories (cmeps PUBLIC "${CMAKE_BINARY_DIR}/util") +target_include_directories (cmeps PUBLIC "${CMAKE_BINARY_DIR}/ufs") target_include_directories (cmeps PUBLIC ${PIO_Fortran_INCLUDE_DIR}) install(TARGETS cmeps diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90 index e853d7073..2bb45a90d 100644 --- a/mediator/esmFldsExchange_cesm_mod.F90 +++ b/mediator/esmFldsExchange_cesm_mod.F90 @@ -77,7 +77,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) use esmflds , only : compmed, compatm, complnd, compocn use esmflds , only : compice, comprof, compwav, ncomps use esmflds , only : compglc, num_icesheets, ocn2glc_coupling ! compglc is an array of integers - use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d + use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapbilnr_nstod use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf use esmflds , only : map_glc2ocn_ice, map_glc2ocn_liq, map_rof2ocn_ice, map_rof2ocn_liq use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb @@ -2228,7 +2228,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_lamult', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_lamult', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_lamult', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_lamult', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_lamult', mrg_from=compwav, mrg_fld='Sw_lamult', mrg_type='copy') end if end if @@ -2241,7 +2241,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_ustokes', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_ustokes', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_ustokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_ustokes', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_ustokes', mrg_from=compwav, mrg_fld='Sw_ustokes', mrg_type='copy') end if end if @@ -2254,7 +2254,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_vstokes', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_vstokes', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_vstokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_vstokes', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_vstokes', mrg_from=compwav, mrg_fld='Sw_vstokes', mrg_type='copy') end if end if @@ -2267,10 +2267,36 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc) else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_hstokes', rc=rc) .and. & fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_hstokes', rc=rc)) then - call addmap(fldListFr(compwav)%flds, 'Sw_hstokes', compocn, mapbilnr, 'one', wav2ocn_smap) + call addmap(fldListFr(compwav)%flds, 'Sw_hstokes', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) call addmrg(fldListTo(compocn)%flds, 'Sw_hstokes', mrg_from=compwav, mrg_fld='Sw_hstokes', mrg_type='copy') end if end if + !----------------------------- + ! to ocn: Partitioned stokes drift components in x-direction + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_pstokes_x') + call addfld(fldListTo(compocn)%flds, 'Sw_pstokes_x') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_pstokes_x', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_pstokes_x', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_pstokes_x', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_pstokes_x', mrg_from=compwav, mrg_fld='Sw_pstokes_x', mrg_type='copy') + end if + end if + !----------------------------- + ! to ocn: Stokes drift depth from wave + !----------------------------- + if (phase == 'advertise') then + call addfld(fldListFr(compwav)%flds, 'Sw_pstokes_y') + call addfld(fldListTo(compocn)%flds, 'Sw_pstokes_y') + else + if ( fldchk(is_local%wrap%FBExp(compocn) , 'Sw_pstokes_y', rc=rc) .and. & + fldchk(is_local%wrap%FBImp(compwav, compwav), 'Sw_pstokes_y', rc=rc)) then + call addmap(fldListFr(compwav)%flds, 'Sw_pstokes_y', compocn, mapbilnr_nstod, 'one', wav2ocn_smap) + call addmrg(fldListTo(compocn)%flds, 'Sw_pstokes_y', mrg_from=compwav, mrg_fld='Sw_pstokes_y', mrg_type='copy') + end if + end if !===================================================================== ! FIELDS TO ICE (compice) diff --git a/mediator/fd_cesm.yaml b/mediator/fd_cesm.yaml index b4a407a06..55da80619 100644 --- a/mediator/fd_cesm.yaml +++ b/mediator/fd_cesm.yaml @@ -1117,6 +1117,13 @@ canonical_units: m/s description: ocean import - Stokes drift v component # + - standard_name: Sw_pstokes_x + canonical_units: m/s + description: Eastward partitioned stokes drift components + # + - standard_name: Sw_pstokes_y + canonical_units: m/s + description: Northward partitioned stokes drift components #----------------------------------- # mediator fields #----------------------------------- diff --git a/mediator/med.F90 b/mediator/med.F90 index 7f2b323af..8e8c4fdf1 100644 --- a/mediator/med.F90 +++ b/mediator/med.F90 @@ -654,9 +654,9 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) ! TransferOfferGeomObject Attribute. use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Clock, ESMF_SUCCESS, ESMF_LogFoundAllocError - use ESMF , only : ESMF_StateIsCreated + use ESMF , only : ESMF_StateIsCreated use ESMF , only : ESMF_LogMsg_Info, ESMF_LogWrite - use ESMF , only : ESMF_END_ABORT, ESMF_Finalize + use ESMF , only : ESMF_END_ABORT, ESMF_Finalize, ESMF_MAXSTR use NUOPC , only : NUOPC_AddNamespace, NUOPC_Advertise, NUOPC_AddNestedState use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd @@ -676,6 +676,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) type(InternalState) :: is_local integer :: stat character(len=CS) :: attrList(8) + character(len=ESMF_MAXSTR) :: mesh_glc character(len=*),parameter :: subname=' (InitializeIPDv03p1) ' !----------------------------------------------------------- @@ -735,13 +736,20 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc) nestedState=is_local%wrap%NStateExp(compwav), rc=rc) ! Only create nested states for active ice sheets - call NUOPC_CompAttributeGet(gcomp, name='num_icesheets', value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='mesh_glc', value=mesh_glc, isPresent=isPresent, isSet=isSet, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + num_icesheets = 0 if (isPresent .and. isSet) then - read(cvalue,*) num_icesheets - else - num_icesheets = 0 + ! determine number of ice sheets - search in mesh_glc for colon deliminted strings + if (len_trim(cvalue) > 0) then + do n = 1, len_trim(mesh_glc) + if (mesh_glc(n:n) == ':') num_icesheets = num_icesheets + 1 + end do + num_icesheets = num_icesheets + 1 + endif + if (mastertask) then + write(logunit,'(a,i8)') trim(subname)//' number of ice sheets is ',num_icesheets + end if end if do ns = 1,num_icesheets write(cnum,'(i0)') ns diff --git a/mediator/med_constants_mod.F90 b/mediator/med_constants_mod.F90 index 4cc96f4f7..7313a9be9 100644 --- a/mediator/med_constants_mod.F90 +++ b/mediator/med_constants_mod.F90 @@ -1,6 +1,11 @@ module med_constants_mod use med_kind_mod, only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 +#ifdef CESMCOUPLED + use shr_const_mod +#else + use ufs_const_mod +#endif implicit none public diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90 index c8bb304e4..8f15f625e 100644 --- a/mediator/med_diag_mod.F90 +++ b/mediator/med_diag_mod.F90 @@ -24,13 +24,14 @@ module med_diag_mod use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_ClockGetNextTime use ESMF , only : ESMF_Alarm, ESMF_ClockGetAlarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff use ESMF , only : ESMF_FieldBundle, ESMF_Field, ESMF_FieldGet - use shr_const_mod , only : shr_const_rearth, shr_const_pi, shr_const_latice - use shr_const_mod , only : shr_const_ice_ref_sal, shr_const_ocn_ref_sal, shr_const_isspval + use med_constants_mod , only : shr_const_rearth, shr_const_pi, shr_const_latice, shr_const_latvap + use med_constants_mod , only : shr_const_ice_ref_sal, shr_const_ocn_ref_sal, shr_const_isspval use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use med_internalstate_mod , only : InternalState, logunit, mastertask, diagunit use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d use med_methods_mod , only : fldbun_fldChk => med_methods_FB_FldChk + use med_time_mod , only : alarmInit => med_time_alarmInit use med_utils_mod , only : chkerr => med_utils_ChkErr use perf_mod , only : t_startf, t_stopf @@ -130,58 +131,60 @@ module med_diag_mod ! --------------------------------- ! F for field ! --------------------------------- - - integer :: f_area ! area (wrt to unit sphere) - integer :: f_heat_frz ! heat : latent, freezing - integer :: f_heat_melt ! heat : latent, melting - integer :: f_heat_swnet ! heat : short wave, net - integer :: f_heat_lwdn ! heat : longwave down - integer :: f_heat_lwup ! heat : longwave up - integer :: f_heat_latvap ! heat : latent, vaporization - integer :: f_heat_latf ! heat : latent, fusion, snow - integer :: f_heat_ioff ! heat : latent, fusion, frozen runoff - integer :: f_heat_sen ! heat : sensible - integer :: f_watr_frz ! water: freezing - integer :: f_watr_melt ! water: melting - integer :: f_watr_rain ! water: precip, liquid - integer :: f_watr_snow ! water: precip, frozen - integer :: f_watr_evap ! water: evaporation - integer :: f_watr_salt ! water: water equivalent of salt flux - integer :: f_watr_roff ! water: runoff/flood - integer :: f_watr_ioff ! water: frozen runoff - integer :: f_watr_frz_16O ! water isotope: freezing - integer :: f_watr_melt_16O ! water isotope: melting - integer :: f_watr_rain_16O ! water isotope: precip, liquid - integer :: f_watr_snow_16O ! water isotope: prcip, frozen - integer :: f_watr_evap_16O ! water isotope: evaporation - integer :: f_watr_roff_16O ! water isotope: runoff/flood - integer :: f_watr_ioff_16O ! water isotope: frozen runoff - integer :: f_watr_frz_18O ! water isotope: freezing - integer :: f_watr_melt_18O ! water isotope: melting - integer :: f_watr_rain_18O ! water isotope: precip, liquid - integer :: f_watr_snow_18O ! water isotope: precip, frozen - integer :: f_watr_evap_18O ! water isotope: evaporation - integer :: f_watr_roff_18O ! water isotope: runoff/flood - integer :: f_watr_ioff_18O ! water isotope: frozen runoff - integer :: f_watr_frz_HDO ! water isotope: freezing - integer :: f_watr_melt_HDO ! water isotope: melting - integer :: f_watr_rain_HDO ! water isotope: precip, liquid - integer :: f_watr_snow_HDO ! water isotope: precip, frozen - integer :: f_watr_evap_HDO ! water isotope: evaporation - integer :: f_watr_roff_HDO ! water isotope: runoff/flood - integer :: f_watr_ioff_HDO ! water isotope: frozen runoff - - integer :: f_heat_beg ! 1st index for heat - integer :: f_heat_end ! Last index for heat - integer :: f_watr_beg ! 1st index for water - integer :: f_watr_end ! Last index for water - - integer :: f_16O_beg ! 1st index for 16O water isotope - integer :: f_16O_end ! Last index for 16O water isotope - integer :: f_18O_beg ! 1st index for 18O water isotope - integer :: f_18O_end ! Last index for 18O water isotope - integer :: f_HDO_beg ! 1st index for HDO water isotope - integer :: f_HDO_end ! Last index for HDO water isotope + integer, parameter :: unset_index = -999 + integer :: f_area = unset_index ! area (wrt to unit sphere) + integer :: f_heat_frz = unset_index ! heat : latent, freezing + integer :: f_heat_melt = unset_index ! heat : latent, melting + integer :: f_heat_swnet = unset_index ! heat : short wave, net + integer :: f_heat_lwdn = unset_index ! heat : longwave down + integer :: f_heat_lwup = unset_index ! heat : longwave up + integer :: f_heat_latvap = unset_index ! heat : latent, vaporization + integer :: f_heat_latf = unset_index ! heat : latent, fusion, snow + integer :: f_heat_ioff = unset_index ! heat : latent, fusion, frozen runoff + integer :: f_heat_sen = unset_index ! heat : sensible + integer :: f_watr_frz = unset_index ! water: freezing + integer :: f_watr_melt = unset_index ! water: melting + integer :: f_watr_rain = unset_index ! water: precip, liquid + integer :: f_watr_snow = unset_index ! water: precip, frozen + integer :: f_watr_evap = unset_index ! water: evaporation + integer :: f_watr_salt = unset_index ! water: water equivalent of salt flux + integer :: f_watr_roff = unset_index ! water: runoff/flood + integer :: f_watr_ioff = unset_index ! water: frozen runoff + integer :: f_watr_frz_16O = unset_index ! water isotope: freezing + integer :: f_watr_melt_16O = unset_index ! water isotope: melting + integer :: f_watr_rain_16O = unset_index ! water isotope: precip, liquid + integer :: f_watr_snow_16O = unset_index ! water isotope: prcip, frozen + integer :: f_watr_evap_16O = unset_index ! water isotope: evaporation + integer :: f_watr_roff_16O = unset_index ! water isotope: runoff/flood + integer :: f_watr_ioff_16O = unset_index ! water isotope: frozen runoff + integer :: f_watr_frz_18O = unset_index ! water isotope: freezing + integer :: f_watr_melt_18O = unset_index ! water isotope: melting + integer :: f_watr_rain_18O = unset_index ! water isotope: precip, liquid + integer :: f_watr_snow_18O = unset_index ! water isotope: precip, frozen + integer :: f_watr_evap_18O = unset_index ! water isotope: evaporation + integer :: f_watr_roff_18O = unset_index ! water isotope: runoff/flood + integer :: f_watr_ioff_18O = unset_index ! water isotope: frozen runoff + integer :: f_watr_frz_HDO = unset_index ! water isotope: freezing + integer :: f_watr_melt_HDO = unset_index ! water isotope: melting + integer :: f_watr_rain_HDO = unset_index ! water isotope: precip, liquid + integer :: f_watr_snow_HDO = unset_index ! water isotope: precip, frozen + integer :: f_watr_evap_HDO = unset_index ! water isotope: evaporation + integer :: f_watr_roff_HDO = unset_index ! water isotope: runoff/flood + integer :: f_watr_ioff_HDO = unset_index ! water isotope: frozen runoff + + integer :: f_heat_beg = unset_index ! 1st index for heat + integer :: f_heat_end = unset_index ! Last index for heat + integer :: f_watr_beg = unset_index ! 1st index for water + integer :: f_watr_end = unset_index ! Last index for water + integer :: f_salt_beg = unset_index ! 1st index for salt + integer :: f_salt_end = unset_index ! Last index for salt + + integer :: f_16O_beg = unset_index ! 1st index for 16O water isotope + integer :: f_16O_end = unset_index ! Last index for 16O water isotope + integer :: f_18O_beg = unset_index ! 1st index for 18O water isotope + integer :: f_18O_end = unset_index ! Last index for 18O water isotope + integer :: f_HDO_beg = unset_index ! 1st index for HDO water isotope + integer :: f_HDO_end = unset_index ! Last index for HDO water isotope ! --------------------------------- ! water isotopes names and indices @@ -232,6 +235,8 @@ module med_diag_mod character(len=*), parameter :: u_FILE_u = & __FILE__ + character(len=CS) :: budget_table_version + !=============================================================================== contains !=============================================================================== @@ -252,15 +257,24 @@ subroutine med_diag_init(gcomp, rc) integer :: f_size ! number of fields integer :: p_size ! number of period types type(ESMF_Clock) :: mediatorClock - character(CS) :: stop_option - integer :: stop_n ! Number until restart interval - integer :: stop_ymd ! Restart date (YYYYMMDD) - type(ESMF_ALARM) :: stop_alarm character(CS) :: cvalue + logical :: isPresent, isSet + character(*), parameter :: subName = '(med_phases_diag_init) ' ! ------------------------------------------------------------------ rc = ESMF_SUCCESS + call NUOPC_CompAttributeGet(gcomp, name="budget_table_version", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (isPresent .and. isSet) then + read(cvalue,*) budget_table_version + else + budget_table_version = 'v1' + end if + if (mastertask) then + write(logunit,'(a)') trim(subname) //' budget table version is '//trim(budget_table_version) + end if + call add_to_budget_diag(budget_diags%comps, c_atm_send , 'c2a_atm' ) ! comp index: atm call add_to_budget_diag(budget_diags%comps, c_atm_recv , 'a2c_atm' ) ! comp index: atm call add_to_budget_diag(budget_diags%comps, c_inh_send , 'c2i_inh' ) ! comp index: ice, northern @@ -286,6 +300,10 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_area ,'area' ) ! field area (wrt to unit sphere) + ! ----------------------------------------- + ! Heat fluxes budget terms + ! ----------------------------------------- + ! Note that this order is important here to determine f_heat_beg and f_heat_end call add_to_budget_diag(budget_diags%fields, f_heat_frz ,'hfreeze' ) ! field heat : latent, freezing call add_to_budget_diag(budget_diags%fields, f_heat_melt ,'hmelt' ) ! field heat : latent, melting @@ -296,55 +314,79 @@ subroutine med_diag_init(gcomp, rc) call add_to_budget_diag(budget_diags%fields, f_heat_latf ,'hlatfus' ) ! field heat : latent, fusion, snow call add_to_budget_diag(budget_diags%fields, f_heat_ioff ,'hiroff' ) ! field heat : latent, fusion, frozen runoff call add_to_budget_diag(budget_diags%fields, f_heat_sen ,'hsen' ) ! field heat : sensible + f_heat_beg = f_heat_frz ! field first index for heat + f_heat_end = f_heat_sen ! field last index for heat + + ! ----------------------------------------- + ! Water fluxes budget terms + ! ----------------------------------------- ! Note that this order is important here to determine f_watr_beg and f_watr_end - call add_to_budget_diag(budget_diags%fields, f_watr_frz ,'wfreeze' ) ! field water: freezing + if (trim(budget_table_version) == 'v0') then + call add_to_budget_diag(budget_diags%fields, f_watr_frz ,'wfreeze' ) ! field water: freezing + end if call add_to_budget_diag(budget_diags%fields, f_watr_melt ,'wmelt' ) ! field water: melting call add_to_budget_diag(budget_diags%fields, f_watr_rain ,'wrain' ) ! field water: precip, liquid call add_to_budget_diag(budget_diags%fields, f_watr_snow ,'wsnow' ) ! field water: precip, frozen call add_to_budget_diag(budget_diags%fields, f_watr_evap ,'wevap' ) ! field water: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'weqsaltf' ) ! field water: water equivalent of salt flux + if (trim(budget_table_version) == 'v0') then + call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'weqsaltf' ) ! field water: water equivalent of salt flux + endif call add_to_budget_diag(budget_diags%fields, f_watr_roff ,'wrunoff' ) ! field water: runoff/flood call add_to_budget_diag(budget_diags%fields, f_watr_ioff ,'wfrzrof' ) ! field water: frozen runoff + if (trim(budget_table_version) == 'v0') then + f_watr_beg = f_watr_frz ! field firs index for water + else + f_watr_beg = f_watr_melt ! field firs index for water + end if + f_watr_end = f_watr_ioff ! field last index for water + + if (flds_wiso) then + call add_to_budget_diag(budget_diags%fields, f_watr_frz_16O ,'wfreeze_16O' ) ! field water isotope: freezing + call add_to_budget_diag(budget_diags%fields, f_watr_melt_16O ,'wmelt_16O' ) ! field water isotope: melting + call add_to_budget_diag(budget_diags%fields, f_watr_rain_16O ,'wrain_16O' ) ! field water isotope: precip, liquid + call add_to_budget_diag(budget_diags%fields, f_watr_snow_16O ,'wsnow_16O' ) ! field water isotope: prcip, frozen + call add_to_budget_diag(budget_diags%fields, f_watr_evap_16O ,'wevap_16O' ) ! field water isotope: evaporation + call add_to_budget_diag(budget_diags%fields, f_watr_roff_16O ,'wrunoff_16O' ) ! field water isotope: runoff/flood + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_16O ,'wfrzrof_16O' ) ! field water isotope: frozen runoff + f_16O_beg = f_watr_frz_16O ! field 1st index for 16O water isotope + f_16O_end = f_watr_ioff_16O ! field Last index for 16O water isotope + + call add_to_budget_diag(budget_diags%fields, f_watr_frz_18O ,'wfreeze_18O' ) ! field water isotope: freezing + call add_to_budget_diag(budget_diags%fields, f_watr_melt_18O ,'wmelt_18O' ) ! field water isotope: melting + call add_to_budget_diag(budget_diags%fields, f_watr_rain_18O ,'wrain_18O' ) ! field water isotope: precip, liquid + call add_to_budget_diag(budget_diags%fields, f_watr_snow_18O ,'wsnow_18O' ) ! field water isotope: precip, frozen + call add_to_budget_diag(budget_diags%fields, f_watr_evap_18O ,'wevap_18O' ) ! field water isotope: evaporation + call add_to_budget_diag(budget_diags%fields, f_watr_roff_18O ,'wrunoff_18O' ) ! field water isotope: runoff/flood + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_18O ,'wfrzrof_18O' ) ! field water isotope: frozen runoff + f_18O_beg = f_watr_frz_18O ! field 1st index for 18O water isotope + f_18O_end = f_watr_ioff_18O ! field Last index for 18O water isotope + + call add_to_budget_diag(budget_diags%fields, f_watr_frz_HDO ,'wfreeze_HDO' ) ! field water isotope: freezing + call add_to_budget_diag(budget_diags%fields, f_watr_melt_HDO ,'wmelt_HDO' ) ! field water isotope: melting + call add_to_budget_diag(budget_diags%fields, f_watr_rain_HDO ,'wrain_HDO' ) ! field water isotope: precip, liquid + call add_to_budget_diag(budget_diags%fields, f_watr_snow_HDO ,'wsnow_HDO' ) ! field water isotope: precip, frozen + call add_to_budget_diag(budget_diags%fields, f_watr_evap_HDO ,'wevap_HDO' ) ! field water isotope: evaporation + call add_to_budget_diag(budget_diags%fields, f_watr_roff_HDO ,'wrunoff_HDO' ) ! field water isotope: runoff/flood + call add_to_budget_diag(budget_diags%fields, f_watr_ioff_HDO ,'wfrzrof_HDO' ) ! field water isotope: frozen runoff + f_HDO_beg = f_watr_frz_HDO ! field 1st index for HDO water isotope + f_HDO_end = f_watr_ioff_HDO ! field Last index for HDO water isotope + + ! water isotopes + iso0(:) = (/ f_16O_beg, f_18O_beg, f_hdO_beg /) + isof(:) = (/ f_16O_end, f_18O_end, f_hdO_end /) + isoname(:) = (/ 'H216O', 'H218O', ' HDO' /) + end if - call add_to_budget_diag(budget_diags%fields, f_watr_frz_16O ,'wfreeze_16O' ) ! field water isotope: freezing - call add_to_budget_diag(budget_diags%fields, f_watr_melt_16O ,'wmelt_16O' ) ! field water isotope: melting - call add_to_budget_diag(budget_diags%fields, f_watr_rain_16O ,'wrain_16O' ) ! field water isotope: precip, liquid - call add_to_budget_diag(budget_diags%fields, f_watr_snow_16O ,'wsnow_16O' ) ! field water isotope: prcip, frozen - call add_to_budget_diag(budget_diags%fields, f_watr_evap_16O ,'wevap_16O' ) ! field water isotope: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_roff_16O ,'wrunoff_16O' ) ! field water isotope: runoff/flood - call add_to_budget_diag(budget_diags%fields, f_watr_ioff_16O ,'wfrzrof_16O' ) ! field water isotope: frozen runoff - call add_to_budget_diag(budget_diags%fields, f_watr_frz_18O ,'wfreeze_18O' ) ! field water isotope: freezing - call add_to_budget_diag(budget_diags%fields, f_watr_melt_18O ,'wmelt_18O' ) ! field water isotope: melting - call add_to_budget_diag(budget_diags%fields, f_watr_rain_18O ,'wrain_18O' ) ! field water isotope: precip, liquid - call add_to_budget_diag(budget_diags%fields, f_watr_snow_18O ,'wsnow_18O' ) ! field water isotope: precip, frozen - call add_to_budget_diag(budget_diags%fields, f_watr_evap_18O ,'wevap_18O' ) ! field water isotope: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_roff_18O ,'wrunoff_18O' ) ! field water isotope: runoff/flood - call add_to_budget_diag(budget_diags%fields, f_watr_ioff_18O ,'wfrzrof_18O' ) ! field water isotope: frozen runoff - call add_to_budget_diag(budget_diags%fields, f_watr_frz_HDO ,'wfreeze_HDO' ) ! field water isotope: freezing - call add_to_budget_diag(budget_diags%fields, f_watr_melt_HDO ,'wmelt_HDO' ) ! field water isotope: melting - call add_to_budget_diag(budget_diags%fields, f_watr_rain_HDO ,'wrain_HDO' ) ! field water isotope: precip, liquid - call add_to_budget_diag(budget_diags%fields, f_watr_snow_HDO ,'wsnow_HDO' ) ! field water isotope: precip, frozen - call add_to_budget_diag(budget_diags%fields, f_watr_evap_HDO ,'wevap_HDO' ) ! field water isotope: evaporation - call add_to_budget_diag(budget_diags%fields, f_watr_roff_HDO ,'wrunoff_HDO' ) ! field water isotope: runoff/flood - call add_to_budget_diag(budget_diags%fields, f_watr_ioff_HDO ,'wfrzrof_HDO' ) ! field water isotope: frozen runoff - - f_heat_beg = f_heat_frz ! field first index for heat - f_heat_end = f_heat_sen ! field last index for heat - f_watr_beg = f_watr_frz ! field firs index for water - f_watr_end = f_watr_ioff ! field last index for water - - f_16O_beg = f_watr_frz_16O ! field 1st index for 16O water isotope - f_16O_end = f_watr_ioff_16O ! field Last index for 16O water isotope - f_18O_beg = f_watr_frz_18O ! field 1st index for 18O water isotope - f_18O_end = f_watr_ioff_18O ! field Last index for 18O water isotope - f_HDO_beg = f_watr_frz_HDO ! field 1st index for HDO water isotope - f_HDO_end = f_watr_ioff_HDO ! field Last index for HDO water isotope + ! ----------------------------------------- + ! Salt fluxes budget terms (for v1 only) + ! ----------------------------------------- - ! water isotopes - iso0(:) = (/ f_16O_beg, f_18O_beg, f_hdO_beg /) - isof(:) = (/ f_16O_end, f_18O_end, f_hdO_end /) - isoname(:) = (/ 'H216O', 'H218O', ' HDO' /) + if (trim(budget_table_version) == 'v1') then + call add_to_budget_diag(budget_diags%fields, f_watr_salt ,'saltf') ! field water: salt flux + f_salt_beg = f_watr_salt + f_salt_end = f_watr_salt + endif !------------------------------------------------------------------------------- ! Get config variables @@ -356,18 +398,18 @@ subroutine med_diag_init(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return budget_print_month = get_diag_attribute(gcomp, 'budget_month', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - budget_print_ann = get_diag_attribute(gcomp, 'budget_ann', rc) + budget_print_ann = get_diag_attribute(gcomp, 'budget_ann', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - budget_print_ltann = get_diag_attribute(gcomp, 'budget_ltann', rc) + budget_print_ltann = get_diag_attribute(gcomp, 'budget_ltann', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - budget_print_ltend = get_diag_attribute(gcomp, 'budget_ltend', rc) + budget_print_ltend = get_diag_attribute(gcomp, 'budget_ltend', rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! period types call add_to_budget_diag(budget_diags%periods, period_inst,' inst') if(budget_print_daily > 0) call add_to_budget_diag(budget_diags%periods, period_day ,' daily') if(budget_print_month > 0) call add_to_budget_diag(budget_diags%periods, period_mon ,' monthly') - if(budget_print_ann > 0) call add_to_budget_diag(budget_diags%periods, period_ann ,' annual') + if(budget_print_ann > 0) call add_to_budget_diag(budget_diags%periods, period_ann ,' annual') call add_to_budget_diag(budget_diags%periods, period_inf ,'all_time') ! allocate module budget arrays @@ -653,12 +695,14 @@ subroutine med_phases_diag_atm(gcomp, rc) areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (flds_wiso) then + call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_atm_wiso_recv(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if ! heat implied by snow flux from atm to mediator budget_local(f_heat_latf,c_atm_recv ,ip) = -budget_local(f_watr_snow,c_atm_recv ,ip)*shr_const_latice @@ -698,9 +742,12 @@ subroutine med_phases_diag_atm(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! water isotopes - call diag_atm_wiso_send(is_local%wrap%FBImp(compatm,compatm), 'Faxa_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, & - areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_atm_wiso_send(is_local%wrap%FBImp(compatm,compatm), 'Faxa_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, & + areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if deallocate(afrac) call t_stopf('MED:'//subname) @@ -938,28 +985,43 @@ subroutine med_phases_diag_lnd( gcomp, rc) end do call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_swnet', f_heat_swnet , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_lwup' , f_heat_lwup , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_lat' , f_heat_latvap , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_sen' , f_heat_sen , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_evap' , f_watr_evap , ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsur', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofgwl', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsub', f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_irrig' , f_watr_roff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi' , f_watr_ioff, ic,& areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofl_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi_wiso', & - f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofl_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi_wiso', & + f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -974,22 +1036,34 @@ subroutine med_phases_diag_lnd( gcomp, rc) budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*lfrac(n) end do call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_lwdn' , f_heat_lwdn, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_rainc', f_watr_rain, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_rainl', f_watr_rain, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_snowc', f_watr_snow, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_snowl', f_watr_snow, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_lnd(is_local%wrap%FBExp(complnd), 'Flrl_flood', f_watr_roff, ic, areas, lfrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainc_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainl_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowc_wiso', & - f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowl_wiso', & - f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) - call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Flrl_flood_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, minus=.true., rc=rc) + if (flds_wiso) then + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainc_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_rainl_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowc_wiso', & + f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Faxa_snowl_wiso', & + f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, ic, areas, lfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_lnd_wiso(is_local%wrap%FBExp(complnd), 'Flrl_flood_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, lfrac, budget_local, minus=.true., rc=rc) + end if budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice @@ -1103,16 +1177,25 @@ subroutine med_phases_diag_rof( gcomp, rc) ip = period_inst call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Flrr_flood', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofl' , f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofi' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Firr_rofi' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_flood_wiso', & - f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc) - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofl_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, minus=.true., rc=rc) - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofi_wiso', & - f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, minus=.true., rc=rc) + if (flds_wiso) then + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_flood_wiso', & + f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofl_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Forr_rofi_wiso', & + f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1124,15 +1207,24 @@ subroutine med_phases_diag_rof( gcomp, rc) ip = period_inst call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsur', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofgwl', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsub', f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_irrig' , f_watr_roff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofi' , f_watr_ioff, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofl_wiso', & - f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, rc=rc) - call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofi_wiso', & + if (flds_wiso) then + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofl_wiso', & + f_watr_roff_16O, f_watr_roff_18O, f_watr_roff_HDO, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_rof_wiso(is_local%wrap%FBExp(comprof), 'Flrl_rofi_wiso', & f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1248,8 +1340,11 @@ subroutine med_phases_diag_glc( gcomp, rc) do ns = 1,num_icesheets areas => is_local%wrap%mesh_info(compglc(ns))%areas call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fogg_rofl', f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Fogg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_glc(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Figg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end do budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1326,11 +1421,11 @@ subroutine med_phases_diag_ocn( gcomp, rc) call fldbun_getdata1d(is_local%wrap%FBfrac(compocn), 'ofrac', ofrac, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return allocate(sfrac(size(ofrac))) - sfrac(:) = ifrac(:) + ofrac(:) - allocate(sfrac_x_ofrac(size(ofrac))) - sfrac_x_ofrac(:) = sfrac(:) * ofrac(:) + sfrac(:) = 1._r8 - areas => is_local%wrap%mesh_info(compocn)%areas + !areas => is_local%wrap%mesh_info(compocn)%areas + call fldbun_getdata1d(is_local%wrap%FBarea(compocn), 'area', areas, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !------------------------------- ! from ocn to mediator @@ -1352,15 +1447,9 @@ subroutine med_phases_diag_ocn( gcomp, rc) end do end if - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_lwup', f_heat_lwup , ic, areas, ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_lat' , f_heat_latvap , ic, areas, ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_sen' , f_heat_sen , ic, areas, ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compocn,compocn), 'Faox_evap', f_watr_evap , ic, areas, ofrac, budget_local, rc=rc) - - call diag_ocn_wiso(is_local%wrap%FBImp(compocn,compocn), 'Faox_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, ofrac, budget_local, rc=rc) - - budget_local(f_watr_frz,ic,ip) = budget_local(f_heat_frz,ic,ip) * HFLXtoWFLX + if (f_watr_frz /= unset_index) then + budget_local(f_watr_frz,ic,ip) = budget_local(f_heat_frz,ic,ip) * HFLXtoWFLX + end if !------------------------------- ! from mediator to ocn @@ -1373,56 +1462,92 @@ subroutine med_phases_diag_ocn( gcomp, rc) budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*ofrac(n) end do - if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', rc=rc)) then - call diag_ocn(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup', f_heat_lwup, ic, areas, sfrac_x_ofrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBImp(compatm,compocn), 'Faxa_lwdn', f_heat_lwdn, ic, areas, sfrac_x_ofrac, budget_local, rc=rc) - else - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lwup' , f_heat_lwup , ic, areas, sfrac, budget_local, rc=rc) + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lwnet', rc=rc)) then ! MOM6 + call diag_ocn(is_local%wrap%FBMed_aoflux_o , 'Faox_lwup', f_heat_lwup, ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBImp(compatm,compocn), 'Faxa_lwdn', f_heat_lwdn, ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else ! POP + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lwup' , f_heat_lwup , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_lwdn' , f_heat_lwdn , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lat', rc=rc)) then - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lat' , f_heat_latvap , ic, areas, sfrac, budget_local, rc=rc) - else - call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lat' , f_heat_latvap , ic, areas, sfrac_x_ofrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_sen' , f_heat_sen , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_evap', f_watr_evap , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_lat', rc=rc)) then ! POP + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_lat' , f_heat_latvap , ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else ! MOM6 + call diag_ocn(is_local%wrap%FBMed_aoflux_o, 'Faox_evap' , f_heat_latvap , ic, areas, ofrac, budget_local, & + scale=shr_const_latvap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_sen' , f_heat_sen , ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_evap' , f_watr_evap , ic, areas, sfrac, budget_local, rc=rc) + call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_meltw', f_watr_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_bergw', f_watr_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_melth', f_heat_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_bergh', f_heat_melt , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_salt' , f_watr_salt , ic, areas, sfrac, budget_local, & scale=SFLXtoWFLX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet', rc=rc)) then call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else if (fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', rc=rc)) then call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdr', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_vdf', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idr', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet_idf', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_rain' , f_watr_rain , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_snow' , f_watr_snow , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_rofl' , f_watr_roff , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_rofi' , f_watr_ioff , ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_meltw_wiso', & - f_watr_melt_16O, f_watr_melt_HDO, f_watr_melt_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_rain_wiso' , & - f_watr_rain_16O, f_watr_rain_HDO, f_watr_rain_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_snow_wiso' , & - f_watr_snow_16O, f_watr_snow_HDO, f_watr_snow_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofl_wiso' , & - f_watr_roff_16O, f_watr_roff_HDO, f_watr_roff_HDO, ic, areas, sfrac, budget_local, rc=rc) - call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofi_wiso' , & - f_watr_ioff_16O, f_watr_ioff_HDO, f_watr_ioff_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_ocn_wiso(is_local%wrap%FBMed_aoflux_o, 'Faox_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, ic, areas, ofrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_meltw_wiso', & + f_watr_melt_16O, f_watr_melt_HDO, f_watr_melt_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_rain_wiso' , & + f_watr_rain_16O, f_watr_rain_HDO, f_watr_rain_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Fioi_snow_wiso' , & + f_watr_snow_16O, f_watr_snow_HDO, f_watr_snow_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofl_wiso' , & + f_watr_roff_16O, f_watr_roff_HDO, f_watr_roff_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ocn_wiso(is_local%wrap%FBExp(compocn), 'Foxx_rofi_wiso' , & + f_watr_ioff_16O, f_watr_ioff_HDO, f_watr_ioff_HDO, ic, areas, sfrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice @@ -1449,6 +1574,7 @@ subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, scale, rc) real(r8), pointer :: data(:) ! ------------------------------------------------------------------ rc = ESMF_SUCCESS + if ( fldbun_fldchk(FB, trim(fldname), rc=rc)) then call fldbun_getdata1d(FB, trim(fldname), data, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1546,10 +1672,13 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_melth', f_heat_melt, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw', f_watr_melt, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_salt', f_watr_salt, & areas, lats, ifrac, budget_local, minus=.true., scale=SFLXtoWFLX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', rc=rc) .and. & fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdf', rc=rc) .and. & @@ -1557,32 +1686,46 @@ subroutine med_phases_diag_ice_ice2med( gcomp, rc) fldbun_fldchk(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idf', rc=rc)) then call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdr', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_vdf', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idr', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen_idf', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return else call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen', f_heat_swnet, & areas, lats, ifrac, budget_local, minus=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return end if call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_swnet', f_heat_swnet, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_lwup', f_heat_lwup, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_lat', f_heat_latvap, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_sen', f_heat_sen, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_recv(is_local%wrap%FBImp(compice,compice), 'Faii_evap', f_watr_evap, & areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw_wiso', & - f_watr_melt_16O, f_watr_melt_18O, f_watr_melt_HDO, areas, lats, ifrac, budget_local, rc=rc) - call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Faii_evap_wiso', & - f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw_wiso', & + f_watr_melt_16O, f_watr_melt_18O, f_watr_melt_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ice_recv_wiso(is_local%wrap%FBImp(compice,compice), 'Faii_evap_wiso', & + f_watr_evap_16O, f_watr_evap_18O, f_watr_evap_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if call t_stopf('MED:'//subname) end subroutine med_phases_diag_ice_ice2med @@ -1728,9 +1871,13 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) end do call diag_ice_send(is_local%wrap%FBExp(compice), 'Faxa_lwdn', f_heat_lwdn, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_send(is_local%wrap%FBExp(compice), 'Faxa_rain', f_watr_rain, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_send(is_local%wrap%FBExp(compice), 'Faxa_snow', f_watr_snow, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return call diag_ice_send(is_local%wrap%FBExp(compice), 'Fixx_rofi', f_watr_ioff, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return if ( fldbun_fldchk(is_local%wrap%FBExp(compice), 'Fioo_q', rc=rc)) then call fldbun_getdata1d(is_local%wrap%FBExp(compice), 'Fioo_q', data, rc=rc) @@ -1757,10 +1904,14 @@ subroutine med_phases_diag_ice_med2ice( gcomp, rc) budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice budget_local(f_watr_frz ,ic,ip) = budget_local(f_heat_frz ,ic,ip)*HFLXtoWFLX - call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_rain_wiso', & - f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, ifrac, budget_local, rc=rc) - call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_snow_wiso', & - f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (flds_wiso) then + call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_rain_wiso', & + f_watr_rain_16O, f_watr_rain_18O, f_watr_rain_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call diag_ice_send_wiso(is_local%wrap%FBExp(compice), 'Faxa_snow_wiso', & + f_watr_snow_16O, f_watr_snow_18O, f_watr_snow_HDO, areas, lats, ifrac, budget_local, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if call t_stopf('MED:'//subname) end subroutine med_phases_diag_ice_med2ice @@ -2328,13 +2479,21 @@ subroutine med_diag_print_summary(data, ip, date, tod) real(r8) :: net_heat_ice_nh , sum_net_heat_ice_nh real(r8) :: net_heat_ice_sh , sum_net_heat_ice_sh real(r8) :: net_heat_tot , sum_net_heat_tot + real(r8) :: net_salt_atm , sum_net_salt_atm + real(r8) :: net_salt_lnd , sum_net_salt_lnd + real(r8) :: net_salt_rof , sum_net_salt_rof + real(r8) :: net_salt_ocn , sum_net_salt_ocn + real(r8) :: net_salt_glc , sum_net_salt_glc + real(r8) :: net_salt_ice_nh , sum_net_salt_ice_nh + real(r8) :: net_salt_ice_sh , sum_net_salt_ice_sh + real(r8) :: net_salt_tot , sum_net_salt_tot character(len=40) :: str character(*), parameter:: subName = '(med_diag_print_summary) ' ! ------------------------------------------------------------------ call t_startf('MED:'//subname) - ! write out areas + ! write out areas write(diagunit,*) ' ' write(diagunit,FAH) subname,'NET AREA BUDGET (m2/m2): period = ',& trim(budget_diags%periods(ip)%name),& @@ -2347,7 +2506,10 @@ subroutine med_diag_print_summary(data, ip, date, tod) ice_area_sh = data(f_area,c_ish_recv,ip) sum_area = atm_area + lnd_area + ocn_area + ice_area_nh + ice_area_sh write(diagunit,FA1) budget_diags%fields(f_area)%name, atm_area, lnd_area, ocn_area, ice_area_nh, ice_area_sh, sum_area + + ! ----------------------------- ! write out net heat budgets + ! ----------------------------- write(diagunit,*) ' ' write(diagunit,FAH) subname,'NET HEAT BUDGET (W/m2): period = ',& @@ -2370,7 +2532,6 @@ subroutine med_diag_print_summary(data, ip, date, tod) end do ! Write out sum over all net heat budgets (sum over f_heat_beg -> f_heat_end) - sum_net_heat_atm = sum(data(f_heat_beg:f_heat_end, c_atm_recv, ip)) + & sum(data(f_heat_beg:f_heat_end, c_atm_send, ip)) sum_net_heat_lnd = sum(data(f_heat_beg:f_heat_end, c_lnd_recv, ip)) + & @@ -2392,7 +2553,9 @@ subroutine med_diag_print_summary(data, ip, date, tod) sum_net_heat_atm, sum_net_heat_lnd, sum_net_heat_rof, sum_net_heat_ocn, & sum_net_heat_ice_nh, sum_net_heat_ice_sh, sum_net_heat_glc, sum_net_heat_tot + ! ----------------------------- ! write out net water budgets + ! ----------------------------- write(diagunit,*) ' ' write(diagunit,FAH) subname,'NET WATER BUDGET (kg/m2s*1e6): period = ',& @@ -2414,8 +2577,7 @@ subroutine med_diag_print_summary(data, ip, date, tod) net_water_ice_nh, net_water_ice_sh, net_water_glc, net_water_tot enddo - ! Write out sum over all net heat budgets (sum over f_watr_beg -> f_watr_end) - + ! Write out sum over all net water budgets (sum over f_watr_beg -> f_watr_end) sum_net_water_atm = sum(data(f_watr_beg:f_watr_end, c_atm_recv, ip)) + & sum(data(f_watr_beg:f_watr_end, c_atm_send, ip)) sum_net_water_lnd = sum(data(f_watr_beg:f_watr_end, c_lnd_recv, ip)) + & @@ -2486,6 +2648,54 @@ subroutine med_diag_print_summary(data, ip, date, tod) end do end if + ! ----------------------------- + ! write out net salt budgets + ! ----------------------------- + + if (trim(budget_table_version) == 'v1') then + write(diagunit,*) ' ' + write(diagunit,FAH) subname,'NET SALT BUDGET (kg/m2s): period = ',& + trim(budget_diags%periods(ip)%name), ': date = ',date,tod + write(diagunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* ' + do nf = f_salt_beg, f_salt_end + net_salt_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip) + net_salt_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip) + net_salt_rof = data(nf, c_rof_recv, ip) + data(nf, c_rof_send, ip) + net_salt_ocn = data(nf, c_ocn_recv, ip) + data(nf, c_ocn_send, ip) + net_salt_ice_nh = data(nf, c_inh_recv, ip) + data(nf, c_inh_send, ip) + net_salt_ice_sh = data(nf, c_ish_recv, ip) + data(nf, c_ish_send, ip) + net_salt_glc = data(nf, c_glc_recv, ip) + data(nf, c_glc_send, ip) + net_salt_tot = net_salt_atm + net_salt_lnd + net_salt_rof + net_salt_ocn + & + net_salt_ice_nh + net_salt_ice_sh + net_salt_glc + + write(diagunit,FA1r) budget_diags%fields(nf)%name,& + net_salt_atm, net_salt_lnd, net_salt_rof, net_salt_ocn, & + net_salt_ice_nh, net_salt_ice_sh, net_salt_glc, net_salt_tot + enddo + + ! Write out sum over all net heat budgets (sum over f_salt_beg -> f_salt_end) + sum_net_salt_atm = sum(data(f_salt_beg:f_salt_end, c_atm_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_atm_send, ip)) + sum_net_salt_lnd = sum(data(f_salt_beg:f_salt_end, c_lnd_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_lnd_send, ip)) + sum_net_salt_rof = sum(data(f_salt_beg:f_salt_end, c_rof_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_rof_send, ip)) + sum_net_salt_ocn = sum(data(f_salt_beg:f_salt_end, c_ocn_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_ocn_send, ip)) + sum_net_salt_ice_nh = sum(data(f_salt_beg:f_salt_end, c_inh_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_inh_send, ip)) + sum_net_salt_ice_sh = sum(data(f_salt_beg:f_salt_end, c_ish_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_ish_send, ip)) + sum_net_salt_glc = sum(data(f_salt_beg:f_salt_end, c_glc_recv, ip)) + & + sum(data(f_salt_beg:f_salt_end, c_glc_send, ip)) + sum_net_salt_tot = sum_net_salt_atm + sum_net_salt_lnd + sum_net_salt_rof + sum_net_salt_ocn + & + sum_net_salt_ice_nh + sum_net_salt_ice_sh + sum_net_salt_glc + + write(diagunit,FA1r)' *SUM*',& + sum_net_salt_atm, sum_net_salt_lnd, sum_net_salt_rof, sum_net_salt_ocn, & + sum_net_salt_ice_nh, sum_net_salt_ice_sh, sum_net_salt_glc, sum_net_salt_tot + end if + call t_stopf('MED:'//subname) end subroutine med_diag_print_summary diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90 index e26748b8f..90fb0eb3f 100644 --- a/mediator/med_io_mod.F90 +++ b/mediator/med_io_mod.F90 @@ -6,7 +6,7 @@ module med_io_mod use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, I8=>SHR_KIND_I8, R8=>SHR_KIND_R8 use med_kind_mod , only : R4=>SHR_KIND_R4 - use shr_const_mod , only : fillvalue => SHR_CONST_SPVAL + use med_constants_mod , only : fillvalue => SHR_CONST_SPVAL use ESMF , only : ESMF_VM, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LogFoundError use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_END_ABORT, ESMF_LOGERR_PASSTHRU use ESMF , only : ESMF_VMGetCurrent, ESMF_VMGet, ESMF_VMBroadCast, ESMF_Finalize @@ -746,13 +746,13 @@ end function med_io_sec2hms !=============================================================================== subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & - fillval, pre, flds, tavg, use_float, file_ind, rc) + fillval, pre, flds, tavg, use_float, file_ind, tilesize, rc) !--------------- ! Write FB to netcdf file !--------------- - use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE + use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE, ESMF_END_ABORT use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_FieldBundle, ESMF_Mesh, ESMF_DistGrid use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet, ESMF_MeshGet, ESMF_DistGridGet use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_AttributeGet @@ -775,6 +775,7 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & logical, optional , intent(in) :: tavg ! is this a tavg logical, optional , intent(in) :: use_float ! write output as float rather than double integer, optional , intent(in) :: file_ind + integer, optional , intent(in) :: tilesize ! if non-zero, write atm component on tiles integer , intent(out):: rc ! local variables @@ -789,6 +790,7 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & integer :: ndims, nelements integer ,target :: dimid2(2) integer ,target :: dimid3(3) + integer ,target :: dimid4(4) integer ,pointer :: dimid(:) type(var_desc_t) :: varid type(io_desc_t) :: iodesc @@ -817,6 +819,8 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields integer :: gridToFieldMap(1) ! currently the size must equal 1 for rank 2 fields logical :: isPresent + logical :: atmtiles + integer :: ntiles = 1 character(CL), allocatable :: fieldNameList(:) character(*),parameter :: subName = '(med_io_write_FB) ' !------------------------------------------------------------------------------- @@ -831,6 +835,10 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & if (present(use_float)) luse_float = use_float lfile_ind = 0 if (present(file_ind)) lfile_ind=file_ind + atmtiles = .false. + if (present(tilesize)) then + if (tilesize > 0) atmtiles = .true. + end if ! Error check if (.not. ESMF_FieldBundleIsCreated(FB, rc=rc)) then @@ -900,15 +908,27 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & ! all the global grid values in the distgrid - e.g. CTSM ng = maxval(maxIndexPTile) - lnx = ng - lny = 1 + if (atmtiles) then + lnx = tilesize + lny = tilesize + ntiles = ng/(lnx*lny) + write(tmpstr,*) subname, 'ng,lnx,lny,ntiles = ',ng,lnx,lny,ntiles + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + if (ntiles /= 6) then + call ESMF_LogWrite(trim(subname)//' ERROR: only cubed sphere atm tiles valid ', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif + else + lnx = ng + lny = 1 + if (nx > 0) lnx = nx + if (ny > 0) lny = ny + if (lnx*lny /= ng) then + write(tmpstr,*) subname,' WARNING: grid2d size not consistent ',ng,lnx,lny + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + end if deallocate(minIndexPTile, maxIndexPTile) - if (nx > 0) lnx = nx - if (ny > 0) lny = ny - if (lnx*lny /= ng) then - write(tmpstr,*) subname,' WARNING: grid2d size not consistent ',ng,lnx,lny - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - endif if (present(nt)) then frame = nt @@ -918,6 +938,18 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & ! Write header if (whead) then + if (atmtiles) then + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_nx', lnx, dimid3(1)) + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ny', lny, dimid3(2)) + rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ntiles', ntiles, dimid3(3)) + if (present(nt)) then + dimid4(1:3) = dimid3 + rcode = pio_inq_dimid(io_file(lfile_ind), 'time', dimid4(4)) + dimid => dimid4 + else + dimid => dimid3 + endif + else rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_nx', lnx, dimid2(1)) rcode = pio_def_dim(io_file(lfile_ind), trim(lpre)//'_ny', lny, dimid2(2)) if (present(nt)) then @@ -927,8 +959,9 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & else dimid => dimid2 endif - write(tmpstr,*) subname,' dimid = ',dimid - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + write(tmpstr,*) subname,' dimid = ',dimid + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) do k = 1,nf ! Determine field name @@ -1034,8 +1067,12 @@ subroutine med_io_write_FB(filename, FB, whead, wdata, nx, ny, nt, & call ESMF_DistGridGet(distgrid, localDE=0, seqIndexList=dof, rc=rc) write(tmpstr,*) subname,' dof = ',ns,size(dof),dof(1),dof(ns) !,minval(dof),maxval(dof) call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) - ! call pio_writedof(lpre, (/lnx,lny/), int(dof,kind=PIO_OFFSET_KIND), mpicom) + if (atmtiles) then + call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny,ntiles/), dof, iodesc) + else + call pio_initdecomp(io_subsystem, pio_double, (/lnx,lny/), dof, iodesc) + !call pio_writedof(lpre, (/lnx,lny/), int(dof,kind=PIO_OFFSET_KIND), mpicom) + end if deallocate(dof) do k = 1,nf @@ -1356,7 +1393,7 @@ end subroutine med_io_write_char !=============================================================================== subroutine med_io_define_time(time_units, calendar, file_ind, rc) - use ESMF, only : operator(==), operator(/=) + use ESMF, only : operator(==), operator(/=) use ESMF, only : ESMF_Calendar, ESMF_CalendarIsCreated use ESMF, only : ESMF_CALKIND_360DAY, ESMF_CALKIND_GREGORIAN use ESMF, only : ESMF_CALKIND_JULIAN, ESMF_CALKIND_JULIANDAY, ESMF_CALKIND_MODJULIANDAY @@ -1913,7 +1950,7 @@ subroutine med_io_read_r81d(filename, vm, rdata, dname, rc) type(var_desc_t) :: varid character(CL) :: lversion character(CL) :: name1 - integer :: iam + integer :: iam character(*),parameter :: subName = '(med_io_read_r81d) ' !------------------------------------------------------------------------------- diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90 index 41b1931f2..6b713398a 100644 --- a/mediator/med_map_mod.F90 +++ b/mediator/med_map_mod.F90 @@ -325,7 +325,7 @@ end subroutine med_map_routehandles_initfrom_fieldbundle subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, routehandles, mapfile, rc) use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandlePrint, ESMF_Field, ESMF_MAXSTR - use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG + use ESMF , only : ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG, ESMF_POLEMETHOD_NONE use ESMF , only : ESMF_FieldSMMStore, ESMF_FieldRedistStore, ESMF_FieldRegridStore use ESMF , only : ESMF_RouteHandleIsCreated, ESMF_RouteHandleCreate use ESMF , only : ESMF_REGRIDMETHOD_BILINEAR, ESMF_REGRIDMETHOD_PATCH @@ -368,7 +368,7 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, integer :: ns integer(I4), pointer :: dof(:) integer :: srcTermProcessing_Value = 0 - type(ESMF_PoleMethod_Flag), parameter :: polemethod=ESMF_POLEMETHOD_ALLAVG + type(ESMF_PoleMethod_Flag) :: polemethod character(len=*), parameter :: subname=' (module_med_map: med_map_routehandles_initfrom_field) ' !--------------------------------------------- @@ -388,11 +388,19 @@ subroutine med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, ! set local flag to false ldstprint = .false. + polemethod=ESMF_POLEMETHOD_ALLAVG if (trim(coupling_mode) == 'cesm') then dstMaskValue = ispval_mask srcMaskValue = ispval_mask if (n1 == compocn .or. n1 == compice) srcMaskValue = 0 if (n2 == compocn .or. n2 == compice) dstMaskValue = 0 + if (n1 == compwav .and. n2 == compocn) then + srcMaskValue = 0 + dstMaskValue = ispval_mask + endif + if (n1 == compwav .or. n2 == compwav) then + polemethod = ESMF_POLEMETHOD_NONE ! todo: remove this when ESMF tripolar mapping fix is in place. + endif else if (coupling_mode(1:4) == 'nems') then if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then srcMaskValue = 1 @@ -1349,7 +1357,7 @@ subroutine med_map_uv_cart3d(FBsrc, FBdst, routehandles, mapindex, rc) use ESMF , only : ESMF_Field, ESMF_FieldCreate, ESMF_FieldGet use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet use ESMF , only : ESMF_RouteHandle - use shr_const_mod , only : shr_const_pi + use med_constants_mod , only : shr_const_pi ! input/output variables type(ESMF_FieldBundle) , intent(in) :: FBsrc diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90 index 42382d3d9..d8aa7acdd 100644 --- a/mediator/med_phases_aofluxes_mod.F90 +++ b/mediator/med_phases_aofluxes_mod.F90 @@ -312,8 +312,11 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldBundle use esmFlds , only : coupling_mode use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk +#ifdef CESMCOUPLED use shr_flux_mod , only : shr_flux_adjust_constants - +#else + use flux_atmocn_mod , only : flux_adjust_constants +#endif !----------------------------------------------------------------------- ! Initialize pointers to the module variables !----------------------------------------------------------------------- @@ -397,7 +400,7 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) end if !---------------------------------- - ! Initialize shr_flux_adjust_constants + ! Initialize flux_adjust_constants !---------------------------------- call NUOPC_CompAttributeGet(gcomp, name='coldair_outbreak_mod', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc) @@ -421,10 +424,18 @@ subroutine med_aofluxes_init(gcomp, aoflux_in, aoflux_out, rc) else flux_convergence = 0.0_r8 end if + +#ifdef CESMCOUPLED call shr_flux_adjust_constants(& flux_convergence_tolerance=flux_convergence, & flux_convergence_max_iteration=flux_max_iteration, & coldair_outbreak_mod=coldair_outbreak_mod) +#else + call flux_adjust_constants(& + flux_convergence_tolerance=flux_convergence, & + flux_convergence_max_iteration=flux_max_iteration, & + coldair_outbreak_mod=coldair_outbreak_mod) +#endif if (dbug_flag > 5) then call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO) @@ -855,10 +866,14 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) ! 3) Map aoflux output to relevant atm/ocn grid(s) !----------------------------------------------------------------------- - use ESMF , only : ESMF_GridComp - use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info, ESMF_SUCCESS - use med_map_mod , only : med_map_field_packed, med_map_rh_is_created - use shr_flux_mod , only : shr_flux_atmocn + use ESMF , only : ESMF_GridComp + use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info, ESMF_SUCCESS + use med_map_mod , only : med_map_field_packed, med_map_rh_is_created +#ifdef CESMCOUPLED + use shr_flux_mod , only : flux_atmocn +#else + use flux_atmocn_mod, only : flux_atmocn +#endif ! Arguments type(ESMF_GridComp) :: gcomp @@ -1001,7 +1016,9 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) ! Update atmosphere/ocean surface fluxes !---------------------------------- - call shr_flux_atmocn (& +#ifdef CESMCOUPLED + + call flux_atmocn (logunit=logunit, & nMax=aoflux_in%lsize, & zbot=aoflux_in%zbot, ubot=aoflux_in%ubot, vbot=aoflux_in%vbot, thbot=aoflux_in%thbot, qbot=aoflux_in%shum, & s16O=aoflux_in%shum_16O, sHDO=aoflux_in%shum_HDO, s18O=aoflux_in%shum_18O, rbot=aoflux_in%dens, & @@ -1013,7 +1030,20 @@ subroutine med_aofluxes_update(gcomp, aoflux_in, aoflux_out, rc) taux=aoflux_out%taux, tauy=aoflux_out%tauy, tref=aoflux_out%tref, qref=aoflux_out%qref, & ocn_surface_flux_scheme=ocn_surface_flux_scheme, & duu10n=aoflux_out%duu10n, ustar_sv=aoflux_out%ustar, re_sv=aoflux_out%re, ssq_sv=aoflux_out%ssq, & - missval = 0.0_r8) + missval=0.0_r8) + +#else + + call flux_atmocn (logunit=logunit, & + nMax=aoflux_in%lsize, mask=aoflux_in%mask, & + zbot=aoflux_in%zbot, ubot=aoflux_in%ubot, vbot=aoflux_in%vbot, thbot=aoflux_in%thbot, qbot=aoflux_in%shum, & + rbot=aoflux_in%dens, tbot=aoflux_in%tbot, us=aoflux_in%uocn, vs=aoflux_in%vocn, ts=aoflux_in%tocn, & + ocn_surface_flux_scheme=ocn_surface_flux_scheme, & + sen=aoflux_out%sen, lat=aoflux_out%lat, lwup=aoflux_out%lwup, evap=aoflux_out%evap, & + taux=aoflux_out%taux, tauy=aoflux_out%tauy, tref=aoflux_out%tref, qref=aoflux_out%qref, & + duu10n=aoflux_out%duu10n, missval=0.0_r8) + +#endif do n = 1,aoflux_in%lsize if (aoflux_in%mask(n) /= 0) then diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90 index 77496e1d7..5bf3c3a53 100644 --- a/mediator/med_phases_history_mod.F90 +++ b/mediator/med_phases_history_mod.F90 @@ -47,7 +47,13 @@ module med_phases_history_mod private :: med_phases_history_fldbun_average ! ---------------------------- - ! Instantaneous history files datatypes/variables + ! Instantaneous history files all components + ! ---------------------------- + character(CL) :: hist_option_all_inst ! freq_option setting (ndays, nsteps, etc) + integer :: hist_n_all_inst ! freq_n setting relative to freq_option + + ! ---------------------------- + ! Instantaneous history files datatypes/variables per component ! ---------------------------- type, public :: instfile_type logical :: write_inst @@ -144,8 +150,6 @@ subroutine med_phases_history_write(gcomp, rc) type(ESMF_Clock) :: mclock type(ESMF_Alarm) :: alarm character(CS) :: alarmname - character(CL) :: hist_option ! freq_option setting (ndays, nsteps, etc) - integer :: hist_n ! freq_n setting relative to freq_option character(CL) :: cvalue ! attribute string logical :: isPresent logical :: isSet @@ -185,27 +189,27 @@ subroutine med_phases_history_write(gcomp, rc) call NUOPC_CompAttributeGet(gcomp, name='history_option', isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - call NUOPC_CompAttributeGet(gcomp, name='history_option', value=hist_option, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name='history_option', value=hist_option_all_inst, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompAttributeGet(gcomp, name='history_n', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,*) hist_n + read(cvalue,*) hist_n_all_inst else ! If attribute is not present - don't write history output - hist_option = 'none' - hist_n = -999 + hist_option_all_inst = 'none' + hist_n_all_inst = -999 end if ! Set alarm name and initialize clock and alarm for instantaneous history output ! The alarm for the full history write is set on the mediator clock not as a separate alarm - if (hist_option /= 'none' .and. hist_option /= 'never') then + if (hist_option_all_inst /= 'none' .and. hist_option_all_inst /= 'never') then ! Initialize alarm on mediator clock for instantaneous mediator history output for all variables call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGet(mclock, startTime=starttime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call med_time_alarmInit(mclock, alarm, option=hist_option, opt_n=hist_n, & + call med_time_alarmInit(mclock, alarm, option=hist_option_all_inst, opt_n=hist_n_all_inst, & reftime=starttime, alarmname=alarmname, rc=rc) call ESMF_AlarmSet(alarm, clock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -221,14 +225,14 @@ subroutine med_phases_history_write(gcomp, rc) ! Write diagnostic info if (mastertask) then write(logunit,'(a,2x,i8)') trim(subname) // " initialized history alarm "//& - trim(alarmname)//" with option "//trim(hist_option)//" and frequency ",hist_n + trim(alarmname)//" with option "//trim(hist_option_all_inst)//" and frequency ",hist_n_all_inst end if end if first_time = .false. end if write_now = .false. - if (hist_option /= 'none' .and. hist_option /= 'never') then + if (hist_option_all_inst /= 'none' .and. hist_option_all_inst /= 'never') then call NUOPC_ModelGet(gcomp, modelClock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_ClockGetAlarm(mclock, alarmname=trim(alarmname), alarm=alarm, rc=rc) @@ -615,7 +619,7 @@ end subroutine med_phases_history_write_lnd2glc !=============================================================================== subroutine med_phases_history_write_comp(gcomp, compid, rc) - ! Write mediator history file for atm variables + ! Write mediator history file for compid variables ! input/output variables type(ESMF_GridComp), intent(inout) :: gcomp @@ -654,6 +658,7 @@ subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) integer :: hist_n ! freq_n setting relative to freq_option character(CL) :: hist_option_in character(CL) :: hist_n_in + integer :: hist_tilesize logical :: isPresent logical :: isSet type(ESMF_VM) :: vm @@ -676,10 +681,20 @@ subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Determine if tiled output to history file is requested + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_tilesize + else + hist_tilesize = 0 + end if ! alarm is not set determine hist_option and hist_n if (.not. instfile%is_clockset) then - ! Determine attribute prefix + ! Determine attribute name write(hist_option_in,'(a)') 'history_option_'//trim(compname(compid))//'_inst' write(hist_n_in,'(a)') 'history_n_'//trim(compname(compid))//'_inst' @@ -749,19 +764,19 @@ subroutine med_phases_history_write_comp_inst(gcomp, compid, instfile, rc) ! Define/write import field bundle if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid),rc=rc)) then call med_io_write(hist_file, is_local%wrap%FBimp(compid,compid), whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Imp', rc=rc) + nt=1, pre=trim(compname(compid))//'Imp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! Define/write import export bundle if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid),rc=rc)) then call med_io_write(hist_file, is_local%wrap%FBexp(compid), whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Exp', rc=rc) + nt=1, pre=trim(compname(compid))//'Exp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! Define/Write mediator fractions if (ESMF_FieldBundleIsCreated(is_local%wrap%FBFrac(compid),rc=rc)) then call med_io_write(hist_file, is_local%wrap%FBFrac(compid), whead(m), wdata(m), nx, ny, & - nt=1, pre='Med_frac_'//trim(compname(compid)), rc=rc) + nt=1, pre='Med_frac_'//trim(compname(compid)), tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if @@ -801,6 +816,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) integer :: hist_n ! freq_n setting relative to freq_option character(CL) :: hist_option_in character(CL) :: hist_n_in + integer :: hist_tilesize logical :: isPresent logical :: isSet type(ESMF_VM) :: vm @@ -825,10 +841,20 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Determine if tiled output to history file is requested + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call NUOPC_CompAttributeGet(gcomp, name='history_tile_'//trim(compname(compid)), value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) hist_tilesize + else + hist_tilesize = 0 + end if ! alarm is not set determine hist_option and hist_n if (.not. avgfile%is_clockset) then - ! Determine attribute prefix + ! Determine attribute name write(hist_option_in,'(a)') 'history_option_'//trim(compname(compid))//'_avg' write(hist_n_in,'(a)') 'history_n_'//trim(compname(compid))//'_avg' @@ -944,7 +970,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) ny = is_local%wrap%ny(compid) if (ESMF_FieldBundleIsCreated(is_local%wrap%FBimp(compid,compid),rc=rc)) then call med_io_write(hist_file, avgfile%FBaccum_import, whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Imp', rc=rc) + nt=1, pre=trim(compname(compid))//'Imp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (wdata(m)) then call med_methods_FB_reset(avgfile%FBAccum_import, czero, rc=rc) @@ -953,7 +979,7 @@ subroutine med_phases_history_write_comp_avg(gcomp, compid, avgfile, rc) endif if (ESMF_FieldBundleIsCreated(is_local%wrap%FBexp(compid),rc=rc)) then call med_io_write(hist_file, avgfile%FBaccum_export, whead(m), wdata(m), nx, ny, & - nt=1, pre=trim(compname(compid))//'Exp', rc=rc) + nt=1, pre=trim(compname(compid))//'Exp', tilesize=hist_tilesize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (wdata(m)) then call med_methods_FB_reset(avgfile%FBAccum_export, czero, rc=rc) @@ -1049,7 +1075,7 @@ subroutine med_phases_history_write_comp_aux(gcomp, compid, auxcomp, rc) if (isPresent .and. isSet) then call NUOPC_CompAttributeGet(gcomp, name=trim(prefix)//'_enabled', value=cvalue, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - read(cvalue,'(l)') enable_auxfile + read(cvalue,'(l7)') enable_auxfile else enable_auxfile = .false. end if diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90 index c9c4d76fe..ce3ef2a82 100644 --- a/mediator/med_phases_ocnalb_mod.F90 +++ b/mediator/med_phases_ocnalb_mod.F90 @@ -210,7 +210,7 @@ subroutine med_phases_ocnalb_run(gcomp, rc) use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldBundleIsCreated use ESMF , only : operator(+) use NUOPC , only : NUOPC_CompAttributeGet - use shr_const_mod , only : shr_const_pi + use med_constants_mod , only : shr_const_pi ! input/output variables type(ESMF_GridComp) :: gcomp diff --git a/mediator/med_phases_post_glc_mod.F90 b/mediator/med_phases_post_glc_mod.F90 index 44e013641..5987ee355 100644 --- a/mediator/med_phases_post_glc_mod.F90 +++ b/mediator/med_phases_post_glc_mod.F90 @@ -2,16 +2,16 @@ module med_phases_post_glc_mod !----------------------------------------------------------------------------- ! Mediator phase for mapping glc->lnd and glc->ocn after the receive of glc + ! ASSUMES that multiple ice sheets do not overlap !----------------------------------------------------------------------------- use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8 use NUOPC , only : NUOPC_CompAttributeGet - use ESMF , only : operator(/=) use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_SUCCESS, ESMF_FAILURE use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet use ESMF , only : ESMF_GridComp, ESMF_GridCompGet - use ESMF , only : ESMF_StateGet, ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND - use ESMF , only : ESMF_Mesh, ESMF_MeshLoc, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 + use ESMF , only : ESMF_StateGet, ESMF_StateItem_Flag + use ESMF , only : ESMF_Mesh, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8 use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated use esmFlds , only : compatm, compice, complnd, comprof, compocn, ncomps, compname @@ -30,10 +30,7 @@ module med_phases_post_glc_mod use med_internalstate_mod , only : InternalState, mastertask, logunit use med_map_mod , only : med_map_rh_is_created, med_map_routehandles_init use med_map_mod , only : med_map_field_packed, med_map_field_normalized, med_map_field - use med_merge_mod , only : med_merge_auto - use glc_elevclass_mod , only : glc_get_num_elevation_classes - use glc_elevclass_mod , only : glc_mean_elevation_virtual - use glc_elevclass_mod , only : glc_get_fractional_icecov + use glc_elevclass_mod , only : glc_mean_elevation_virtual, glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf implicit none @@ -159,7 +156,7 @@ subroutine med_phases_post_glc(gcomp, rc) end if !--------------------------------------- - ! glc->ocn mapping - + ! glc->ocn mapping ! merging with rof->ocn fields is done in med_phases_prep_ocn !--------------------------------------- if (glc2ocn_coupling) then @@ -236,7 +233,6 @@ subroutine med_phases_post_glc(gcomp, rc) end subroutine med_phases_post_glc !================================================================================================ - subroutine map_glc2lnd_init(gcomp, rc) ! input/output variables @@ -384,6 +380,7 @@ subroutine map_glc2lnd( gcomp, rc) real(r8), pointer :: topo_l_ec_sum(:,:) real(r8), pointer :: dataptr1d_src(:) real(r8), pointer :: dataptr1d_dst(:) + real(r8), pointer :: icemask_l(:) character(len=*), parameter :: subname = 'map_glc2lnd' !----------------------------------------------------------------------- @@ -553,25 +550,53 @@ subroutine map_glc2lnd( gcomp, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call field_getdata2d(field_frac_x_icemask_l_ec, frac_x_icemask_l_ec, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return + call field_getdata1d(field_icemask_l, icemask_l, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return ! set Sg_topo values in export state to land (in multiple elevation classes) ! also set the topo field for virtual columns, in a given elevation class. ! This is needed because virtual columns (i.e., elevation classes that have no ! contributing glc grid cells) won't have any topographic information mapped onto ! them, so would otherwise end up with an elevation of 0. + ! ASSUME that multiple ice sheets do not overlap do ec = 1,ungriddedCount topo_virtual = glc_mean_elevation_virtual(ec-1) ! glc_mean_elevation_virtual uses 0:glc_nec do l = 1,size(frac_x_icemask_l_ec, dim=2) - if (frac_l_ec_sum(ec,l) <= 0._r8) then - topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_virtual - else - if (frac_x_icemask_l_ec(ec,l) /= 0.0_r8) then - topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_l_ec(ec,l) / frac_x_icemask_l_ec(ec,l) + if (icemask_l(l) > 0._r8) then + ! We only do this where icemask_l > 0 to avoid adding topo_virtual + ! multiple times. If icemask_l == 0 for all ice sheets, then lnd should + ! ignore the topo values from glc, so it's safe to leave them unset; if + ! icemask_l is 0 for this ice sheet but > 0 for some other ice sheet, + ! then we'll get the appropriate topo setting from that other ice + ! sheet. + ! + ! Note that frac_l_ec_sum is the sum over ice sheets we have handled so + ! far in the outer loop over ice sheets. At first glance, that could + ! seem wrong (because what if a later ice sheet causes this sum to + ! become greater than 0?), and it may be that we should rework this for + ! clarity. However, since icemask_l > 0 (which is the ice mask for this + ! ice sheet) and we assume that multiple ice sheets do not overlap, we + ! can be confident that no other ice sheet will contribute to + ! frac_l_ec_sum for this land point, so if it is <= 0 at this point, + ! it should remain <= 0. + if (frac_l_ec_sum(ec,l) <= 0._r8) then + ! This is formulated as an addition for consistency with other + ! additions to the *_sum variables, but in practice only one ice + ! sheet will contribute to any land point, given the assumption of + ! non-overlapping ice sheet domains. (If more than one ice sheet + ! contributed to a given land point, the following line would do the + ! wrong thing, since it would add topo_virtual multiple times.) + topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_virtual + else + if (frac_x_icemask_l_ec(ec,l) /= 0.0_r8) then + topo_l_ec_sum(ec,l) = topo_l_ec_sum(ec,l) + topo_l_ec(ec,l) / frac_x_icemask_l_ec(ec,l) + end if end if end if end do end do end if + end do if (dbug_flag > 5) then diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90 index 890bb5501..8098d4106 100644 --- a/mediator/med_phases_prep_glc_mod.F90 +++ b/mediator/med_phases_prep_glc_mod.F90 @@ -31,6 +31,7 @@ module med_phases_prep_glc_mod use med_map_mod , only : med_map_field_normalized, med_map_field use med_constants_mod , only : dbug_flag => med_constants_dbug_flag use med_constants_mod , only : czero => med_constants_czero + use med_constants_mod , only : shr_const_pi, shr_const_spval use med_methods_mod , only : fldbun_getmesh => med_methods_FB_getmesh use med_methods_mod , only : fldbun_getdata2d => med_methods_FB_getdata2d use med_methods_mod , only : fldbun_getdata1d => med_methods_FB_getdata1d @@ -45,8 +46,6 @@ module med_phases_prep_glc_mod use glc_elevclass_mod , only : glc_get_elevation_classes use glc_elevclass_mod , only : glc_get_fractional_icecov use perf_mod , only : t_startf, t_stopf - use shr_const_mod , only : shr_const_pi, shr_const_spval - use shr_mpi_mod , only : shr_mpi_sum implicit none private @@ -962,7 +961,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) ! scaling in the CISM NUOPC cap if (smb_renormalize) then - call med_phases_prep_glc_renormalize_smb(gcomp, rc) + call med_phases_prep_glc_renormalize_smb(gcomp, ns, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return end if @@ -975,7 +974,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc) end subroutine med_phases_prep_glc_map_lnd2glc !================================================================================================ - subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) + subroutine med_phases_prep_glc_renormalize_smb(gcomp, ns, rc) !------------------ ! Renormalizes surface mass balance (smb, here named qice_g) so that the global @@ -1033,6 +1032,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) ! input/output variables type(ESMF_GridComp) :: gcomp + integer , intent(in) :: ns ! icesheet instance index integer , intent(out) :: rc ! return error code ! local variables @@ -1051,7 +1051,7 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) real(r8) , pointer :: dataptr1d(:) ! temporary 1d pointer real(r8) , pointer :: dataptr2d(:,:) ! temporary 2d pointer integer :: ec ! loop index over elevation classes - integer :: n, ns + integer :: n ! local and global sums of accumulation and ablation; used to compute renormalization factors real(r8) :: local_accum_lnd(1), global_accum_lnd(1) @@ -1082,160 +1082,156 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc) call ESMF_GridCompGetInternalState(gcomp, is_local, rc) if (chkErr(rc,__LINE__,u_FILE_u)) return - do ns = 1,num_icesheets - - !--------------------------------------- - ! Map icemask_g from the glc grid to the land grid. - !--------------------------------------- - - ! determine icemask_g and set as contents of field_icemask_g - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_icemask_fieldname, dataptr1d, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - call field_getdata1d(toglc_frlnd(ns)%field_icemask_g, icemask_g, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - icemask_g(:) = dataptr1d(:) - - ! map ice mask from glc to lnd with no normalization - call med_map_field( & - field_src=toglc_frlnd(ns)%field_icemask_g, & - field_dst=field_icemask_l, & - routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & - maptype=mapconsd, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return - - ! get icemask_l - call field_getdata1d(field_icemask_l, icemask_l, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return - - ! ------------------------------------------------------------------------ - ! Map frac_field on glc grid without elevation classes to frac_field on land grid with elevation classes - ! ------------------------------------------------------------------------ + !--------------------------------------- + ! Map icemask_g from the glc grid to the land grid. + !--------------------------------------- - ! get topo_g(:), the topographic height of each glc gridcell - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_topo_fieldname, topo_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! determine icemask_g and set as contents of field_icemask_g + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_icemask_fieldname, dataptr1d, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call field_getdata1d(toglc_frlnd(ns)%field_icemask_g, icemask_g, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + icemask_g(:) = dataptr1d(:) + + ! map ice mask from glc to lnd with no normalization + call med_map_field( & + field_src=toglc_frlnd(ns)%field_icemask_g, & + field_dst=field_icemask_l, & + routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & + maptype=mapconsd, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get icemask_l + call field_getdata1d(field_icemask_l, icemask_l, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - ! get frac_g(:), the total ice fraction in each glc gridcell - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_frac_fieldname, frac_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! ------------------------------------------------------------------------ + ! Map frac_field on glc grid without elevation classes to frac_field on land grid with elevation classes + ! ------------------------------------------------------------------------ - ! get frac_g_ec - the glc_elevclass gives the elevation class of each - ! glc grid cell, assuming that the grid cell is ice-covered, spans [1 -> ungriddedcount] - call field_getdata2d(toglc_frlnd(ns)%field_frac_g_ec, frac_g_ec, rc=rc) ! module field - if (chkerr(rc,__LINE__,u_FILE_u)) return - call glc_get_fractional_icecov(ungriddedCount-1, topo_g, frac_g, frac_g_ec, logunit) - - ! map fraction in each elevation class from the glc grid to the land grid and normalize by the icemask on the - ! glc grid - call med_map_field_normalized( & - field_src=toglc_frlnd(ns)%field_frac_g_ec, & - field_dst=field_frac_l_ec, & - routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & - maptype=mapconsd, & - field_normsrc=toglc_frlnd(ns)%field_icemask_g, & - field_normdst=field_normdst_l, rc=rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! get topo_g(:), the topographic height of each glc gridcell + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_topo_fieldname, topo_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get frac_g(:), the total ice fraction in each glc gridcell + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), Sg_frac_fieldname, frac_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + + ! get frac_g_ec - the glc_elevclass gives the elevation class of each + ! glc grid cell, assuming that the grid cell is ice-covered, spans [1 -> ungriddedcount] + call field_getdata2d(toglc_frlnd(ns)%field_frac_g_ec, frac_g_ec, rc=rc) ! module field + if (chkerr(rc,__LINE__,u_FILE_u)) return + call glc_get_fractional_icecov(ungriddedCount-1, topo_g, frac_g, frac_g_ec, logunit) + + ! map fraction in each elevation class from the glc grid to the land grid and normalize by the icemask on the + ! glc grid + call med_map_field_normalized( & + field_src=toglc_frlnd(ns)%field_frac_g_ec, & + field_dst=field_frac_l_ec, & + routehandles=is_local%wrap%RH(compglc(ns),complnd,:), & + maptype=mapconsd, & + field_normsrc=toglc_frlnd(ns)%field_icemask_g, & + field_normdst=field_normdst_l, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - !--------------------------------------- - ! Sum qice_l_ec over all elevation classes for each local land grid cell then do a global sum - !--------------------------------------- + !--------------------------------------- + ! Sum qice_l_ec over all elevation classes for each local land grid cell then do a global sum + !--------------------------------------- - ! get fractional ice coverage for each elevation class on the land grid, frac_l_ec(:,:) - call field_getdata2d(field_frac_l_ec, frac_l_ec, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return + ! get fractional ice coverage for each elevation class on the land grid, frac_l_ec(:,:) + call field_getdata2d(field_frac_l_ec, frac_l_ec, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - ! determine fraction on land grid, lfrac(:) - call fldbun_getdata1d(is_local%wrap%FBFrac(complnd), 'lfrac', lfrac, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return + ! determine fraction on land grid, lfrac(:) + call fldbun_getdata1d(is_local%wrap%FBFrac(complnd), 'lfrac', lfrac, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - ! get qice_l_ec - call fldbun_getdata2d(FBlndAccum2glc_l, trim(qice_fieldname)//'_elev', qice_l_ec, rc) - if (chkErr(rc,__LINE__,u_FILE_u)) return + ! get qice_l_ec + call fldbun_getdata2d(FBlndAccum2glc_l, trim(qice_fieldname)//'_elev', qice_l_ec, rc) + if (chkErr(rc,__LINE__,u_FILE_u)) return - local_accum_lnd(1) = 0.0_r8 - local_ablat_lnd(1) = 0.0_r8 - do n = 1, size(lfrac) - ! Calculate effective area for sum - need the mapped icemask_l - effective_area = min(lfrac(n), icemask_l(n)) * is_local%wrap%mesh_info(complnd)%areas(n) - if (effective_area > 0.0_r8) then - do ec = 1, ungriddedCount - if (qice_l_ec(ec,n) >= 0.0_r8) then - local_accum_lnd(1) = local_accum_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) - else - local_ablat_lnd(1) = local_ablat_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) - endif - end do ! ec - end if ! if landmaks > 0 - enddo ! n - - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllreduce(vm, senddata=local_accum_lnd, recvdata=global_accum_lnd, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMAllreduce(vm, senddata=local_ablat_lnd, recvdata=global_ablat_lnd, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (mastertask) then - write(logunit,'(a,d21.10)') trim(subname)//'global_accum_lnd = ', global_accum_lnd - write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_lnd = ', global_ablat_lnd - endif + local_accum_lnd(1) = 0.0_r8 + local_ablat_lnd(1) = 0.0_r8 + do n = 1, size(lfrac) + ! Calculate effective area for sum - need the mapped icemask_l + effective_area = min(lfrac(n), icemask_l(n)) * is_local%wrap%mesh_info(complnd)%areas(n) + if (effective_area > 0.0_r8) then + do ec = 1, ungriddedCount + if (qice_l_ec(ec,n) >= 0.0_r8) then + local_accum_lnd(1) = local_accum_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) + else + local_ablat_lnd(1) = local_ablat_lnd(1) + effective_area * frac_l_ec(ec,n) * qice_l_ec(ec,n) + endif + end do ! ec + end if ! if landmaks > 0 + enddo ! n - !--------------------------------------- - ! Sum qice_g over local glc grid cells. - !--------------------------------------- + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllreduce(vm, senddata=local_accum_lnd, recvdata=global_accum_lnd, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllreduce(vm, senddata=local_ablat_lnd, recvdata=global_ablat_lnd, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (mastertask) then + write(logunit,'(a,d21.10)') trim(subname)//'global_accum_lnd = ', global_accum_lnd + write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_lnd = ', global_ablat_lnd + endif - ! determine qice_g - call fldbun_getdata1d(is_local%wrap%FBExp(compglc(ns)), qice_fieldname, qice_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + !--------------------------------------- + ! Sum qice_g over local glc grid cells. + !--------------------------------------- - ! get areas internal to glc grid - call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Sg_area', area_g, rc) - if (chkerr(rc,__LINE__,u_FILE_u)) return + ! determine qice_g + call fldbun_getdata1d(is_local%wrap%FBExp(compglc(ns)), qice_fieldname, qice_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - local_accum_glc(1) = 0.0_r8 - local_ablat_glc(1) = 0.0_r8 - do n = 1, size(qice_g) - if (qice_g(n) >= 0.0_r8) then - local_accum_glc(1) = local_accum_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) - else - local_ablat_glc(1) = local_ablat_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) - endif - enddo ! n - call ESMF_VMAllreduce(vm, senddata=local_accum_glc, recvdata=global_accum_glc, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - call ESMF_VMAllreduce(vm, senddata=local_ablat_glc, recvdata=global_ablat_glc, count=1, & - reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (mastertask) then - write(logunit,'(a,d21.10)') trim(subname)//'global_accum_glc = ', global_accum_glc - write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_glc = ', global_ablat_glc - endif + ! get areas internal to glc grid + call fldbun_getdata1d(is_local%wrap%FBImp(compglc(ns),compglc(ns)), 'Sg_area', area_g, rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return - ! Renormalize - if (global_accum_glc(1) > 0.0_r8) then - accum_renorm_factor = global_accum_lnd(1) / global_accum_glc(1) + local_accum_glc(1) = 0.0_r8 + local_ablat_glc(1) = 0.0_r8 + do n = 1, size(qice_g) + if (qice_g(n) >= 0.0_r8) then + local_accum_glc(1) = local_accum_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) else - accum_renorm_factor = 0.0_r8 - endif - if (global_ablat_glc(1) < 0.0_r8) then ! negative by definition - ablat_renorm_factor = global_ablat_lnd(1) / global_ablat_glc(1) - else - ablat_renorm_factor = 0.0_r8 - endif - if (mastertask) then - write(logunit,'(a,d21.10)') trim(subname)//'accum_renorm_factor = ', accum_renorm_factor - write(logunit,'(a,d21.10)') trim(subname)//'ablat_renorm_factor = ', ablat_renorm_factor + local_ablat_glc(1) = local_ablat_glc(1) + icemask_g(n) * area_g(n) * qice_g(n) endif + enddo ! n + call ESMF_VMAllreduce(vm, senddata=local_accum_glc, recvdata=global_accum_glc, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + call ESMF_VMAllreduce(vm, senddata=local_ablat_glc, recvdata=global_ablat_glc, count=1, & + reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (mastertask) then + write(logunit,'(a,d21.10)') trim(subname)//'global_accum_glc = ', global_accum_glc + write(logunit,'(a,d21.10)') trim(subname)//'global_ablat_glc = ', global_ablat_glc + endif - do n = 1, size(qice_g) - if (qice_g(n) >= 0.0_r8) then - qice_g(n) = qice_g(n) * accum_renorm_factor - else - qice_g(n) = qice_g(n) * ablat_renorm_factor - endif - enddo + ! Renormalize + if (global_accum_glc(1) > 0.0_r8) then + accum_renorm_factor = global_accum_lnd(1) / global_accum_glc(1) + else + accum_renorm_factor = 0.0_r8 + endif + if (global_ablat_glc(1) < 0.0_r8) then ! negative by definition + ablat_renorm_factor = global_ablat_lnd(1) / global_ablat_glc(1) + else + ablat_renorm_factor = 0.0_r8 + endif + if (mastertask) then + write(logunit,'(a,d21.10)') trim(subname)//'accum_renorm_factor = ', accum_renorm_factor + write(logunit,'(a,d21.10)') trim(subname)//'ablat_renorm_factor = ', ablat_renorm_factor + endif - end do ! end of loop over ice sheets + do n = 1, size(qice_g) + if (qice_g(n) >= 0.0_r8) then + qice_g(n) = qice_g(n) * accum_renorm_factor + else + qice_g(n) = qice_g(n) * ablat_renorm_factor + endif + enddo call t_stopf('MED:'//subname) diff --git a/mediator/med_phases_profile_mod.F90 b/mediator/med_phases_profile_mod.F90 index 447b1e4c2..46d8f2a73 100644 --- a/mediator/med_phases_profile_mod.F90 +++ b/mediator/med_phases_profile_mod.F90 @@ -11,7 +11,9 @@ module med_phases_profile_mod use med_utils_mod , only : chkerr => med_utils_ChkErr use med_time_mod , only : alarmInit => med_time_alarmInit use perf_mod , only : t_startf, t_stopf +#ifdef CESMCOUPLED use shr_mem_mod , only : shr_mem_getusage +#endif implicit none private @@ -179,11 +181,13 @@ subroutine med_phases_profile(gcomp, rc) write(logunit,101) 'Model Date: ',trim(nexttimestr), ' wall clock = ',trim(walltimestr),' avg dt = ', & avgdt, ' s/day, dt = ',wallclockelapsed/ringdays,' s/day, rate = ',ypd,' ypd' +#ifdef CESMCOUPLED call shr_mem_getusage(msize,mrss,.true.) - write(logunit,105) ' memory_write: model date = ',trim(nexttimestr), & ' memory = ',msize,' MB (highwater) ',mrss,' MB (usage)' +#endif previous_time = current_time + endif endif iterations = iterations + 1 diff --git a/mediator/med_phases_restart_mod.F90 b/mediator/med_phases_restart_mod.F90 index e2e00c474..d87cfba80 100644 --- a/mediator/med_phases_restart_mod.F90 +++ b/mediator/med_phases_restart_mod.F90 @@ -113,7 +113,7 @@ subroutine med_phases_restart_alarm_init(gcomp, rc) write(logunit,'(a,2x,i8)') trim(subname)//" restart clock timestep = ",timestep_length write(logunit,'(a,2x,i8)') trim(subname)//" set restart alarm with option "//& trim(restart_option)//" and frequency ",restart_n - write(logunit,'(a)') trim(subname)//" write_restart_at_endofrun : ", write_restart_at_endofrun + write(logunit,'(a,l7)') trim(subname)//" write_restart_at_endofrun : ", write_restart_at_endofrun write(logunit,*) end if diff --git a/ufs/CMakeLists.txt b/ufs/CMakeLists.txt new file mode 100644 index 000000000..bb047dabb --- /dev/null +++ b/ufs/CMakeLists.txt @@ -0,0 +1,6 @@ +project(CMEPS_share Fortran) +include(ExternalProject) + +add_library(cmeps_share flux_atmocn_mod.F90 glc_elevclass_mod.F90 perf_mod.F90 ufs_const_mod.F90 ufs_kind_mod.F90) + +target_include_directories (cmeps_share PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS}) diff --git a/util/shr_flux_mod.F90 b/ufs/flux_atmocn_mod.F90 similarity index 75% rename from util/shr_flux_mod.F90 rename to ufs/flux_atmocn_mod.F90 index b04a13497..ca0bc200c 100644 --- a/util/shr_flux_mod.F90 +++ b/ufs/flux_atmocn_mod.F90 @@ -1,9 +1,8 @@ -module shr_flux_mod +module flux_atmocn_mod - use shr_kind_mod ! shared kinds - use shr_const_mod ! shared constants - use shr_sys_mod ! shared system routines - use shr_log_mod, only: s_logunit => shr_log_Unit + use ufs_kind_mod ! shared kinds + use ufs_const_mod ! shared constants + use ESMF, only : ESMF_FINALIZE, ESMF_END_ABORT implicit none @@ -11,18 +10,15 @@ module shr_flux_mod ! !PUBLIC MEMBER FUNCTIONS: - public :: shr_flux_atmOcn ! computes atm/ocn fluxes - public :: shr_flux_adjust_constants ! adjust constant values used in flux calculations. + public :: flux_atmOcn ! computes atm/ocn fluxes + public :: flux_adjust_constants ! adjust constant values used in flux calculations. !--- rename kinds for local readability only --- integer,parameter :: R8 = SHR_KIND_R8 ! 8 byte real integer,parameter :: IN = SHR_KIND_IN ! native/default integer - ! The follow variables are not declared as parameters so that they can be - ! adjusted to support aquaplanet and potentially other simple model modes. - ! The shr_flux_adjust_constants subroutine is called to set the desired - ! values. The default values are from shr_const_mod. Currently they are - ! only used by the shr_flux_atmocn and shr_flux_atmice routines. + ! The follow variables are not declared as parameters so that they can be adjusted. + ! The default values are from ufs_const_mod. real(R8) :: loc_zvir = shr_const_zvir real(R8) :: loc_cpdair = shr_const_cpdair real(R8) :: loc_cpvir = shr_const_cpvir @@ -51,56 +47,32 @@ module shr_flux_mod contains !=============================================================================== - subroutine shr_flux_adjust_constants( & - zvir, cpair, cpvir, karman, gravit, & - latvap, latice, stebol, flux_convergence_tolerance, & - flux_convergence_max_iteration, & - coldair_outbreak_mod) + subroutine flux_adjust_constants( flux_convergence_tolerance, & + flux_convergence_max_iteration, coldair_outbreak_mod) ! Adjust local constants. Used to support simple models. - - real(R8), optional, intent(in) :: zvir - real(R8), optional, intent(in) :: cpair - real(R8), optional, intent(in) :: cpvir - real(R8), optional, intent(in) :: karman - real(R8), optional, intent(in) :: gravit - real(R8), optional, intent(in) :: latvap - real(R8), optional, intent(in) :: latice - real(R8), optional, intent(in) :: stebol - real(r8), optional, intent(in) :: flux_convergence_tolerance - integer(in), optional, intent(in) :: flux_convergence_max_iteration - logical, optional, intent(in) :: coldair_outbreak_mod + real(r8) , optional, intent(in) :: flux_convergence_tolerance + integer(in) , optional, intent(in) :: flux_convergence_max_iteration + logical , optional, intent(in) :: coldair_outbreak_mod !---------------------------------------------------------------------------- - if (present(zvir)) loc_zvir = zvir - if (present(cpair)) loc_cpdair = cpair - if (present(cpvir)) loc_cpvir = cpvir - if (present(karman)) loc_karman = karman - if (present(gravit)) loc_g = gravit - if (present(latvap)) loc_latvap = latvap - if (present(latice)) loc_latice = latice - if (present(stebol)) loc_stebol = stebol if (present(flux_convergence_tolerance)) flux_con_tol = flux_convergence_tolerance if (present(flux_convergence_max_iteration)) flux_con_max_iter = flux_convergence_max_iteration - if(present(coldair_outbreak_mod)) use_coldair_outbreak_mod = coldair_outbreak_mod - end subroutine shr_flux_adjust_constants + if (present(coldair_outbreak_mod)) use_coldair_outbreak_mod = coldair_outbreak_mod + + end subroutine flux_adjust_constants !=============================================================================== - subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & - & qbot ,s16O ,sHDO ,s18O ,rbot , & - & tbot ,us ,vs , & - & ts ,mask ,seq_flux_atmocn_minwind, & - & sen ,lat ,lwup , & - & r16O, rhdo, r18O, & - & evap ,evap_16O, evap_HDO, evap_18O, & - & taux ,tauy ,tref ,qref , & - & ocn_surface_flux_scheme, & - & duu10n, ustar_sv ,re_sv ,ssq_sv, & - & missval ) + subroutine flux_atmOcn(logunit, nMax,zbot ,ubot ,vbot ,thbot , & + & qbot , rbot ,tbot ,us ,vs , & + & ts , mask ,sen ,lat ,lwup , & + & evap , taux ,tauy ,tref ,qref , & + & ocn_surface_flux_scheme, duu10n, missval ) implicit none !--- input arguments -------------------------------- + integer ,intent(in) :: logunit integer(IN),intent(in) :: nMax ! data vector length integer(IN),intent(in) :: mask (nMax) ! ocn domain mask 0 <=> out of domain real(R8) ,intent(in) :: zbot (nMax) ! atm level height (m) @@ -108,38 +80,23 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & real(R8) ,intent(in) :: vbot (nMax) ! atm v wind (bottom or 10m) (m/s) real(R8) ,intent(in) :: thbot(nMax) ! atm potential T (K) real(R8) ,intent(in) :: qbot (nMax) ! atm specific humidity (bottom or 2m) (kg/kg) - real(R8) ,intent(in) :: s16O (nMax) ! atm H216O tracer conc. (kg/kg) - real(R8) ,intent(in) :: sHDO (nMax) ! atm HDO tracer conc. (kg/kg) - real(R8) ,intent(in) :: s18O (nMax) ! atm H218O tracer conc. (kg/kg) - real(R8) ,intent(in) :: r16O (nMax) ! ocn H216O tracer ratio/Rstd - real(R8) ,intent(in) :: rHDO (nMax) ! ocn HDO tracer ratio/Rstd - real(R8) ,intent(in) :: r18O (nMax) ! ocn H218O tracer ratio/Rstd real(R8) ,intent(in) :: rbot (nMax) ! atm air density (kg/m^3) real(R8) ,intent(in) :: tbot (nMax) ! atm T (bottom or 2m) (K) real(R8) ,intent(in) :: us (nMax) ! ocn u-velocity (m/s) real(R8) ,intent(in) :: vs (nMax) ! ocn v-velocity (m/s) real(R8) ,intent(in) :: ts (nMax) ! ocn temperature (K) integer(IN),intent(in), optional :: ocn_surface_flux_scheme - real(R8) ,intent(in), optional :: seq_flux_atmocn_minwind ! minimum wind speed for atmocn (m/s) !--- output arguments ------------------------------- real(R8),intent(out) :: sen (nMax) ! heat flux: sensible (W/m^2) real(R8),intent(out) :: lat (nMax) ! heat flux: latent (W/m^2) real(R8),intent(out) :: lwup (nMax) ! heat flux: lw upward (W/m^2) real(R8),intent(out) :: evap (nMax) ! water flux: evap ((kg/s)/m^2) - real(R8),intent(out) :: evap_16O (nMax) ! water flux: evap ((kg/s/m^2) - real(R8),intent(out) :: evap_HDO (nMax) ! water flux: evap ((kg/s)/m^2) - real(R8),intent(out) :: evap_18O (nMax) ! water flux: evap ((kg/s/m^2) real(R8),intent(out) :: taux (nMax) ! surface stress, zonal (N) real(R8),intent(out) :: tauy (nMax) ! surface stress, maridional (N) real(R8),intent(out) :: tref (nMax) ! diag: 2m ref height T (K) real(R8),intent(out) :: qref (nMax) ! diag: 2m ref humidity (kg/kg) real(R8),intent(out) :: duu10n(nMax) ! diag: 10m wind speed squared (m/s)^2 - - real(R8),intent(out),optional :: ustar_sv(nMax) ! diag: ustar - real(R8),intent(out),optional :: re_sv (nMax) ! diag: sqrt of exchange coefficient (water) - real(R8),intent(out),optional :: ssq_sv (nMax) ! diag: sea surface humidity (kg/kg) - real(R8),intent(in) ,optional :: missval ! masked value ! !EOP @@ -170,7 +127,7 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & real(R8) :: rh ! sqrt of exchange coefficient (heat) real(R8) :: re ! sqrt of exchange coefficient (water) real(R8) :: ustar ! ustar - real(r8) :: ustar_prev + real(r8) :: ustar_prev real(R8) :: qstar ! qstar real(R8) :: tstar ! tstar real(R8) :: hol ! H (at zbot) over L @@ -329,9 +286,10 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & qstar = re * delq enddo if (iter < 1) then - write(s_logunit,*) ustar,ustar_prev,flux_con_tol,flux_con_max_iter - call shr_sys_abort('shr_flux_mod: No iterations performed ') + write(logunit,*) ustar,ustar_prev,flux_con_tol,flux_con_max_iter + call ESMF_Finalize(endflag=ESMF_END_ABORT) end if + !------------------------------------------------------------ ! compute the fluxes !------------------------------------------------------------ @@ -365,13 +323,6 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & duu10n(n) = u10n*u10n ! 10m wind speed squared - !------------------------------------------------------------ - ! optional diagnostics, needed for water tracer fluxes (dcn) - !------------------------------------------------------------ - if (present(ustar_sv)) ustar_sv(n) = ustar - if (present(re_sv )) re_sv(n) = re - if (present(ssq_sv )) ssq_sv(n) = ssq - else !------------------------------------------------------------ ! no valid data here -- out of domain @@ -380,21 +331,15 @@ subroutine shr_flux_atmOcn(nMax ,zbot ,ubot ,vbot ,thbot , & lat (n) = spval ! latent heat flux (W/m^2) lwup (n) = spval ! long-wave upward heat flux (W/m^2) evap (n) = spval ! evaporative water flux ((kg/s)/m^2) - evap_16O (n) = spval !water tracer flux (kg/s)/m^2) - evap_HDO (n) = spval !HDO tracer flux (kg/s)/m^2) - evap_18O (n) = spval !H218O tracer flux (kg/s)/m^2) taux (n) = spval ! x surface stress (N) tauy (n) = spval ! y surface stress (N) tref (n) = spval ! 2m reference height temperature (K) qref (n) = spval ! 2m reference height humidity (kg/kg) duu10n(n) = spval ! 10m wind speed squared (m/s)^2 - if (present(ustar_sv)) ustar_sv(n) = spval - if (present(re_sv )) re_sv (n) = spval - if (present(ssq_sv )) ssq_sv (n) = spval endif end DO - end subroutine shr_flux_atmOcn + end subroutine flux_atmOcn -end module shr_flux_mod +end module flux_atmocn_mod diff --git a/util/glc_elevclass_mod.F90 b/ufs/glc_elevclass_mod.F90 similarity index 97% rename from util/glc_elevclass_mod.F90 rename to ufs/glc_elevclass_mod.F90 index ea4c4c9e0..3bcefc23c 100644 --- a/util/glc_elevclass_mod.F90 +++ b/ufs/glc_elevclass_mod.F90 @@ -2,10 +2,10 @@ module glc_elevclass_mod !--------------------------------------------------------------------- ! This module contains the interfaces needed by mediator code - but - ! is not used by the NEMS system + ! is not used by the UFS system !--------------------------------------------------------------------- - use shr_kind_mod , only : r8=>shr_kind_r8 + use ufs_kind_mod , only : r8=>shr_kind_r8 implicit none private diff --git a/util/perf_mod.F90 b/ufs/perf_mod.F90 similarity index 100% rename from util/perf_mod.F90 rename to ufs/perf_mod.F90 diff --git a/util/shr_const_mod.F90 b/ufs/ufs_const_mod.F90 similarity index 93% rename from util/shr_const_mod.F90 rename to ufs/ufs_const_mod.F90 index 8437190c7..173baf3ab 100644 --- a/util/shr_const_mod.F90 +++ b/ufs/ufs_const_mod.F90 @@ -1,11 +1,6 @@ -!=============================================================================== -! SVN $Id: shr_const_mod.F90 61510 2014-06-26 21:58:56Z tcraig $ -! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_const_mod.F90 $ -!=============================================================================== +MODULE ufs_const_mod -MODULE shr_const_mod - - use shr_kind_mod, only : R8 => shr_kind_r8 + use ufs_kind_mod, only : R8 => shr_kind_r8 !---------------------------------------------------------------------------- ! physical constants (all data public) @@ -102,4 +97,4 @@ end function shr_const_isspval !----------------------------------------------------------------------------- -END MODULE shr_const_mod +END MODULE ufs_const_mod diff --git a/util/shr_kind_mod.F90 b/ufs/ufs_kind_mod.F90 similarity index 95% rename from util/shr_kind_mod.F90 rename to ufs/ufs_kind_mod.F90 index e9e7d170c..195485e9a 100644 --- a/util/shr_kind_mod.F90 +++ b/ufs/ufs_kind_mod.F90 @@ -1,4 +1,4 @@ -MODULE shr_kind_mod +MODULE ufs_kind_mod !---------------------------------------------------------------------------- ! precision/kind constants add data public @@ -16,4 +16,4 @@ MODULE shr_kind_mod integer,parameter :: SHR_KIND_CX = 512 ! extra-long char integer,parameter :: SHR_KIND_CXX= 4096 ! extra-extra-long char -END MODULE shr_kind_mod +END MODULE ufs_kind_mod diff --git a/util/CMakeLists.txt b/util/CMakeLists.txt deleted file mode 100644 index 6b95eea08..000000000 --- a/util/CMakeLists.txt +++ /dev/null @@ -1,7 +0,0 @@ -project(CMEPS_share Fortran) -include(ExternalProject) - -add_library(cmeps_share shr_abort_mod.F90 shr_flux_mod.F90 shr_log_mod.F90 shr_mpi_mod.F90 shr_sys_mod.F90 - glc_elevclass_mod.F90 perf_mod.F90 shr_const_mod.F90 shr_kind_mod.F90 shr_mem_mod.F90) - -target_include_directories (cmeps_share PUBLIC ${CMAKE_CURRENT_SOURCE_DIR} ${ESMF_F90COMPILEPATHS} ${PIO_Fortran_INCLUDE_DIRS}) diff --git a/util/Makefile b/util/Makefile deleted file mode 100644 index 5cb72884a..000000000 --- a/util/Makefile +++ /dev/null @@ -1,50 +0,0 @@ -ifneq ($(origin ESMFMKFILE), environment) -$(error Environment variable ESMFMKFILE was not set.) -endif - -include $(ESMFMKFILE) - -ifndef PIO_INC -$(error PIO_INC should point to PIO include directory.) -endif - -LIBRARY = libcmeps_util.a - -OBJ1= \ -perf_mod.o \ -shr_abort_mod.o \ -shr_const_mod.o \ -shr_flux_mod.o \ -shr_kind_mod.o \ -shr_log_mod.o \ -shr_mem_mod.o \ -shr_mpi_mod.o \ -shr_pio_mod.o \ -shr_sys_mod.o \ -glc_elevclass_mod.o - -all default: $(LIBRARY) - -$(LIBRARY): $(OBJ1) - $(AR) $(ARFLAGS) $@ $(OBJ1) - -%.o: %.F90.in - perl genf90.pl $< > $(@:.o=.F90) - $(ESMF_F90COMPILER) -c $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) -I$(PIO_INC) -DFORTRANUNDERSCORE -DCPRINTEL $(@:.o=.F90) -%.o: %.F90 - $(ESMF_F90COMPILER) -c $(ESMF_F90COMPILEOPTS) $(ESMF_F90COMPILEPATHS) -I$(PIO_INC) -I. $*.F90 - -clean: - $(RM) -f $(LIBRARY) *.f90 *.i90 *.o *.mod - $(RM) -f med_constants_mod.* - -perf_mod.o: shr_kind_mod.o -shr_abort_mod.o: shr_kind_mod.o shr_mpi_mod.o shr_log_mod.o -shr_const_mod.o: shr_kind_mod.o shr_const_mod.F90 -shr_flux_mod.o: shr_kind_mod.o shr_const_mod.o shr_sys_mod.o shr_log_mod.o -shr_log_mod.o: shr_kind_mod.o -shr_mem_mod.o: shr_kind_mod.o shr_log_mod.o -shr_mpi_mod.o: shr_kind_mod.o shr_log_mod.o -shr_pio_mod.o: shr_kind_mod.o shr_log_mod.o shr_mpi_mod.o shr_sys_mod.o -shr_sys_mod.o: shr_kind_mod.o shr_log_mod.o shr_abort_mod.o -glc_elevclass_mod.o: shr_kind_mod.o diff --git a/util/dtypes.h b/util/dtypes.h deleted file mode 100644 index 9076cf0f7..000000000 --- a/util/dtypes.h +++ /dev/null @@ -1,5 +0,0 @@ -#define TYPEDOUBLE 102 -#define TYPEINT 103 -#define TYPETEXT 100 -#define TYPELONG 104 -#define TYPEREAL 101 diff --git a/util/genf90.pl b/util/genf90.pl deleted file mode 100755 index 5d35112e9..000000000 --- a/util/genf90.pl +++ /dev/null @@ -1,387 +0,0 @@ -#!/usr/bin/env perl -use strict; -my $outfile; -# Beginning with F90, Fortran has strict typing of variables based on "TKR" -# (type, kind, and rank). In many cases we want to write subroutines that -# provide the same functionality for different variable types and ranks. In -# order to do this without cut-and-paste duplication of code, we create a -# template file with the extension ".F90.in", which can be parsed by this script -# to generate F90 code for all of the desired specific types. -# -# Keywords are delimited by curly brackets: {} -# -# {TYPE} and {DIMS} are used to generate the specific subroutine names from the -# generic template -# {TYPE} : Variable type name; implemented types are character, 4 or 8 byte real, -# and 4 or 8 byte integer. -# allowed values: text, real, double, int, long, logical -# default values: text, real, double, int -# {VTYPE} : Used to generate variable declarations to match the specific type. -# if {TYPE}=double then {VTYPE} is "real(r8)" -# {ITYPE}, {ITYPENAME} : Used to generate CPP statements for the specific type. -# {MPITYPE} : Used to generate MPI types corresponding to the specific type. -# -# {DIMS} : Rank of arrays, "0" for scalar. -# allowed values: 0-7 -# default values : 0-5 -# {DIMSTR} : Generates the parenthesis and colons used for a variable -# declaration of {DIMS} dimensions. -# if {DIMS}=3 then {DIMSTR} is (:,:,:) -# {REPEAT} : Repeats an expression for each number from 1 to {DIMS}, with each -# iteration separated by commas. -# {REPEAT: foo(#, bar)} -# expands to this: -# foo(1, bar), foo(2, bar), foo(3, bar), ... - -# defaults -my @types = qw(text real double int); -my $vtype = {'text' => 'character(len=*)', - 'real' => 'real(r4)', - 'double' => 'real(r8)', - 'int' => 'integer(i4)', - 'long' => 'integer(i8)', - 'logical' => 'logical' }; -my $itype = {'text' => 100, - 'real' => 101, - 'double' => 102, - 'int' => 103, - 'long' => 104, - 'logical' => 105}; -my $itypename = {'text' => 'TYPETEXT', - 'real' => 'TYPEREAL', - 'double' => 'TYPEDOUBLE', - 'int' => 'TYPEINT', - 'long' => 'TYPELONG', - 'logical' => 'TYPELOGICAL'}; -my $mpitype = {'text' => 'MPI_CHARACTER', - 'real' => 'MPI_REAL4', - 'double' => 'MPI_REAL8', - 'int' => 'MPI_INTEGER'}; -# Netcdf C datatypes -my $nctype = {'text' => 'text', - 'real' => 'float', - 'double' => 'double', - 'int' => 'int'}; -# C interoperability types -my $ctype = {'text' => 'character(C_CHAR)', - 'real' => 'real(C_FLOAT)', - 'double' => 'real(C_DOUBLE)', - 'int' => 'integer(C_INT)'}; - - - -my @dims =(0..5); - -my $write_dtypes = "no"; -# begin - -foreach(@ARGV){ - my $infile = $_; - usage() unless($infile =~ /(.*.F90).in/); - $outfile = $1; - open(F,"$infile") || die "$0 Could not open $infile to read"; - my @parsetext; - my $cnt=0; - foreach(){ - $cnt++; - if(/^\s*contains/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - if(/^\s*interface/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - if(/^[^!]*subroutine/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - if(/^[^!]*function/i){ - push(@parsetext,"# $cnt \"$infile\"\n"); - } - - push(@parsetext,$_); - } - - close(F); - - my $end; - my $contains=0; - my $in_type_block=0; - my @unit; - my $unitcnt=0; - my $date = localtime(); - my $preamble = -"!=================================================== -! DO NOT EDIT THIS FILE, it was generated using $0 -! Any changes you make to this file may be lost -!===================================================\n"; - my @output ; - push(@output,$preamble); - - my $line; - my $dimmodifier; - my $typemodifier; - my $itypeflag; - my $block; - my $block_type; - my $cppunit; - foreach $line (@parsetext){ -# skip parser comments - next if($line =~ /\s*!pl/); - - $itypeflag=1 if($line =~ /{ITYPE}/); - $itypeflag=1 if($line =~ /TYPETEXT/); - $itypeflag=1 if($line =~ /TYPEREAL/); - $itypeflag=1 if($line =~ /TYPEDOUBLE/); - $itypeflag=1 if($line =~ /TYPEINT/); - $itypeflag=1 if($line =~ /TYPELONG/); - - - if($contains==0){ - if($line=~/\s*!\s*DIMS\s+[\d,]+!*/){ - $dimmodifier=$line; - next; - } - if($line=~/\s*!\s*TYPE\s+[^!]+!*$/){ - $typemodifier=$line; - next; - } - if ((defined $typemodifier or defined $dimmodifier) - and not defined $block and $line=~/^\s*#[^{]*$/) { - push(@output, $line); - next; - } - # Figure out the bounds of a type statement. - # Type blocks start with "type," "type foo" or "type::" but not - # "type(". - $in_type_block=1 if($line=~/^\s*type\s*[,:[:alpha:]]/i); - $in_type_block=0 if($line=~/^\s*end\s*type/i); - if(not defined $block) { - if ($line=~/^\s*type[^[:alnum:]_].*(\{TYPE\}|\{DIMS\})/i or - $line=~/^[^!]*(function|subroutine).*(\{TYPE\}|\{DIMS\})/i) { - $block=$line; - next; - } - if ($line=~/^\s*interface.*(\{TYPE\}|\{DIMS\})/i) { - $block_type="interface"; - $block=$line; - next; - } - } - if(not defined $block_type and - ($line=~/^\s*end\s+type\s+.*(\{TYPE\}|\{DIMS\})/i or - $line=~/^\s*end\s+(function|subroutine)\s+.*(\{TYPE\}|\{DIMS\})/i)){ - - $line = $block.$line; - undef $block; - } - if ($line=~/^\s*end\s*interface/i and - defined $block) { - $line = $block.$line; - undef $block; - undef $block_type; - } - if(defined $block){ - $block = $block.$line; - next; - } - if(defined $dimmodifier){ - $line = $dimmodifier.$line; - undef $dimmodifier; - } - if(defined $typemodifier){ - $line = $typemodifier.$line; - undef $typemodifier; - } - - push(@output, buildout($line)); - if(($line =~ /^\s*contains\s*!*/i && ! $in_type_block) or - ($line =~ /^\s*!\s*Not a module/i)){ - $contains=1; - next; - } - } - if($line=~/^\s*end module\s*/){ - $end = $line; - last; - } - - if($contains==1){ - # first parse into functions or subroutines - if($cppunit || !(defined($unit[$unitcnt]))){ - # Make cpp lines and blanks between routines units. - if($line =~ /^\s*\#(?!\s[[:digit:]]+)/ || $line =~/^\s*$/ || $line=~/^\s*!(?!\s*(TYPE|DIMS))/){ - push(@{$unit[$unitcnt]},$line); - $cppunit=1; - next; - } else { - $cppunit=0; - $unitcnt++; - } - } - - - push(@{$unit[$unitcnt]},$line); - if ($line=~/^\s*interface/i) { - $block_type="interface"; - $block=$line; - } - if ($line=~/^\s*end\s*interface/i) { - undef $block_type; - undef $block; - } - unless(defined $block){ - if($line =~ /\s*end function/i or $line =~ /\s*end subroutine/i){ - $unitcnt++; - } - } - } - } - my $i; - - - for($i=0;$i<$unitcnt;$i++){ - if(defined($unit[$i])){ - my $func = join('',@{$unit[$i]}); - push(@output, buildout($func)); - } - } - push(@output,@{$unit[$#unit]}) if($unitcnt==$#unit); - push(@output, $end); - if($itypeflag==1){ - my $str; - $str.="#include \"dtypes.h\"\n"; - $write_dtypes = "yes"; - print $str; - } - print @output; - writedtypes() if(!(-e "dtypes.h") && $write_dtypes == "yes"); - - -} - - -sub usage{ - die("$0 Expected input filename of the form .*.F90.in"); -} - -sub build_repeatstr{ - my($dims) = @_; - # Create regex to repeat expression DIMS times. - my $repeatstr; - for(my $i=1;$i<=$dims;$i++){ - $repeatstr .="\$\{1\}$i\$\{2\},&\n"; - } - if(defined $repeatstr){ - $repeatstr="\"$repeatstr"; - chop $repeatstr; - chop $repeatstr; - chop $repeatstr; - $repeatstr.="\""; - }else{ - $repeatstr=''; - } -} - -sub writedtypes{ - open(F,">dtypes.h"); - print F -"#define TYPETEXT 100 -#define TYPEREAL 101 -#define TYPEDOUBLE 102 -#define TYPEINT 103 -#define TYPELONG 104 -#define TYPELOGICAL 105 -"; - close(F); -} - -sub buildout{ - my ($func) = @_; - - my $outstr; - my(@ldims, @ltypes); - - if($func=~/\s*!\s*DIMS\s+([\d,]+)\s*/){ - @ldims = split(/,/,$1); - }else{ - @ldims = @dims; - } - if($func=~/\s*!\s*TYPE\s+([^!\s]+)\s*/){ - @ltypes = split(/,/,$1); -# print ">$func<>@ltypes<\n"; - }else{ - @ltypes = @types; - } - - - if(($func =~ /{TYPE}/ && $func =~ /{DIMS}/) ){ - my ($type, $dims); - foreach $type (@ltypes){ - foreach $dims (@ldims){ - my $dimstr; - for(my $i=1;$i<=$dims;$i++){ - $dimstr .=':,'; - } - if(defined $dimstr){ - $dimstr="($dimstr"; - chop $dimstr; - $dimstr.=')'; - }else{ - $dimstr=''; - } - - my $repeatstr = build_repeatstr($dims); - - my $str = $func; - $str =~ s/{TYPE}/$type/g; - $str =~ s/{VTYPE}/$vtype->{$type}/g; - $str =~ s/{ITYPE}/$itype->{$type}/g; - $str =~ s/{MPITYPE}/$mpitype->{$type}/g; - $str =~ s/{NCTYPE}/$nctype->{$type}/g; - $str =~ s/{CTYPE}/$ctype->{$type}/g; - $str =~ s/{DIMS}/$dims/g; - $str =~ s/{DIMSTR}/$dimstr/g; - $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; - $outstr .= $str; - } - } - }elsif($func =~ /{DIMS}/){ - my $dims; - foreach $dims (@ldims){ - my $dimstr; - for(my $i=1;$i<=$dims;$i++){ - $dimstr .=':,'; - } - if(defined $dimstr){ - $dimstr="($dimstr"; - chop $dimstr; - $dimstr.=')'; - }else{ - $dimstr=''; - } - - my $repeatstr = build_repeatstr($dims); - - my $str = $func; - $str =~ s/{DIMS}/$dims/g; - $str =~ s/{DIMSTR}/$dimstr/g; - $str =~ s/{REPEAT:([^#}]*)#([^#}]*)}/$repeatstr/eeg; - $outstr .= $str; - } - }elsif($func =~ /{TYPE}/){ - my ($type); - foreach $type (@ltypes){ - my $str = $func; - $str =~ s/{TYPE}/$type/g; - $str =~ s/{VTYPE}/$vtype->{$type}/g; - $str =~ s/{ITYPE}/$itype->{$type}/g; - $str =~ s/{MPITYPE}/$mpitype->{$type}/g; - $str =~ s/{NCTYPE}/$nctype->{$type}/g; - $str =~ s/{CTYPE}/$ctype->{$type}/g; - $outstr.=$str; - } - }else{ - $outstr=$func; - } - - return $outstr; -} diff --git a/util/shr_abort_mod.F90 b/util/shr_abort_mod.F90 deleted file mode 100644 index 9e4de5bd0..000000000 --- a/util/shr_abort_mod.F90 +++ /dev/null @@ -1,164 +0,0 @@ -module shr_abort_mod - ! This module defines procedures that can be used to abort the model cleanly in a - ! system-specific manner - ! - ! The public routines here are only meant to be used directly by shr_sys_mod. Other code - ! that wishes to use these routines should use the republished names from shr_sys_mod - ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from - ! when these routines were defined in shr_sys_mod.) - - use, intrinsic :: iso_fortran_env, only: output_unit, error_unit - - use shr_kind_mod, only : shr_kind_in, shr_kind_cx - use shr_mpi_mod , only : shr_mpi_initialized, shr_mpi_abort - use shr_log_mod , only : s_logunit => shr_log_Unit - -#ifdef CPRNAG - ! NAG does not provide this as an intrinsic, but it does provide modules - ! that implement commonly used POSIX routines. - use f90_unix_proc, only: abort -#endif - - implicit none - - ! PUBLIC: Public interfaces - - private - - ! The public routines here are only meant to be used directly by shr_sys_mod. Other code - ! that wishes to use these routines should use the republished names from shr_sys_mod - ! (shr_sys_abort, shr_sys_backtrace). (This is for consistency with older code, from - ! when these routines were defined in shr_sys_mod.) - public :: shr_abort_abort ! abort a program - public :: shr_abort_backtrace ! print a backtrace, if possible - -contains - - !=============================================================================== - subroutine shr_abort_abort(string,rc) - ! Consistent stopping mechanism - - !----- arguments ----- - character(len=*) , intent(in), optional :: string ! error message string - integer(shr_kind_in), intent(in), optional :: rc ! error code - - !----- local ----- - logical :: flag - - ! Local version of the string. - ! (Gets a default value if string is not present.) - character(len=shr_kind_cx) :: local_string - !------------------------------------------------------------------------------- - - if (present(string)) then - local_string = trim(string) - else - local_string = "Unknown error submitted to shr_abort_abort." - end if - - call print_error_to_logs("ERROR", local_string) - - call shr_abort_backtrace() - - call shr_mpi_initialized(flag) - - if (flag) then - if (present(rc)) then - call shr_mpi_abort(trim(local_string),rc) - else - call shr_mpi_abort(trim(local_string)) - endif - endif - - ! A compiler's abort method may print a backtrace or do other nice - ! things, but in fact we can rarely leverage this, because MPI_Abort - ! usually sends SIGTERM to the process, and we don't catch that signal. - call abort() - - end subroutine shr_abort_abort - !=============================================================================== - - !=============================================================================== - subroutine shr_abort_backtrace() - ! This routine uses compiler-specific facilities to print a backtrace to - ! error_unit (standard error, usually unit 0). - -#if defined(CPRIBM) - - ! This theoretically should be in xlfutility, but using it from that - ! module doesn't seem to always work. - interface - subroutine xl_trbk() - end subroutine xl_trbk - end interface - - call xl__trbk() - -#elif defined(CPRGNU) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 8 )) - - ! gfortran 4.8 and later implement this intrinsic. We explicitly call it - ! out as such to make sure that it really is available, just in case the - ! CPP logic above screws up. - intrinsic :: backtrace - - call backtrace() - -#elif defined(CPRINTEL) - - ! tracebackqq uses optional arguments, so *must* have an explicit - ! interface. - use ifcore, only: tracebackqq - - ! An exit code of -1 is a special value that prevents this subroutine - ! from aborting the run. - call tracebackqq(user_exit_code=-1) - -#else - - ! Currently we have no means to request a backtrace from the NAG runtime, - ! even though it is capable of emitting backtraces itself, if you use the - ! "-gline" option. - - ! Similarly, PGI has a -traceback option, but no user interface for - ! requesting a backtrace to be printed. - -#endif - - flush(error_unit) - - end subroutine shr_abort_backtrace - !=============================================================================== - - !=============================================================================== - subroutine print_error_to_logs(error_type, message) - ! This routine prints error messages to s_logunit (which is standard output - ! for most tasks in CESM) and also to standard error if s_logunit is a - ! file. - ! - ! It also flushes these output units. - - character(len=*), intent(in) :: error_type, message - - integer, allocatable :: log_units(:) - - integer :: i - - if (s_logunit == output_unit .or. s_logunit == error_unit) then - ! If the log unit number is standard output or standard error, just - ! print to that. - allocate(log_units(1), source=[s_logunit]) - else - ! Otherwise print the same message to both the log unit and standard - ! error. - allocate(log_units(2), source=[error_unit, s_logunit]) - end if - - do i = 1, size(log_units) - write(log_units(i),*) trim(error_type), ": ", trim(message) - flush(log_units(i)) - end do - - end subroutine print_error_to_logs - !=============================================================================== - -end module shr_abort_mod diff --git a/util/shr_log_mod.F90 b/util/shr_log_mod.F90 deleted file mode 100644 index e3b2992f6..000000000 --- a/util/shr_log_mod.F90 +++ /dev/null @@ -1,26 +0,0 @@ -!BOP =========================================================================== -! -! !MODULE: shr_log_mod -- variables and methods for logging -! -! !DESCRIPTION: -! Low-level shared variables for logging. -! -! Also, routines for generating log file messages. -! -! !INTERFACE: ------------------------------------------------------------------ -module shr_log_mod - - use shr_kind_mod - use, intrinsic :: iso_fortran_env, only: output_unit - - implicit none - private - - public :: shr_log_Level - public :: shr_log_Unit - - ! low-level shared variables for logging, these may not be parameters - integer(SHR_KIND_IN) :: shr_log_Level = 0 - integer(SHR_KIND_IN) :: shr_log_Unit = output_unit - -end module shr_log_mod diff --git a/util/shr_mem_mod.F90 b/util/shr_mem_mod.F90 deleted file mode 100644 index e8d2fc7d6..000000000 --- a/util/shr_mem_mod.F90 +++ /dev/null @@ -1,17 +0,0 @@ -module shr_mem_mod - - use shr_kind_mod, only : shr_kind_r8 - - implicit none - public - -contains - - subroutine shr_mem_getusage(r_msize, r_mrss, prt) - real(shr_kind_r8) :: r_msize,r_mrss - logical, optional :: prt - ! For now does nothing - - end subroutine shr_mem_getusage - -end module shr_mem_mod diff --git a/util/shr_mpi_mod.F90 b/util/shr_mpi_mod.F90 deleted file mode 100644 index ab872a270..000000000 --- a/util/shr_mpi_mod.F90 +++ /dev/null @@ -1,2217 +0,0 @@ -Module shr_mpi_mod - - !------------------------------------------------------------------------------- - ! PURPOSE: general layer on MPI functions - !------------------------------------------------------------------------------- - - use shr_kind_mod - use shr_log_mod, only: s_loglev => shr_log_Level - use shr_log_mod, only: s_logunit => shr_log_Unit - - implicit none - private - - ! PUBLIC: Public interfaces - - public :: shr_mpi_chkerr - public :: shr_mpi_send - public :: shr_mpi_recv - public :: shr_mpi_bcast - public :: shr_mpi_gathScatVInit - public :: shr_mpi_gatherV - public :: shr_mpi_scatterV - public :: shr_mpi_sum - public :: shr_mpi_min - public :: shr_mpi_max - public :: shr_mpi_commsize - public :: shr_mpi_commrank - public :: shr_mpi_initialized - public :: shr_mpi_abort - public :: shr_mpi_barrier - public :: shr_mpi_init - public :: shr_mpi_finalize - - interface shr_mpi_send ; module procedure & - shr_mpi_sendi0, & - shr_mpi_sendi1, & - shr_mpi_sendr0, & - shr_mpi_sendr1, & - shr_mpi_sendr3 - end interface shr_mpi_send - interface shr_mpi_recv ; module procedure & - shr_mpi_recvi0, & - shr_mpi_recvi1, & - shr_mpi_recvr0, & - shr_mpi_recvr1, & - shr_mpi_recvr3 - end interface shr_mpi_recv - interface shr_mpi_bcast ; module procedure & - shr_mpi_bcastc0, & - shr_mpi_bcastc1, & - shr_mpi_bcastl0, & - shr_mpi_bcastl1, & - shr_mpi_bcasti0, & - shr_mpi_bcasti1, & - shr_mpi_bcasti80, & - shr_mpi_bcasti81, & - shr_mpi_bcasti2, & - shr_mpi_bcastr0, & - shr_mpi_bcastr1, & - shr_mpi_bcastr2, & - shr_mpi_bcastr3 - end interface shr_mpi_bcast - interface shr_mpi_gathScatVInit ; module procedure & - shr_mpi_gathScatVInitr1 - end interface shr_mpi_gathScatVInit - interface shr_mpi_gatherv ; module procedure & - shr_mpi_gatherVr1 - end interface shr_mpi_gatherv - interface shr_mpi_scatterv ; module procedure & - shr_mpi_scatterVr1 - end interface shr_mpi_scatterv - interface shr_mpi_sum ; module procedure & - shr_mpi_sumi0, & - shr_mpi_sumi1, & - shr_mpi_sumb0, & - shr_mpi_sumb1, & - shr_mpi_sumr0, & - shr_mpi_sumr1, & - shr_mpi_sumr2, & - shr_mpi_sumr3 - end interface shr_mpi_sum - interface shr_mpi_min ; module procedure & - shr_mpi_mini0, & - shr_mpi_mini1, & - shr_mpi_minr0, & - shr_mpi_minr1 - end interface shr_mpi_min - interface shr_mpi_max ; module procedure & - shr_mpi_maxi0, & - shr_mpi_maxi1, & - shr_mpi_maxr0, & - shr_mpi_maxr1 - end interface shr_mpi_max - -#include ! mpi library include file - - !=============================================================================== -CONTAINS - !=============================================================================== - - SUBROUTINE shr_mpi_chkerr(rcode,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: rcode ! input MPI error code - character(*), intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_chkerr) ' - character(MPI_MAX_ERROR_STRING) :: lstring - integer(SHR_KIND_IN) :: len - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: layer on MPI error checking - !------------------------------------------------------------------------------- - - if (rcode /= MPI_SUCCESS) then - call MPI_ERROR_STRING(rcode,lstring,len,ierr) - write(s_logunit,*) trim(subName),":",lstring(1:len) - call shr_mpi_abort(string,rcode) - endif - - END SUBROUTINE shr_mpi_chkerr - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendi0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! send value - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendi0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a single integer - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendi1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendi1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a vector of integers - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_SEND(lvec,lsize,MPI_INTEGER,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendr0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendr0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a real scalar - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendr1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendr1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_SEND(lvec,lsize,MPI_REAL8,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sendr3(array,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real (SHR_KIND_R8), intent(in) :: array(:,:,:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to send to - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sendr3) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Send a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(array) - - call MPI_SEND(array,lsize,MPI_REAL8,pid,tag,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_sendr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvi0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(out):: lvec ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvi0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvi1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(out):: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvi1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_RECV(lvec,lsize,MPI_INTEGER,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvr0(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(out):: lvec ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvr0) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = 1 - - call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvr1(lvec,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(out):: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvr1) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(lvec) - - call MPI_RECV(lvec,lsize,MPI_REAL8,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_recvr3(array,pid,tag,comm,string) - - IMPLICIT none - - !----- arguments --- - real (SHR_KIND_R8), intent(out):: array(:,:,:) ! in/out local values - integer(SHR_KIND_IN), intent(in) :: pid ! pid to recv from - integer(SHR_KIND_IN), intent(in) :: tag ! tag - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_recvr3) ' - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: status(MPI_STATUS_SIZE) ! mpi status info - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Recv a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(array) - - call MPI_RECV(array,lsize,MPI_REAL8,pid,tag,comm,status,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_recvr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcasti0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast an integer - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti0 - - SUBROUTINE shr_mpi_bcasti80(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast an integer - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti80 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastl0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - logical, intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastl0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a logical - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastl0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastc0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - character(len=*), intent(inout) :: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastc0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a character string - !------------------------------------------------------------------------------- - - lsize = len(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastc0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastc1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - character(len=*), intent(inout) :: vec(:) ! 1D vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastc1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a character string - !------------------------------------------------------------------------------- - - lsize = size(vec)*len(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_CHARACTER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastc1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr0(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(inout):: vec ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastr0) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a real - !------------------------------------------------------------------------------- - - lsize = 1 - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcasti1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(inout):: vec(:) ! vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a vector of integers - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti1 - - SUBROUTINE shr_mpi_bcasti81(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(inout):: vec(:) ! vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcasti1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a vector of integers - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_INTEGER8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti81 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastl1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - logical, intent(inout):: vec(:) ! vector of 1 - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastl1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a logical - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_LOGICAL,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastl1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr1(vec,comm,string,pebcast) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(inout):: vec(:) ! vector - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_bcastr1) ' - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a vector of reals - !------------------------------------------------------------------------------- - - lsize = size(vec) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(vec,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr2(arr,comm,string,pebcast) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(inout):: arr(:,:) ! array, 2d - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local ----- - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_bcastr2) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a 2d array of reals - !------------------------------------------------------------------------------- - - lsize = size(arr) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr2 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcasti2(arr,comm,string,pebcast) - - IMPLICIT none - - !----- arguments ----- - integer, intent(inout):: arr(:,:) ! array, 2d - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local ----- - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_bcasti2) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a 2d array of integers - !------------------------------------------------------------------------------- - - lsize = size(arr) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(arr,lsize,MPI_INTEGER,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcasti2 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_bcastr3(arr,comm,string,pebcast) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(inout):: arr(:,:,:) ! array, 3d - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - integer(SHR_KIND_IN), optional, intent(in) :: pebcast ! bcast pe (otherwise zero) - - !----- local ----- - integer(SHR_KIND_IN) :: ierr - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: lpebcast - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_bcastr3) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Broadcast a 3d array of reals - !------------------------------------------------------------------------------- - - lsize = size(arr) - lpebcast = 0 - if (present(pebcast)) lpebcast = pebcast - - call MPI_BCAST(arr,lsize,MPI_REAL8,lpebcast,comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_bcastr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_gathScatvInitr1(comm, rootid, locArr, glob1DArr, globSize, & - displs, string ) - - IMPLICIT none - - !----- arguments ----- - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather/scatter on - real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array of distributed data - real(SHR_KIND_R8), pointer :: glob1DArr(:) ! Global 1D array of gathered data - integer(SHR_KIND_IN), pointer :: globSize(:) ! Size of each distributed piece - integer(SHR_KIND_IN), pointer :: displs(:) ! Displacements for receive - character(*),optional,intent(in) :: string ! message - - !----- local ----- - integer(SHR_KIND_IN) :: npes ! Number of MPI tasks - integer(SHR_KIND_IN) :: locSize ! Size of local distributed data - integer(SHR_KIND_IN), pointer :: sendSize(:) ! Size to send for initial gather - integer(SHR_KIND_IN) :: i ! Index - integer(SHR_KIND_IN) :: rank ! Rank of this MPI task - integer(SHR_KIND_IN) :: nSize ! Maximum size to send - integer(SHR_KIND_IN) :: ierr ! Error code - integer(SHR_KIND_IN) :: nSiz1D ! Size of 1D global array - integer(SHR_KIND_IN) :: maxSize ! Maximum size - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_gathScatvInitr1) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Setup arrays for a gatherv/scatterv operation - !------------------------------------------------------------------------------- - - locSize = size(locarr) - call shr_mpi_commsize( comm, npes ) - call shr_mpi_commrank( comm, rank ) - allocate( globSize(npes) ) - ! - ! --- Gather the send global sizes from each MPI task ----------------------- - ! - allocate( sendSize(npes) ) - sendSize(:) = 1 - globSize(:) = 1 - call MPI_GATHER( locSize, 1, MPI_INTEGER, globSize, sendSize, & - MPI_INTEGER, rootid, comm, ierr ) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - deallocate( sendSize ) - ! - ! --- Prepare the displacement and allocate arrays ------------------------- - ! - allocate( displs(npes) ) - displs(1) = 0 - if ( rootid /= rank )then - maxSize = 1 - globSize = 1 - else - maxSize = maxval(globSize) - end if - nsiz1D = min(maxSize,globSize(1)) - do i = 2, npes - nSize = min(maxSize,globSize(i-1)) - displs(i) = displs(i-1) + nSize - nsiz1D = nsiz1D + min(maxSize,globSize(i)) - end do - allocate( glob1DArr(nsiz1D) ) - !----- Do some error checking for the root task arrays computed ---- - if ( rootid == rank )then - if ( nsiz1D /= sum(globSize) ) & - call shr_mpi_abort( subName//" : Error, size of global array not right" ) - if ( any(displs < 0) .or. any(displs >= nsiz1D) ) & - call shr_mpi_abort( subName//" : Error, displacement array not right" ) - if ( (displs(npes)+globSize(npes)) /= nsiz1D ) & - call shr_mpi_abort( subName//" : Error, displacement array values too big" ) - end if - - END SUBROUTINE shr_mpi_gathScatvInitr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_gathervr1(locarr, locSize, glob1DArr, globSize, displs, rootid, & - comm, string ) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(in) :: locArr(:) ! Local array - real(SHR_KIND_R8), intent(inout):: glob1DArr(:) ! Global 1D array to receive in on - integer(SHR_KIND_IN), intent(in) :: locSize ! Number to send this PE - integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to receive each PE - integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for receive - integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to gather on - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local ----- - integer(SHR_KIND_IN) :: ierr ! Error code - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_gathervr1) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Gather a 1D array of reals - !------------------------------------------------------------------------------- - - call MPI_GATHERV( locarr, locSize, MPI_REAL8, glob1Darr, globSize, displs, & - MPI_REAL8, rootid, comm, ierr ) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_gathervr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_scattervr1(locarr, locSize, glob1Darr, globSize, displs, rootid, & - comm, string ) - - IMPLICIT none - - !----- arguments ----- - real(SHR_KIND_R8), intent(out) :: locarr(:) ! Local array - real(SHR_KIND_R8), intent(in) :: glob1Darr(:) ! Global 1D array to send from - integer(SHR_KIND_IN), intent(in) :: locSize ! Number to receive this PE - integer(SHR_KIND_IN), intent(in) :: globSize(:) ! Number to send to each PE - integer(SHR_KIND_IN), intent(in) :: displs(:) ! Displacements for send - integer(SHR_KIND_IN), intent(in) :: rootid ! MPI task to scatter on - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - - !----- local ----- - integer(SHR_KIND_IN) :: ierr ! Error code - - !----- formats ----- - character(*),parameter :: subName = '(shr_mpi_scattervr1) ' - - !------------------------------------------------------------------------------- - ! PURPOSE: Scatter a 1D array of reals - !------------------------------------------------------------------------------- - - - call MPI_SCATTERV( glob1Darr, globSize, displs, MPI_REAL8, locarr, locSize, & - MPI_REAL8, rootid, comm, ierr ) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_scattervr1 - - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumi0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumi0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumi1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumi1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumb0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_I8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumb0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumb0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumb1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_I8), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_I8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumb1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumb1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr2(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:,:)! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:,:)! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr2) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr2 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_sumr3(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:,:,:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:,:,:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_sumr3) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds sum of a distributed vector of values, assume local sum - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_SUM - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_sumr3 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_mini0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_mini0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_mini0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_mini1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_mini1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_mini1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_minr0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_minr0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_minr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_minr1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_minr1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds min of a distributed vector of values, assume local min - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MIN - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_minr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxi0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxi0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxi0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxi1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - integer(SHR_KIND_IN), intent(in) :: lvec(:) ! in/out local values - integer(SHR_KIND_IN), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxi1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_INTEGER,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxi1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxr0(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxr0) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = 1 - gsize = 1 - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxr0 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_maxr1(lvec,gvec,comm,string,all) - - IMPLICIT none - - !----- arguments --- - real(SHR_KIND_R8), intent(in) :: lvec(:) ! in/out local values - real(SHR_KIND_R8), intent(out):: gvec(:) ! in/out global values - integer(SHR_KIND_IN), intent(in) :: comm ! mpi communicator - character(*),optional,intent(in) :: string ! message - logical, optional,intent(in) :: all ! allreduce if true - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_maxr1) ' - logical :: lall - character(SHR_KIND_CL) :: lstring - integer(SHR_KIND_IN) :: reduce_type ! mpi reduction type - integer(SHR_KIND_IN) :: lsize - integer(SHR_KIND_IN) :: gsize - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: Finds max of a distributed vector of values, assume local max - ! already computed - !------------------------------------------------------------------------------- - - reduce_type = MPI_MAX - if (present(all)) then - lall = all - else - lall = .false. - endif - if (present(string)) then - lstring = trim(subName)//":"//trim(string) - else - lstring = trim(subName) - endif - - lsize = size(lvec) - gsize = size(gvec) - - if (lsize /= gsize) then - call shr_mpi_abort(subName//" lsize,gsize incompatable "//trim(string)) - endif - - if (lall) then - call MPI_ALLREDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_ALLREDUCE") - else - call MPI_REDUCE(lvec,gvec,gsize,MPI_REAL8,reduce_type,0,comm,ierr) - call shr_mpi_chkerr(ierr,trim(lstring)//" MPI_REDUCE") - endif - - END SUBROUTINE shr_mpi_maxr1 - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_commsize(comm,size,string) - - IMPLICIT none - - !----- arguments --- - integer,intent(in) :: comm - integer,intent(out) :: size - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_commsize) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI commsize - !------------------------------------------------------------------------------- - - call MPI_COMM_SIZE(comm,size,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_commsize - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_commrank(comm,rank,string) - - IMPLICIT none - - !----- arguments --- - integer,intent(in) :: comm - integer,intent(out) :: rank - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_commrank) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI commrank - !------------------------------------------------------------------------------- - - call MPI_COMM_RANK(comm,rank,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_commrank - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_initialized(flag,string) - - IMPLICIT none - - !----- arguments --- - logical,intent(out) :: flag - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_initialized) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI initialized - !------------------------------------------------------------------------------- - - call MPI_INITIALIZED(flag,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_initialized - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_abort(string,rcode) - - IMPLICIT none - - !----- arguments --- - character(*),optional,intent(in) :: string ! message - integer,optional,intent(in) :: rcode ! optional code - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_abort) ' - integer(SHR_KIND_IN) :: ierr - integer :: rc ! return code - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI abort - !------------------------------------------------------------------------------- - - if ( present(string) .and. present(rcode) ) then - write(s_logunit,*) trim(subName),":",trim(string),rcode - endif - if ( present(rcode) )then - rc = rcode - else - rc = 1001 - end if - call MPI_ABORT(MPI_COMM_WORLD,rc,ierr) - - END SUBROUTINE shr_mpi_abort - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_barrier(comm,string) - - IMPLICIT none - - !----- arguments --- - integer,intent(in) :: comm - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_barrier) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI barrier - !------------------------------------------------------------------------------- - - call MPI_BARRIER(comm,ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_barrier - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_init(string) - - IMPLICIT none - - !----- arguments --- - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_init) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI init - !------------------------------------------------------------------------------- - - call MPI_INIT(ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_init - - !=============================================================================== - !=============================================================================== - - SUBROUTINE shr_mpi_finalize(string) - - IMPLICIT none - - !----- arguments --- - character(*),optional,intent(in) :: string ! message - - !----- local --- - character(*),parameter :: subName = '(shr_mpi_finalize) ' - integer(SHR_KIND_IN) :: ierr - - !------------------------------------------------------------------------------- - ! PURPOSE: MPI finalize - !------------------------------------------------------------------------------- - - call MPI_BARRIER(MPI_COMM_WORLD,ierr) - call MPI_FINALIZE(ierr) - if (present(string)) then - call shr_mpi_chkerr(ierr,subName//trim(string)) - else - call shr_mpi_chkerr(ierr,subName) - endif - - END SUBROUTINE shr_mpi_finalize - - !=============================================================================== - !=============================================================================== - -END MODULE shr_mpi_mod diff --git a/util/shr_sys_mod.F90 b/util/shr_sys_mod.F90 deleted file mode 100644 index 5a04d6653..000000000 --- a/util/shr_sys_mod.F90 +++ /dev/null @@ -1,320 +0,0 @@ -!=============================================================================== -! SVN $Id: shr_sys_mod.F90 66411 2014-12-19 22:40:08Z santos@ucar.edu $ -! SVN $URL: https://svn-ccsm-models.cgd.ucar.edu/csm_share/trunk_tags/share3_150116/shr/shr_sys_mod.F90 $ -!=============================================================================== - -! Currently supported by all compilers -#define HAVE_GET_ENVIRONMENT -#define HAVE_SLEEP - -! Except this combination? -#if defined CPRPGI && defined CNL -#undef HAVE_GET_ENVIRONMENT -#endif - -#if defined CPRNAG -#define HAVE_EXECUTE -#endif - -MODULE shr_sys_mod - - use shr_kind_mod ! defines real & integer kinds - use shr_log_mod, only: s_loglev => shr_log_Level - use shr_log_mod, only: s_logunit => shr_log_Unit - use shr_abort_mod, only: shr_sys_abort => shr_abort_abort - use shr_abort_mod, only: shr_sys_backtrace => shr_abort_backtrace - -#ifdef CPRNAG - ! NAG does not provide these as intrinsics, but it does provide modules - ! that implement commonly used POSIX routines. - use f90_unix_dir, only: chdir - use f90_unix_proc, only: abort, sleep -#endif - - implicit none - -! PUBLIC: Public interfaces - - private - - public :: shr_sys_system ! make a system call - public :: shr_sys_chdir ! change current working dir - public :: shr_sys_getenv ! get an environment variable - public :: shr_sys_irtc ! returns real-time clock tick - public :: shr_sys_sleep ! have program sleep for a while - public :: shr_sys_flush ! flush an i/o buffer - - ! Imported from shr_abort_mod and republished with renames. Other code that wishes to - ! use these routines should use these shr_sys names rather than directly using the - ! routines from shr_abort_abort. (This is for consistency with older code, from when - ! these routines were defined in shr_sys_mod.) - public :: shr_sys_abort ! abort a program - public :: shr_sys_backtrace ! print a backtrace, if possible - -!=============================================================================== -CONTAINS -!=============================================================================== - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_system(str,rcode) - - IMPLICIT none - - !----- arguments --- - character(*) ,intent(in) :: str ! system/shell command string - integer(SHR_KIND_IN),intent(out) :: rcode ! function return error code - - !----- functions ----- -#if (defined LINUX && !defined CPRGNU) - integer(SHR_KIND_IN),external :: system ! function to envoke shell command -#endif - - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_system) ' - character(*),parameter :: F00 = "('(shr_sys_system) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -!------------------------------------------------------------------------------- - rcode = 0 -#ifdef HAVE_EXECUTE - call execute_command_line(str,exitstat=rcode) ! Intrinsic as of F2008 -#else -#if (defined AIX) - - call system(str,rcode) - -#elif (defined CPRGNU || defined LINUX) - - rcode = system(str) - -#else - - write(s_logunit,F00) 'ERROR: no implementation of system call for this architecture' - call shr_sys_abort(subName//'no implementation of system call for this architecture') -#endif -#endif - -END SUBROUTINE shr_sys_system - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_chdir(path, rcode) - - IMPLICIT none - - !----- arguments ----- - character(*) ,intent(in) :: path ! chdir to this dir - integer(SHR_KIND_IN),intent(out) :: rcode ! return code - - !----- local ----- - integer(SHR_KIND_IN) :: lenpath ! length of path -#if (defined AIX || (defined LINUX && !defined CPRGNU && !defined CPRNAG) || defined CPRINTEL) - integer(SHR_KIND_IN),external :: chdir ! AIX system call -#endif - - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_chdir) ' - character(*),parameter :: F00 = "('(shr_sys_chdir) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -!------------------------------------------------------------------------------- - - lenpath=len_trim(path) - -#if (defined AIX) - - rcode = chdir(%ref(path(1:lenpath)//'\0')) - -#elif (defined Darwin || (defined LINUX && !defined CPRNAG)) - - rcode=chdir(path(1:lenpath)) - -#elif (defined CPRNAG) - - call chdir(path(1:lenpath), errno=rcode) - -#else - - write(s_logunit,F00) 'ERROR: no implementation of chdir for this architecture' - call shr_sys_abort(subname//'no implementation of chdir for this machine') - -#endif - -END SUBROUTINE shr_sys_chdir - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_getenv(name, val, rcode) - - IMPLICIT none - - !----- arguments ----- - character(*) ,intent(in) :: name ! env var name - character(*) ,intent(out) :: val ! env var value - integer(SHR_KIND_IN),intent(out) :: rcode ! return code - - !----- local ----- -#ifndef HAVE_GET_ENVIRONMENT - integer(SHR_KIND_IN) :: lenname ! length of env var name - integer(SHR_KIND_IN) :: lenval ! length of env var value - character(SHR_KIND_CL) :: tmpval ! temporary env var value -#endif - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_getenv) ' - character(*),parameter :: F00 = "('(shr_sys_getenv) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -!------------------------------------------------------------------------------- - -!$OMP master - - -#ifdef HAVE_GET_ENVIRONMENT - call get_environment_variable(name=name,value=val,status=rcode) ! Intrinsic in F2003 -#else - lenname=len_trim(name) -#if (defined AIX || defined LINUX) - - call getenv(trim(name),tmpval) - val=trim(tmpval) - rcode = 0 - if (len_trim(val) == 0 ) rcode = 1 - if (len_trim(val) > SHR_KIND_CL) rcode = 2 - -#else - - write(s_logunit,F00) 'ERROR: no implementation of getenv for this architecture' - call shr_sys_abort(subname//'no implementation of getenv for this machine') - -#endif -#endif -!$OMP end master - -END SUBROUTINE shr_sys_getenv - -!=============================================================================== -!=============================================================================== - -integer(SHR_KIND_I8) FUNCTION shr_sys_irtc( rate ) - - IMPLICIT none - - !----- arguments ----- - integer(SHR_KIND_I8), optional :: rate - - !----- local ----- - integer(SHR_KIND_IN) :: count - integer(SHR_KIND_IN) :: count_rate - integer(SHR_KIND_IN) :: count_max - integer(SHR_KIND_IN),save :: last_count = -1 - integer(SHR_KIND_I8),save :: count_offset = 0 - - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_irtc) ' - character(*),parameter :: F00 = "('(shr_sys_irtc) ',4a)" - -!------------------------------------------------------------------------------- -! emulates Cray/SGI irtc function (returns clock tick since last reboot) -!------------------------------------------------------------------------------- - - call system_clock(count=count,count_rate=count_rate, count_max=count_max) - if ( present(rate) ) rate = count_rate - shr_sys_irtc = count - - !--- adjust for clock wrap-around --- - if ( last_count /= -1 ) then - if ( count < last_count ) count_offset = count_offset + count_max - end if - shr_sys_irtc = shr_sys_irtc + count_offset - last_count = count - -END FUNCTION shr_sys_irtc - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_sleep(sec) - - IMPLICIT none - - !----- arguments ----- - real (SHR_KIND_R8),intent(in) :: sec ! number of seconds to sleep - - !----- local ----- - integer(SHR_KIND_IN) :: isec ! integer number of seconds -#ifndef HAVE_SLEEP - integer(SHR_KIND_IN) :: rcode ! return code - character(90) :: str ! system call string -#endif - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_sleep) ' - character(*),parameter :: F00 = "('(shr_sys_sleep) ',4a)" - character(*),parameter :: F10 = "('sleep ',i8 )" - -!------------------------------------------------------------------------------- -! PURPOSE: Sleep for approximately sec seconds -!------------------------------------------------------------------------------- - - isec = nint(sec) - - if (isec < 0) then - if (s_loglev > 0) write(s_logunit,F00) 'ERROR: seconds must be > 0, sec=',sec - else if (isec == 0) then - ! Don't consider this an error and don't call system sleep - else -#ifdef HAVE_SLEEP - call sleep(isec) -#else - write(str,FMT=F10) isec - call shr_sys_system( str, rcode ) -#endif - endif - -END SUBROUTINE shr_sys_sleep - -!=============================================================================== -!=============================================================================== - -SUBROUTINE shr_sys_flush(unit) - - IMPLICIT none - - !----- arguments ----- - integer(SHR_KIND_IN) :: unit ! flush output buffer for this unit - - !----- local ----- - !----- formats ----- - character(*),parameter :: subName = '(shr_sys_flush) ' - character(*),parameter :: F00 = "('(shr_sys_flush) ',4a)" - -!------------------------------------------------------------------------------- -! PURPOSE: an architecture independent system call -! -! This is probably no longer needed; the "flush" statement is supported by -! all compilers that CESM supports for years now. -! -!------------------------------------------------------------------------------- - flush(unit) -! -! The following code was originally present, but there's an obvious issue. -! Since shr_sys_flush is usually used to flush output to a log, when it -! returns an error, does it do any good to print that error to the log? -! -! if (ierr > 0) then -! write(s_logunit,*) subname,' Flush reports error: ',ierr -! endif -! - -END SUBROUTINE shr_sys_flush - -!=============================================================================== -!=============================================================================== - -END MODULE shr_sys_mod