diff --git a/.github/workflows/extbuild.yml b/.github/workflows/extbuild.yml
new file mode 100644
index 000000000..0c086e380
--- /dev/null
+++ b/.github/workflows/extbuild.yml
@@ -0,0 +1,106 @@
+# This is a workflow to compile the cdeps source without cime
+name: extbuild
+
+# Controls when the action will run. Triggers the workflow on push or pull request
+# events but only for the master branch
+on:
+ push:
+ branches: [ master ]
+ pull_request:
+ branches: [ master ]
+
+# A workflow run is made up of one or more jobs that can run sequentially or in parallel
+jobs:
+ build-cmeps:
+ runs-on: ubuntu-latest
+ env:
+ CC: mpicc
+ FC: mpifort
+ CXX: mpicxx
+ CPPFLAGS: "-I/usr/include -I/usr/local/include"
+ # Versions of all dependencies can be updated here
+ ESMF_VERSION: ESMF_8_1_0_beta_snapshot_31
+ PNETCDF_VERSION: pnetcdf-1.12.1
+ NETCDF_FORTRAN_VERSION: v4.5.2
+ # PIO version is awkward
+ PIO_VERSION_DIR: pio2_5_2
+ PIO_VERSION: pio-2.5.2
+ steps:
+ - uses: actions/checkout@v2
+ # Build the ESMF library, if the cache contains a previous build
+ # it will be used instead
+ - id: cache-esmf
+ uses: actions/cache@v2
+ with:
+ path: ~/ESMF
+ key: ${{ runner.os }}-${{ env.ESMF_VERSION }}-ESMF
+ - id: load-env
+ run: sudo apt-get install gfortran wget openmpi-bin netcdf-bin libopenmpi-dev libnetcdf-dev
+ - id: build-ESMF
+ if: steps.cache-esmf.outputs.cache-hit != 'true'
+ run: |
+ wget https://github.com/esmf-org/esmf/archive/${{ env.ESMF_VERSION }}.tar.gz
+ tar -xzvf ${{ env.ESMF_VERSION }}.tar.gz
+ pushd esmf-${{ env.ESMF_VERSION }}
+ export ESMF_DIR=`pwd`
+ export ESMF_COMM=openmpi
+ export ESMF_YAMLCPP="internal"
+ export ESMF_INSTALL_PREFIX=$HOME/ESMF
+ export ESMF_BOPT=g
+ make
+ make install
+ popd
+ - id: cache-pnetcdf
+ uses: actions/cache@v2
+ with:
+ path: ~/pnetcdf
+ key: ${{ runner.os }}-${{ env.PNETCDF_VERSION}}-pnetcdf
+ - 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
+ - name: netcdf fortran build
+ if: steps.cache-netcdf-fortran.outputs.cache-hit != 'true'
+ run: |
+ 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: Build PIO
+ if: steps.cache-PIO.outputs.cache-hit != 'true'
+ run: |
+ git submodule init
+ git submodule update
+ mkdir build-pio
+ pushd build-pio
+ cmake -Wno-dev -DNetCDF_C_LIBRARY=/usr/lib/x86_64-linux-gnu/libnetcdf.so -DNetCDF_C_INCLUDE_DIR=/usr/include -DCMAKE_PREFIX_PATH=/usr -DCMAKE_INSTALL_PREFIX=$HOME/pio -DPIO_HDF5_LOGGING=On -DPIO_USE_MALLOC=On -DPIO_ENABLE_LOGGING=On -DPIO_ENABLE_TIMING=Off -DPIO_ENABLE_TESTS=OFF -DNetCDF_Fortran_PATH=$HOME/netcdf-fortran -DPnetCDF_PATH=$HOME/pnetcdf ../nems/lib/ParallelIO
+ make VERBOSE=1
+ make install
+ popd
+
+ - name: Build CMEPS
+ run: |
+ export ESMFMKFILE=$HOME/ESMF/lib/libg/Linux.gfortran.64.openmpi.default/esmf.mk
+ export PIO=$HOME/pio
+ mkdir build-cmeps
+ pushd build-cmeps
+ cmake -DCMAKE_BUILD_TYPE=DEBUG -DCMAKE_Fortran_FLAGS="-g -Wall -ffree-form -ffree-line-length-none" ../
+ make VERBOSE=1
+ popd
diff --git a/.travis.yml b/.travis.yml
index 386d2310a..0a14a61ba 100644
--- a/.travis.yml
+++ b/.travis.yml
@@ -6,9 +6,10 @@ install:
python:
- '2.7'
- '3.6'
+ - '3.8'
branches:
only:
- master
-script: ./tcipylint
\ No newline at end of file
+script: ./tcipylint
diff --git a/Makefile b/Makefile
index 169bf8228..0f9eb808a 100644
--- a/Makefile
+++ b/Makefile
@@ -19,6 +19,11 @@ ifndef CXX
$(error CXX not defined)
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)/nems/util/libcmeps_util.a
@@ -48,7 +53,7 @@ endif
$(LIBRARY_MEDIATOR): $(LIBRARY_UTIL) .FORCE
cd mediator ;\
- exec $(MAKE) INTERNAL_PIO_INIT=1
+ exec $(MAKE) PIO_INCLUDE_DIR=$(PIO_INCLUDE_DIR) INTERNAL_PIO_INIT=$(INTERNAL_PIO_INIT)
$(LIBRARY_UTIL): .FORCE
cd nems/util ;\
diff --git a/cime_config/buildexe b/cime_config/buildexe
index 211d2b6d1..ed5b04459 100755
--- a/cime_config/buildexe
+++ b/cime_config/buildexe
@@ -6,7 +6,10 @@ build model executable
import sys, os
-_CIMEROOT = os.path.join(os.path.dirname(os.path.abspath(__file__)), "..","..","..","..")
+_CIMEROOT = os.environ.get("CIMEROOT")
+if _CIMEROOT is None:
+ raise SystemExit("ERROR: must set CIMEROOT environment variable")
+
sys.path.append(os.path.join(_CIMEROOT, "scripts", "Tools"))
from standard_script_setup import *
@@ -28,7 +31,6 @@ def _main_func():
with Case(caseroot) as case:
casetools = case.get_value("CASETOOLS")
- cimeroot = case.get_value("CIMEROOT")
exeroot = case.get_value("EXEROOT")
gmake = case.get_value("GMAKE")
gmake_j = case.get_value("GMAKE_J")
@@ -37,7 +39,6 @@ def _main_func():
ocn_model = case.get_value("COMP_OCN")
atm_model = case.get_value("COMP_ATM")
gmake_args = get_standard_makefile_args(case)
- blddir = os.path.join(case.get_value("EXEROOT"),"cpl","obj")
# Determine valid components
valid_comps = []
@@ -50,7 +51,7 @@ def _main_func():
if valid:
valid_comps.append(item)
- datamodel_in_compset = False
+ datamodel_in_compset = False
for comp in comp_classes:
dcompname = "d"+comp.lower()
if dcompname in case.get_value("COMP_{}".format(comp)):
@@ -81,10 +82,12 @@ def _main_func():
os.makedirs(bld_root)
with open(os.path.join(bld_root,'Filepath'), 'w') as out:
- if not skip_mediator:
- out.write(os.path.join(cimeroot, "src", "drivers", "nuopc", "mediator") + "\n")
+ cmeps_dir = os.path.join(os.path.dirname(__file__), os.pardir)
+ # SourceMods dir needs to be first listed
out.write(os.path.join(caseroot, "SourceMods", "src.drv") + "\n")
- out.write(os.path.join(cimeroot, "src", "drivers", "nuopc", "drivers", "cime") + "\n")
+ if not skip_mediator:
+ out.write(os.path.join(cmeps_dir, "mediator") + "\n")
+ out.write(os.path.join(cmeps_dir, "drivers", "cime") + "\n")
# build model executable
makefile = os.path.join(casetools, "Makefile")
diff --git a/cime_config/buildnml b/cime_config/buildnml
index 13cf826db..9d18d7136 100755
--- a/cime_config/buildnml
+++ b/cime_config/buildnml
@@ -3,7 +3,10 @@
"""
import os, sys
-_CIMEROOT = os.path.join(os.path.dirname(os.path.abspath(__file__)), "..","..","..","..")
+_CIMEROOT = os.environ.get("CIMEROOT")
+if _CIMEROOT is None:
+ raise SystemExit("ERROR: must set CIMEROOT environment variable")
+
sys.path.append(os.path.join(_CIMEROOT, "scripts", "Tools"))
import shutil, glob, itertools
@@ -237,7 +240,7 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files):
valid_comps.append(item)
# Determine if there are any data components in the compset
- datamodel_in_compset = False
+ datamodel_in_compset = False
comp_classes = case.get_values("COMP_CLASSES")
for comp in comp_classes:
dcompname = "d"+comp.lower()
@@ -248,14 +251,12 @@ def _create_drv_namelists(case, infile, confdir, nmlgen, files):
# driver rpointer file if there is only one non-stub component then skip mediator
if len(valid_comps) == 2 and not datamodel_in_compset:
# skip the mediator if there is a prognostic component and all other components are stub
- skip_mediator = True
valid_comps.remove("CPL")
nmlgen.set_value('mediator_present', value='.false.')
nmlgen.set_value("drv_restart_pointer", value="none")
nmlgen.set_value("component_list", value=" ".join(valid_comps))
else:
# do not skip mediator if there is a data component but all other components are stub
- skip_mediator = False
nmlgen.set_value("drv_restart_pointer", value="rpointer.cpl")
valid_comps_string = " ".join(valid_comps)
nmlgen.set_value("component_list", value=valid_comps_string.replace("CPL","MED"))
@@ -392,7 +393,7 @@ def _create_runseq(case, coupling_times, valid_comps):
comp_lnd = case.get_value("COMP_LND")
comp_ocn = case.get_value("COMP_OCN")
- sys.path.append(os.path.join(_CIMEROOT, "src", "drivers", "nuopc", "cime_config", "runseq"))
+ sys.path.append(os.path.join(os.path.dirname(__file__), "runseq"))
if (comp_ice == "cice" and comp_atm == 'datm' and comp_ocn == "docn"):
from runseq_D import gen_runseq
@@ -564,14 +565,13 @@ def buildnml(case, caseroot, component):
shutil.copy(filename, rundir)
# copy fd_cesm.yaml to rundir
- cimeroot = case.get_value("CIMEROOT")
- fd_dir = os.path.join(cimeroot, "src","drivers","nuopc","mediator")
+ fd_dir = os.path.join(os.path.dirname(__file__),os.pardir,"mediator")
coupling_mode = case.get_value('COUPLING_MODE')
if coupling_mode == 'cesm':
filename = os.path.join(fd_dir,"fd_cesm.yaml")
elif coupling_mode == 'hafs':
filename = os.path.join(fd_dir,"fd_hafs.yaml")
- elif coupling_mode == 'nems':
+ elif 'nems' in coupling_mode:
filename = os.path.join(fd_dir,"fd_nems.yaml")
else:
expect(False, "coupling mode currently only supports cesm, hafs and nems")
diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml
index 036930492..dbffe661f 100644
--- a/cime_config/config_component.xml
+++ b/cime_config/config_component.xml
@@ -28,7 +28,7 @@
char
- cesm,nems_orig_active,nems_orig_data,nems_frac,hafs
+ cesm,nems_orig,nems_orig_data,nems_frac,hafs
cesm
run_coupling
env_run.xml
@@ -987,9 +987,9 @@
env_run.xml
Determines what ESMF log files (if any) are generated when
- USE_ESMF_LIB is TRUE.
+ USE_ESMF_LIB is TRUE.
ESMF_LOGKIND_SINGLE: Use a single log file, combining messages from
- all of the PETs. Not supported on some platforms.
+ all of the PETs. Not supported on some platforms.
ESMF_LOGKIND_MULTI: Use multiple log files -- one per PET.
ESMF_LOGKIND_NONE: Do not issue messages to a log file.
By default, no ESMF log files are generated.
@@ -2018,7 +2018,7 @@
pio rearranger communication max pending requests (io2comp) :
-2 implies that CIME internally calculates the value ( = 64),
-1 implies no bound on max pending requests
- 0 implies that MPI_ALLTOALL will be used
+ 0 implies that MPI_ALLTOALL will be used
@@ -2600,7 +2600,7 @@
-
+
diff --git a/cime_config/runseq/runseq_general.py b/cime_config/runseq/runseq_general.py
index 8a7126ab5..e0a4cfb36 100644
--- a/cime_config/runseq/runseq_general.py
+++ b/cime_config/runseq/runseq_general.py
@@ -18,8 +18,10 @@ def gen_runseq(case, coupling_times):
rundir = case.get_value("RUNDIR")
caseroot = case.get_value("CASEROOT")
cpl_seq_option = case.get_value('CPL_SEQ_OPTION')
- cpl_add_aoflux = case.get_value('ADD_AOFLUX_TO_RUNSEQ')
coupling_mode = case.get_value('COUPLING_MODE')
+ diag_mode = case.get_value('BUDGETS')
+ xcompset = case.get_value("COMP_ATM") == 'xatm'
+ cpl_add_aoflux = not xcompset and case.get_value('ADD_AOFLUX_TO_RUNSEQ')
# It is assumed that if a component will be run it will send information to the mediator
# so the flags run_xxx and xxx_to_med are redundant
@@ -33,6 +35,7 @@ def gen_runseq(case, coupling_times):
run_rof, med_to_rof, rof_cpl_time = driver_config['rof']
run_wav, med_to_wav, wav_cpl_time = driver_config['wav']
+
# Note: assume that atm_cpl_dt, lnd_cpl_dt, ice_cpl_dt and wav_cpl_dt are the same
if lnd_cpl_time != atm_cpl_time:
@@ -88,11 +91,12 @@ def gen_runseq(case, coupling_times):
runseq.add_action("MED med_phases_aofluxes_run" , run_ocn and run_atm and (med_to_ocn or med_to_atm))
runseq.add_action("MED med_phases_prep_ocn_merge" , med_to_ocn)
runseq.add_action("MED med_phases_prep_ocn_accum_fast" , med_to_ocn)
- runseq.add_action("MED med_phases_ocnalb_run" , run_ocn and run_atm and (med_to_ocn or med_to_atm))
+ runseq.add_action("MED med_phases_ocnalb_run" , (run_ocn and run_atm and (med_to_ocn or med_to_atm)) and not xcompset)
runseq.add_action("MED med_phases_prep_lnd" , med_to_lnd)
runseq.add_action("MED -> LND :remapMethod=redist" , med_to_lnd)
runseq.add_action("MED med_phases_prep_ice" , med_to_ice)
runseq.add_action("MED -> ICE :remapMethod=redist" , med_to_ice)
+ runseq.add_action("MED med_phases_diag_ice_med2ice" , run_ice and diag_mode)
runseq.add_action("MED med_phases_prep_wav" , med_to_wav)
runseq.add_action("MED -> WAV :remapMethod=redist" , med_to_wav)
runseq.add_action("MED med_phases_prep_rof_avg" , med_to_rof and not rof_outer_loop)
@@ -114,10 +118,13 @@ def gen_runseq(case, coupling_times):
runseq.add_action("MED med_phases_aofluxes_run" , run_ocn and run_atm)
runseq.add_action("MED med_phases_prep_ocn_merge" , med_to_ocn)
runseq.add_action("MED med_phases_prep_ocn_accum_fast" , med_to_ocn)
- runseq.add_action("MED med_phases_ocnalb_run" , run_ocn and run_atm)
+ runseq.add_action("MED med_phases_ocnalb_run" , (run_ocn and run_atm) and not xcompset)
+ runseq.add_action("MED med_phases_diag_ocn" , run_ocn and diag_mode and not ocn_outer_loop)
runseq.add_action("LND -> MED :remapMethod=redist" , run_lnd)
runseq.add_action("ICE -> MED :remapMethod=redist" , run_ice)
+ runseq.add_action("MED med_phases_diag_ice_ice2med" , run_ice and diag_mode)
runseq.add_action("MED med_fraction_set" , run_ice)
+
runseq.add_action("MED med_phases_prep_rof_accum" , med_to_rof)
runseq.add_action("MED med_phases_prep_glc_accum" , med_to_glc)
runseq.add_action("MED med_phases_prep_atm" , med_to_atm)
@@ -126,17 +133,24 @@ def gen_runseq(case, coupling_times):
runseq.add_action("ATM -> MED :remapMethod=redist" , run_atm)
runseq.add_action("WAV -> MED :remapMethod=redist" , run_wav)
runseq.add_action("ROF -> MED :remapMethod=redist" , run_rof and not rof_outer_loop)
-
+ runseq.add_action("MED med_phases_diag_atm" , run_atm and diag_mode)
+ runseq.add_action("MED med_phases_diag_lnd" , run_lnd and diag_mode)
+ runseq.add_action("MED med_phases_diag_rof" , run_rof and diag_mode)
+ runseq.add_action("MED med_phases_diag_glc" , run_glc and diag_mode)
+ runseq.add_action("MED med_phases_diag_accum" , diag_mode)
+ runseq.add_action("MED med_phases_diag_print" , diag_mode)
#------------------
runseq.leave_time_loop(inner_loop)
#------------------
runseq.add_action("OCN" , run_ocn and ocn_outer_loop)
+
if coupling_mode == 'hafs':
runseq.add_action("OCN -> MED :remapMethod=redist:ignoreUnmatchedIndices=true" , run_ocn and ocn_outer_loop)
else:
runseq.add_action("OCN -> MED :remapMethod=redist" , run_ocn and ocn_outer_loop)
+
#------------------
runseq.leave_time_loop(ocn_outer_loop)
#------------------
diff --git a/cime_config/testdefs/testlist_drv.xml b/cime_config/testdefs/testlist_drv.xml
index 01b4a9691..ad1d2514d 100644
--- a/cime_config/testdefs/testlist_drv.xml
+++ b/cime_config/testdefs/testlist_drv.xml
@@ -165,6 +165,14 @@
+
+
+
+
+
+
+
+
@@ -464,18 +472,18 @@
-
-
-
+
+
+
-
-
-
+
+
+
diff --git a/drivers/cime/esm_time_mod.F90 b/drivers/cime/esm_time_mod.F90
index 3554394d7..72b246ccd 100644
--- a/drivers/cime/esm_time_mod.F90
+++ b/drivers/cime/esm_time_mod.F90
@@ -130,8 +130,6 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert
call NUOPC_CompAttributeGet(instance_driver, name='drv_restart_pointer', value=restart_file, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- write(6,*)'DEBUG: restart_file = ',trim(restart_file)
-
if (trim(restart_file) /= 'none') then
call NUOPC_CompAttributeGet(instance_driver, name="inst_suffix", isPresent=isPresent, rc=rc)
@@ -144,7 +142,6 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert
endif
restart_pfile = trim(restart_file)//inst_suffix
- write(6,*)'DEBUG: restart_pfile = ',restart_pfile
if (mastertask) then
call ESMF_LogWrite(trim(subname)//" read rpointer file = "//trim(restart_pfile), &
@@ -170,8 +167,6 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert
call esm_time_read_restart(restart_file, start_ymd, start_tod, curr_ymd, curr_tod, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- write(6,*)'DEBUG: curr_ymd = ',curr_ymd
- write(6,*)'DEBUG: curr_tod = ',curr_tod
tmp(1) = start_ymd ; tmp(2) = start_tod
tmp(3) = curr_ymd ; tmp(4) = curr_tod
endif
@@ -185,7 +180,7 @@ subroutine esm_time_clockInit(ensemble_driver, instance_driver, logunit, mastert
if (mastertask) then
write(logunit,*) ' NOTE: the current compset has no mediator - which provides the clock restart information'
- write(logunit,*) ' In this case the restarts are handled solely by the component being used and'
+ write(logunit,*) ' In this case the restarts are handled solely by the component being used and'
write(logunit,*) ' and the driver clock will always be starting from the initial date on restart'
end if
curr_ymd = start_ymd
@@ -650,8 +645,7 @@ subroutine esm_time_read_restart(restart_file, start_ymd, start_tod, curr_ymd, c
! use netcdf here since it's serial
status = nf90_open(restart_file, NF90_NOWRITE, ncid)
if (status /= nf90_NoErr) then
- print *,__FILE__,__LINE__,trim(restart_file)
- call ESMF_LogWrite(trim(subname)//' ERROR: nf90_open', ESMF_LOGMSG_INFO)
+ call ESMF_LogWrite(trim(subname)//' ERROR: nf90_open: '//trim(restart_file), ESMF_LOGMSG_INFO)
rc = ESMF_FAILURE
return
endif
diff --git a/mediator/Makefile b/mediator/Makefile
index 517749140..acf5cb68c 100644
--- a/mediator/Makefile
+++ b/mediator/Makefile
@@ -5,7 +5,11 @@ endif
include $(ESMFMKFILE)
CPPDEFS += -DESMF_VERSION_MAJOR=$(ESMF_VERSION_MAJOR) -DESMF_VERSION_MINOR=$(ESMF_VERSION_MINOR)
-ifdef INTERNAL_PIO_INIT
+ifndef PIO_INCLUDE_DIR
+$(error PIO_INCLUDE_DIR not set)
+endif
+
+ifeq ($(INTERNAL_PIO_INIT),1)
CPPDEFS += -DINTERNAL_PIO_INIT
endif
@@ -24,7 +28,7 @@ $(LIBRARY): $(OBJ)
clean:
$(RM) -f $(LIBRARY) *.i90 *.o *.mod
-med_kind_mod.o :
+med_kind_mod.o :
med_constants_mod.o : med_kind_mod.o
esmFlds.o : med_kind_mod.o
esmFldsExchange_cesm_mod.o : med_kind_mod.o med_methods_mod.o esmFlds.o med_internalstate_mod.o med_utils_mod.o
@@ -35,23 +39,24 @@ med.o : med_kind_mod.o med_phases_profile_mod.o med_utils_mod.o med_phases_prep_
med_phases_prep_lnd_mod.o med_phases_history_mod.o med_phases_ocnalb_mod.o med_phases_restart_mod.o \
med_time_mod.o med_internalstate_mod.o med_phases_prep_atm_mod.o esmFldsExchange_cesm_mod.o esmFldsExchange_nems_mod.o \
esmFldsExchange_hafs_mod.o med_phases_prep_glc_mod.o esmFlds.o med_io_mod.o med_methods_mod.o med_phases_prep_ocn_mod.o
-med_fraction_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o esmFlds.o
-med_internalstate_mod.o : med_kind_mod.o esmFlds.o
-med_io_mod.o : med_kind_mod.o med_methods_mod.o med_constants_mod.o med_internalstate_mod.o med_utils_mod.o
-med_map_mod.o : med_kind_mod.o med_internalstate_mod.o med_constants_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
-med_merge_mod.o : med_kind_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_methods_mod.o med_utils_mod.o
-med_methods_mod.o : med_kind_mod.o med_utils_mod.o med_constants_mod.o
-med_phases_aofluxes_mod.o : med_kind_mod.o med_utils_mod.o med_map_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_methods_mod.o
-med_phases_history_mod.o : med_kind_mod.o med_utils_mod.o med_time_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o med_io_mod.o esmFlds.o
-med_phases_ocnalb_mod.o : med_kind_mod.o med_utils_mod.o med_map_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_methods_mod.o
-med_phases_prep_atm_mod.o : med_kind_mod.o esmFlds.o med_methods_mod.o med_merge_mod.o med_map_mod.o med_constants_mod.o med_phases_ocnalb_mod.o med_internalstate_mod.o med_utils_mod.o
-med_phases_prep_glc_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_map_mod.o med_constants_mod.o med_methods_mod.o esmFlds.o
-med_phases_prep_ice_mod.o : med_kind_mod.o med_utils_mod.o med_methods_mod.o med_merge_mod.o esmFlds.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o
-med_phases_prep_lnd_mod.o : med_kind_mod.o med_internalstate_mod.o med_map_mod.o med_constants_mod.o med_merge_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
-med_phases_prep_ocn_mod.o : med_kind_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_merge_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
-med_phases_prep_rof_mod.o : med_kind_mod.o med_internalstate_mod.o med_map_mod.o med_constants_mod.o med_merge_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
-med_phases_prep_wav_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o med_merge_mod.o esmFlds.o
+med_fraction_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o esmFlds.o
+med_internalstate_mod.o : med_kind_mod.o esmFlds.o
+med_io_mod.o : med_kind_mod.o med_methods_mod.o med_constants_mod.o med_internalstate_mod.o med_utils_mod.o
+med_map_mod.o : med_kind_mod.o med_internalstate_mod.o med_constants_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
+med_merge_mod.o : med_kind_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_methods_mod.o med_utils_mod.o
+med_methods_mod.o : med_kind_mod.o med_utils_mod.o med_constants_mod.o
+med_phases_aofluxes_mod.o : med_kind_mod.o med_utils_mod.o med_map_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_methods_mod.o
+med_phases_history_mod.o : med_kind_mod.o med_utils_mod.o med_time_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o med_io_mod.o esmFlds.o
+med_phases_ocnalb_mod.o : med_kind_mod.o med_utils_mod.o med_map_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_methods_mod.o
+med_phases_prep_atm_mod.o : med_kind_mod.o esmFlds.o med_methods_mod.o med_merge_mod.o med_map_mod.o med_constants_mod.o med_phases_ocnalb_mod.o med_internalstate_mod.o med_utils_mod.o
+med_phases_prep_glc_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_map_mod.o med_constants_mod.o med_methods_mod.o esmFlds.o
+med_phases_prep_ice_mod.o : med_kind_mod.o med_utils_mod.o med_methods_mod.o med_merge_mod.o esmFlds.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o
+med_phases_prep_lnd_mod.o : med_kind_mod.o med_internalstate_mod.o med_map_mod.o med_constants_mod.o med_merge_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
+med_phases_prep_ocn_mod.o : med_kind_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_merge_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
+med_phases_prep_rof_mod.o : med_kind_mod.o med_internalstate_mod.o med_map_mod.o med_constants_mod.o med_merge_mod.o med_methods_mod.o esmFlds.o med_utils_mod.o
+med_phases_prep_wav_mod.o : med_kind_mod.o med_utils_mod.o med_internalstate_mod.o med_constants_mod.o med_map_mod.o med_methods_mod.o med_merge_mod.o esmFlds.o
med_phases_profile_mod.o : med_kind_mod.o med_utils_mod.o med_constants_mod.o med_internalstate_mod.o med_time_mod.o
med_phases_restart_mod.o : med_kind_mod.o med_utils_mod.o med_constants_mod.o med_internalstate_mod.o esmFlds.o med_io_mod.o
-med_time_mod.o : med_kind_mod.o med_utils_mod.o med_constants_mod.o
-med_utils_mod.o : med_kind_mod.o med_utils_mod.F90
+med_time_mod.o : med_kind_mod.o med_utils_mod.o med_constants_mod.o
+med_utils_mod.o : med_kind_mod.o
+med_diag_mod.o : med_kind_mod.o med_time_mod.o med_utils_mod.o med_methods_mod.o med_internalstate_mod.o
diff --git a/mediator/esmFlds.F90 b/mediator/esmFlds.F90
index cf3afec5a..6f2396923 100644
--- a/mediator/esmFlds.F90
+++ b/mediator/esmFlds.F90
@@ -26,21 +26,36 @@ module esmflds
! Set mappers
!-----------------------------------------------
- integer , public, parameter :: mapunset = 0
- integer , public, parameter :: mapbilnr = 1
- integer , public, parameter :: mapconsf = 2
- integer , public, parameter :: mapconsd = 3
- integer , public, parameter :: mappatch = 4
- integer , public, parameter :: mapfcopy = 5
- integer , public, parameter :: mapnstod = 6 ! nearest source to destination
- integer , public, parameter :: mapnstod_consd = 7 ! nearest source to destination followed by conservative dst
- integer , public, parameter :: mapnstod_consf = 8 ! nearest source to destination followed by conservative frac
- integer , public, parameter :: nmappers = 8
+ integer , public, parameter :: mapunset = 0
+ integer , public, parameter :: mapbilnr = 1
+ integer , public, parameter :: mapconsf = 2
+ integer , public, parameter :: mapconsd = 3
+ integer , public, parameter :: mappatch = 4
+ integer , public, parameter :: mapfcopy = 5
+ integer , public, parameter :: mapnstod = 6 ! nearest source to destination
+ integer , public, parameter :: mapnstod_consd = 7 ! nearest source to destination followed by conservative dst
+ integer , public, parameter :: mapnstod_consf = 8 ! nearest source to destination followed by conservative frac
+ integer , public, parameter :: mappatch_uv3d = 9 ! rotate u,v to 3d cartesian space, map from src->dest, then rotate back
+ integer , public, parameter :: map_glc2ocn_ice = 10 ! custom smoothing map to map ice from glc->ocn (cesm only)
+ integer , public, parameter :: map_glc2ocn_liq = 11 ! custom smoothing map to map liq from glc->ocn (cesm only)
+ integer , public, parameter :: map_rof2ocn_ice = 12 ! custom smoothing map to map ice from rof->ocn (cesm only)
+ integer , public, parameter :: map_rof2ocn_liq = 13 ! custom smoothing map to map liq from rof->ocn (cesm only)
+ integer , public, parameter :: nmappers = 13
character(len=*) , public, parameter :: mapnames(nmappers) = &
- (/'bilnr ','consf ','consd ','patch ','fcopy ','nstod ','nstod_consd','nstod_consf'/)
-
- logical, public :: mapuv_with_cart3d ! rotate u,v to 3d cartesian space, map from src->dest, then rotate back
+ (/'bilnr ',&
+ 'consf ',&
+ 'consd ',&
+ 'patch ',&
+ 'fcopy ',&
+ 'nstod ',&
+ 'nstod_consd',&
+ 'nstod_consf',&
+ 'patch_uv3d ',&
+ 'glc2ocn_ice',&
+ 'glc2ocn_liq',&
+ 'rof2ocn_ice',&
+ 'rof2ocn_liq'/)
!-----------------------------------------------
! Set coupling mode
@@ -87,7 +102,7 @@ module esmflds
! merge_type(comptm) = 'copy' (could also have 'copy_with_weighting')
type, public :: med_fldList_type
- type (med_fldList_entry_type), pointer :: flds(:)
+ type (med_fldList_entry_type), pointer :: flds(:) => null()
end type med_fldList_type
interface med_fldList_GetFldInfo ; module procedure &
@@ -130,13 +145,13 @@ subroutine med_fldList_AddFld(flds, stdname, shortname)
! ----------------------------------------------
type(med_fldList_entry_type) , pointer :: flds(:)
- character(len=*) , intent(in) :: stdname
- character(len=*) , intent(in) , optional :: shortname
+ character(len=*) , intent(in) :: stdname
+ character(len=*) , intent(in) , optional :: shortname
! local variables
integer :: n,oldsize,id
logical :: found
- type(med_fldList_entry_type), pointer :: newflds(:)
+ type(med_fldList_entry_type), pointer :: newflds(:) => null()
character(len=*), parameter :: subname='(med_fldList_AddFld)'
! ----------------------------------------------
@@ -211,23 +226,23 @@ subroutine med_fldList_AddMrg(flds, fldname, &
! input/output variables
type(med_fldList_entry_type) , pointer :: flds(:)
- character(len=*) , intent(in) :: fldname
- integer , intent(in) , optional :: mrg_from1
- character(len=*) , intent(in) , optional :: mrg_fld1
- character(len=*) , intent(in) , optional :: mrg_type1
- character(len=*) , intent(in) , optional :: mrg_fracname1
- integer , intent(in) , optional :: mrg_from2
- character(len=*) , intent(in) , optional :: mrg_fld2
- character(len=*) , intent(in) , optional :: mrg_type2
- character(len=*) , intent(in) , optional :: mrg_fracname2
- integer , intent(in) , optional :: mrg_from3
- character(len=*) , intent(in) , optional :: mrg_fld3
- character(len=*) , intent(in) , optional :: mrg_type3
- character(len=*) , intent(in) , optional :: mrg_fracname3
- integer , intent(in) , optional :: mrg_from4
- character(len=*) , intent(in) , optional :: mrg_fld4
- character(len=*) , intent(in) , optional :: mrg_type4
- character(len=*) , intent(in) , optional :: mrg_fracname4
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) , optional :: mrg_from1
+ character(len=*) , intent(in) , optional :: mrg_fld1
+ character(len=*) , intent(in) , optional :: mrg_type1
+ character(len=*) , intent(in) , optional :: mrg_fracname1
+ integer , intent(in) , optional :: mrg_from2
+ character(len=*) , intent(in) , optional :: mrg_fld2
+ character(len=*) , intent(in) , optional :: mrg_type2
+ character(len=*) , intent(in) , optional :: mrg_fracname2
+ integer , intent(in) , optional :: mrg_from3
+ character(len=*) , intent(in) , optional :: mrg_fld3
+ character(len=*) , intent(in) , optional :: mrg_type3
+ character(len=*) , intent(in) , optional :: mrg_fracname3
+ integer , intent(in) , optional :: mrg_from4
+ character(len=*) , intent(in) , optional :: mrg_fld4
+ character(len=*) , intent(in) , optional :: mrg_type4
+ character(len=*) , intent(in) , optional :: mrg_fracname4
! local variables
integer :: n, id
@@ -383,10 +398,10 @@ subroutine med_fldList_Realize(state, fldList, flds_scalar_name, flds_scalar_num
character(ESMF_MAXSTR) :: transferActionAttr
#endif
character(ESMF_MAXSTR) :: transferAction
- character(ESMF_MAXSTR), pointer :: StandardNameList(:)
- character(ESMF_MAXSTR), pointer :: ConnectedList(:)
- character(ESMF_MAXSTR), pointer :: NameSpaceList(:)
- character(ESMF_MAXSTR), pointer :: itemNameList(:)
+ character(ESMF_MAXSTR), pointer :: StandardNameList(:) => null()
+ character(ESMF_MAXSTR), pointer :: ConnectedList(:) => null()
+ character(ESMF_MAXSTR), pointer :: NameSpaceList(:) => null()
+ character(ESMF_MAXSTR), pointer :: itemNameList(:) => null()
character(len=*),parameter :: subname='(med_fldList_Realize)'
! ----------------------------------------------
@@ -679,8 +694,8 @@ subroutine med_fldList_GetFldNames(flds, fldnames, rc)
! input/output variables
type(med_fldList_entry_type) , pointer :: flds(:)
- character(len=*) , pointer :: fldnames(:)
- integer, optional , intent(out) :: rc
+ character(len=*) , pointer :: fldnames(:)
+ integer, optional , intent(out) :: rc
!local variables
integer :: n
diff --git a/mediator/esmFldsExchange_cesm_mod.F90 b/mediator/esmFldsExchange_cesm_mod.F90
index f7615256a..1040f6c46 100644
--- a/mediator/esmFldsExchange_cesm_mod.F90
+++ b/mediator/esmFldsExchange_cesm_mod.F90
@@ -4,13 +4,50 @@ module esmFldsExchange_cesm_mod
! This is a mediator specific routine that determines ALL possible
! fields exchanged between components and their associated routing,
! mapping and merging
- !---------------------------------------------------------------------
+ !
+ ! Merging arguments:
+ ! mrg_fromN = source component index that for the field to be merged
+ ! mrg_fldN = souce field name to be merged
+ ! mrg_typeN = merge type ('copy', 'copy_with_weights', 'sum', 'sum_with_weights', 'merge')
+ ! NOTE:
+ ! mrg_from(compmed) can either be for mediator computed fields for atm/ocn fluxes or for ocn albedos
+ !
+ ! NOTE:
+ ! FBMed_aoflux_o only refer to output fields to the atm/ocn that computed in the
+ ! atm/ocn flux calculations. Input fields required from either the atm or the ocn for
+ ! these computation will use the logical 'use_med_aoflux' below. This is used to determine
+ ! mappings between the atm and ocn needed for these computations.
+ !--------------------------------------
+
+ use med_kind_mod, only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
implicit none
public
public :: esmFldsExchange_cesm
+ character(len=CX) :: atm2ice_fmap='unset', atm2ice_smap='unset', atm2ice_vmap='unset'
+ character(len=CX) :: atm2ocn_fmap='unset', atm2ocn_smap='unset', atm2ocn_vmap='unset'
+ character(len=CX) :: atm2lnd_fmap='unset', atm2lnd_smap='unset'
+ character(len=CX) :: glc2lnd_smap='unset', glc2lnd_fmap='unset'
+ character(len=CX) :: glc2ice_rmap='unset'
+ character(len=CX) :: glc2ocn_liq_rmap='unset'
+ character(len=CX) :: glc2ocn_ice_rmap='unset'
+ character(len=CX) :: ice2atm_fmap='unset', ice2atm_smap='unset'
+ character(len=CX) :: ocn2atm_fmap='unset', ocn2atm_smap='unset'
+ character(len=CX) :: lnd2atm_fmap='unset', lnd2atm_smap='unset'
+ character(len=CX) :: lnd2glc_fmap='unset', lnd2glc_smap='unset'
+ character(len=CX) :: lnd2rof_fmap='unset'
+ character(len=CX) :: rof2lnd_fmap='unset'
+ character(len=CX) :: rof2ocn_fmap='unset', rof2ocn_ice_rmap='unset', rof2ocn_liq_rmap='unset'
+ character(len=CX) :: atm2wav_smap='unset', ice2wav_smap='unset', ocn2wav_smap='unset'
+ character(len=CX) :: wav2ocn_smap='unset'
+ logical :: mapuv_with_cart3d
+ logical :: flds_i2o_per_cat
+ logical :: flds_co2a
+ logical :: flds_co2b
+ logical :: flds_co2c
+
character(*), parameter :: u_FILE_u = &
__FILE__
@@ -25,16 +62,15 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
use med_utils_mod , only : chkerr => med_utils_chkerr
use med_methods_mod , only : fldchk => med_methods_FB_FldChk
- use med_internalstate_mod , only : InternalState
- use esmFlds , only : med_fldList_type
+ use med_internalstate_mod , only : InternalState, logunit, mastertask
use esmFlds , only : addfld => med_fldList_AddFld
use esmFlds , only : addmap => med_fldList_AddMap
use esmFlds , only : addmrg => med_fldList_AddMrg
use esmflds , only : compmed, compatm, complnd, compocn
use esmflds , only : compice, comprof, compwav, compglc, ncomps
- use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch
+ use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d
use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf
- use esmflds , only : mapuv_with_cart3d
+ use esmflds , only : map_glc2ocn_ice, map_glc2ocn_liq, map_rof2ocn_ice, map_rof2ocn_liq
use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb
use esmFlds , only : coupling_mode
@@ -45,43 +81,20 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
! local variables:
type(InternalState) :: is_local
- logical :: flds_i2o_per_cat
- integer :: dbrc
- integer :: num, i, n
- integer :: n1, n2, n3, n4
- logical :: isPresent
+ integer :: n
character(len=5) :: iso(2)
character(len=CL) :: cvalue
character(len=CS) :: name, fldname
- character(len=CX) :: atm2ice_fmap='unset', atm2ice_smap='unset', atm2ice_vmap='unset'
- character(len=CX) :: atm2ocn_fmap='unset', atm2ocn_smap='unset', atm2ocn_vmap='unset'
- character(len=CX) :: atm2lnd_fmap='unset', atm2lnd_smap='unset'
- character(len=CX) :: glc2lnd_smap='unset', glc2lnd_fmap='unset'
- character(len=CX) :: glc2ice_rmap='unset'
- character(len=CX) :: glc2ocn_liq_rmap='unset', glc2ocn_ice_rmap='unset'
- character(len=CX) :: ice2atm_fmap='unset', ice2atm_smap='unset'
- character(len=CX) :: ocn2atm_fmap='unset', ocn2atm_smap='unset'
- character(len=CX) :: lnd2atm_fmap='unset', lnd2atm_smap='unset'
- character(len=CX) :: lnd2glc_fmap='unset', lnd2glc_smap='unset'
- character(len=CX) :: lnd2rof_fmap='unset'
- character(len=CX) :: rof2lnd_fmap='unset'
- character(len=CX) :: rof2ocn_fmap='unset', rof2ocn_ice_rmap='unset', rof2ocn_liq_rmap='unset'
- character(len=CX) :: atm2wav_smap='unset', ice2wav_smap='unset', ocn2wav_smap='unset'
- character(len=CX) :: wav2ocn_smap='unset'
- logical :: flds_co2a ! use case
- logical :: flds_co2b ! use case
- logical :: flds_co2c ! use case
character(len=CS), allocatable :: flds(:)
character(len=CS), allocatable :: suffix(:)
- character(len=*) , parameter :: subname='(esmFldsExchange_cesm)'
+ character(len=*) , parameter :: subname=' (esmFldsExchange_cesm) '
!--------------------------------------
rc = ESMF_SUCCESS
- iso(1) = ''
+ iso(1) = ' '
iso(2) = '_wiso'
-
!---------------------------------------
! Get the internal state
!---------------------------------------
@@ -92,233 +105,137 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- !--------------------------------------
- ! Merging arguments:
- ! mrg_fromN = source component index that for the field to be merged
- ! mrg_fldN = souce field name to be merged
- ! mrg_typeN = merge type ('copy', 'copy_with_weights', 'sum', 'sum_with_weights', 'merge')
- ! NOTE:
- ! mrg_from(compmed) can either be for mediator computed fields for atm/ocn fluxes or for ocn albedos
- !
- ! NOTE:
- ! FBMed_aoflux_o only refer to output fields to the atm/ocn that computed in the
- ! atm/ocn flux calculations. Input fields required from either the atm or the ocn for
- ! these computation will use the logical 'use_med_aoflux' below. This is used to determine
- ! mappings between the atm and ocn needed for these computations.
- !--------------------------------------
-
- call NUOPC_CompAttributeGet(gcomp, name='flds_i2o_per_cat', value=cvalue, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- read(cvalue,*) flds_i2o_per_cat
- call ESMF_LogWrite('flds_i2o_per_cat = '// trim(cvalue), ESMF_LOGMSG_INFO)
-
- !----------------------------------------------------------
- ! Initialize mapping file names
- !----------------------------------------------------------
-
- ! to atm
-
- call NUOPC_CompAttributeGet(gcomp, name='ice2atm_fmapname', value=ice2atm_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ice2atm_fmapname = '// trim(ice2atm_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='ice2atm_smapname', value=ice2atm_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ice2atm_smapname = '// trim(ice2atm_smap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='lnd2atm_fmapname', value=lnd2atm_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('lnd2atm_fmapname = '// trim(lnd2atm_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', value=ocn2atm_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ocn2atm_smapname = '// trim(ocn2atm_smap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', value=ocn2atm_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ocn2atm_fmapname = '// trim(ocn2atm_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='lnd2atm_smapname', value=lnd2atm_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('lnd2atm_smapname = '// trim(lnd2atm_smap), ESMF_LOGMSG_INFO)
- end if
-
- ! to lnd
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2lnd_fmapname', value=atm2lnd_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2lnd_fmapname = '// trim(atm2lnd_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2lnd_smapname', value=atm2lnd_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2lnd_smapname = '// trim(atm2lnd_smap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='rof2lnd_fmapname', value=rof2lnd_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('rof2lnd_fmapname = '// trim(rof2lnd_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='glc2lnd_fmapname', value=glc2lnd_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('glc2lnd_smapname = '// trim(glc2lnd_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='glc2lnd_smapname', value=glc2lnd_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('glc2lnd_smapname = '// trim(glc2lnd_smap), ESMF_LOGMSG_INFO)
- end if
-
- ! to ice
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2ice_fmapname', value=atm2ice_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ice_fmapname = '// trim(atm2ice_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2ice_smapname', value=atm2ice_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ice_smapname = '// trim(atm2ice_smap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2ice_vmapname', value=atm2ice_vmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ice_vmapname = '// trim(atm2ice_vmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='glc2ice_rmapname', value=glc2ice_rmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('glc2ice_rmapname = '// trim(glc2ice_rmap), ESMF_LOGMSG_INFO)
- end if
-
- ! to ocn
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', value=atm2ocn_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ocn_fmapname = '// trim(atm2ocn_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', value=atm2ocn_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ocn_smapname = '// trim(atm2ocn_smap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', value=atm2ocn_vmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ocn_vmapname = '// trim(atm2ocn_vmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='glc2ocn_liq_rmapname', value=glc2ocn_liq_rmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('glc2ocn_liq_rmapname = '// trim(glc2ocn_liq_rmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='glc2ocn_ice_rmapname', value=glc2ocn_ice_rmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('glc2ocn_ice_rmapname = '// trim(glc2ocn_ice_rmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='wav2ocn_smapname', value=wav2ocn_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('wav2ocn_smapname = '// trim(wav2ocn_smap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='rof2ocn_fmapname', value=rof2ocn_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('rof2ocn_fmapname = '// trim(rof2ocn_fmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='rof2ocn_liq_rmapname', value=rof2ocn_liq_rmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('rof2ocn_liq_rmapname = '// trim(rof2ocn_liq_rmap), ESMF_LOGMSG_INFO)
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='rof2ocn_ice_rmapname', value=rof2ocn_ice_rmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('rof2ocn_ice_rmapname = '// trim(rof2ocn_ice_rmap), ESMF_LOGMSG_INFO)
- end if
+ if (phase == 'advertise') then
- ! to rof
+ ! mapping to atm
+ call NUOPC_CompAttributeGet(gcomp, name='ice2atm_fmapname', value=ice2atm_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'ice2atm_fmapname = '// trim(ice2atm_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='ice2atm_smapname', value=ice2atm_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'ice2atm_smapname = '// trim(ice2atm_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='lnd2atm_fmapname', value=lnd2atm_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2atm_fmapname = '// trim(lnd2atm_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', value=ocn2atm_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'ocn2atm_smapname = '// trim(ocn2atm_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', value=ocn2atm_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'ocn2atm_fmapname = '// trim(ocn2atm_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='lnd2atm_smapname', value=lnd2atm_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2atm_smapname = '// trim(lnd2atm_smap)
- call NUOPC_CompAttributeGet(gcomp, name='lnd2rof_fmapname', value=lnd2rof_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('lnd2rof_fmapname = '// trim(lnd2rof_fmap), ESMF_LOGMSG_INFO)
- end if
+ ! mapping to lnd
+ call NUOPC_CompAttributeGet(gcomp, name='atm2lnd_fmapname', value=atm2lnd_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2lnd_fmapname = '// trim(atm2lnd_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='atm2lnd_smapname', value=atm2lnd_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2lnd_smapname = '// trim(atm2lnd_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='rof2lnd_fmapname', value=rof2lnd_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'rof2lnd_fmapname = '// trim(rof2lnd_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='glc2lnd_fmapname', value=glc2lnd_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'glc2lnd_smapname = '// trim(glc2lnd_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='glc2lnd_smapname', value=glc2lnd_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'glc2lnd_smapname = '// trim(glc2lnd_smap)
- ! to glc
+ ! mapping to ice
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ice_fmapname', value=atm2ice_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ice_fmapname = '// trim(atm2ice_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ice_smapname', value=atm2ice_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ice_smapname = '// trim(atm2ice_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ice_vmapname', value=atm2ice_vmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ice_vmapname = '// trim(atm2ice_vmap)
+ call NUOPC_CompAttributeGet(gcomp, name='glc2ice_rmapname', value=glc2ice_rmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'glc2ice_rmapname = '// trim(glc2ice_rmap)
- call NUOPC_CompAttributeGet(gcomp, name='lnd2glc_fmapname', value=lnd2glc_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('lnd2glc_fmapname = '// trim(lnd2glc_fmap), ESMF_LOGMSG_INFO)
- end if
+ ! mapping to ocn
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', value=atm2ocn_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ocn_fmapname = '// trim(atm2ocn_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', value=atm2ocn_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ocn_smapname = '// trim(atm2ocn_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', value=atm2ocn_vmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'atm2ocn_vmapname = '// trim(atm2ocn_vmap)
+ call NUOPC_CompAttributeGet(gcomp, name='glc2ocn_liq_rmapname', value=glc2ocn_liq_rmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'glc2ocn_liq_rmapname = '// trim(glc2ocn_liq_rmap)
+ call NUOPC_CompAttributeGet(gcomp, name='glc2ocn_ice_rmapname', value=glc2ocn_ice_rmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'glc2ocn_ice_rmapname = '// trim(glc2ocn_ice_rmap)
+ call NUOPC_CompAttributeGet(gcomp, name='wav2ocn_smapname', value=wav2ocn_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'wav2ocn_smapname = '// trim(wav2ocn_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='rof2ocn_fmapname', value=rof2ocn_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'rof2ocn_fmapname = '// trim(rof2ocn_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='rof2ocn_liq_rmapname', value=rof2ocn_liq_rmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'rof2ocn_liq_rmapname = '// trim(rof2ocn_liq_rmap)
+ call NUOPC_CompAttributeGet(gcomp, name='rof2ocn_ice_rmapname', value=rof2ocn_ice_rmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'rof2ocn_ice_rmapname = '// trim(rof2ocn_ice_rmap)
- call NUOPC_CompAttributeGet(gcomp, name='lnd2glc_smapname', value=lnd2glc_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('lnd2glc_smapname = '// trim(lnd2glc_smap), ESMF_LOGMSG_INFO)
- end if
+ ! mapping to rof
+ call NUOPC_CompAttributeGet(gcomp, name='lnd2rof_fmapname', value=lnd2rof_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2rof_fmapname = '// trim(lnd2rof_fmap)
- ! to wav
+ ! mapping to glc
+ call NUOPC_CompAttributeGet(gcomp, name='lnd2glc_fmapname', value=lnd2glc_fmap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2glc_fmapname = '// trim(lnd2glc_fmap)
+ call NUOPC_CompAttributeGet(gcomp, name='lnd2glc_smapname', value=lnd2glc_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit, '(a)') trim(subname)//'lnd2glc_smapname = '// trim(lnd2glc_smap)
- call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', value=atm2wav_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2wav_smapname = '// trim(atm2wav_smap), ESMF_LOGMSG_INFO)
- end if
+ ! mapping to wav
+ call NUOPC_CompAttributeGet(gcomp, name='atm2wav_smapname', value=atm2wav_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit,'(a)') trim(subname)//'atm2wav_smapname = '// trim(atm2wav_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='ice2wav_smapname', value=ice2wav_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit,'(a)') trim(subname)//'ice2wav_smapname = '// trim(ice2wav_smap)
+ call NUOPC_CompAttributeGet(gcomp, name='ocn2wav_smapname', value=ocn2wav_smap, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit,'(a)') trim(subname)//'ocn2wav_smapname = '// trim(ocn2wav_smap)
- call NUOPC_CompAttributeGet(gcomp, name='ice2wav_smapname', value=ice2wav_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ice2wav_smapname = '// trim(ice2wav_smap), ESMF_LOGMSG_INFO)
- end if
+ ! uv cart3d mapping
+ call NUOPC_CompAttributeGet(gcomp, name='mapuv_with_cart3d', value=cvalue, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) write(logunit,'(a)') trim(subname)//'mapuv_with_cart3d = '// trim(cvalue)
+ read(cvalue,*) mapuv_with_cart3d
- call NUOPC_CompAttributeGet(gcomp, name='ocn2wav_smapname', value=ocn2wav_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ocn2wav_smapname = '// trim(ocn2wav_smap), ESMF_LOGMSG_INFO)
- end if
+ ! co2 transfer between componetns
+ call NUOPC_CompAttributeGet(gcomp, name='flds_co2a', value=cvalue, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) flds_co2a
+ call NUOPC_CompAttributeGet(gcomp, name='flds_co2b', value=cvalue, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) flds_co2b
+ call NUOPC_CompAttributeGet(gcomp, name='flds_co2c', value=cvalue, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) flds_co2c
+ if (mastertask) write(logunit,'(a)') trim(subname)//' flds_co2a = '// trim(cvalue)
+ if (mastertask) write(logunit,'(a)') trim(subname)//' flds_co2b = '// trim(cvalue)
+ if (mastertask) write(logunit,'(a)') trim(subname)//' flds_co2c = '// trim(cvalue)
- !----------------------------------------------------------
- ! Initialize if use 3d cartesian mapping for u,v
- !----------------------------------------------------------
+ call NUOPC_CompAttributeGet(gcomp, name='flds_i2o_per_cat', value=cvalue, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) flds_i2o_per_cat
+ call ESMF_LogWrite('flds_i2o_per_cat = '// trim(cvalue), ESMF_LOGMSG_INFO)
- call NUOPC_CompAttributeGet(gcomp, name='mapuv_with_cart3d', value=cvalue, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- read(cvalue,*) mapuv_with_cart3d
- if (isPresent) then
- call ESMF_LogWrite('mapuv_with_cart3d = '// trim(cvalue), ESMF_LOGMSG_INFO)
end if
!=====================================================================
@@ -354,10 +271,14 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
! ---------------------------------------------------------------------
if (phase /= 'advertise') then
call addfld(fldListFr(compatm)%flds, 'Sa_u')
- call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mappatch, 'one', atm2ocn_vmap)
-
call addfld(fldListFr(compatm)%flds, 'Sa_v')
- call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mappatch, 'one', atm2ocn_vmap)
+ if (mapuv_with_cart3d) then
+ call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mappatch_uv3d, 'one', atm2ocn_vmap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mappatch_uv3d, 'one', atm2ocn_vmap)
+ else
+ call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mappatch, 'one', atm2ocn_vmap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mappatch, 'one', atm2ocn_vmap)
+ end if
call addfld(fldListFr(compatm)%flds, 'Sa_z')
call addmap(fldListFr(compatm)%flds, 'Sa_z' , compocn, mapbilnr, 'one', atm2ocn_smap)
@@ -371,20 +292,16 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(compatm)%flds, 'Sa_shum')
call addmap(fldListFr(compatm)%flds, 'Sa_shum', compocn, mapbilnr, 'one', atm2ocn_smap)
+ call addfld(fldListFr(compatm)%flds, 'Sa_ptem')
+ call addmap(fldListFr(compatm)%flds, 'Sa_ptem', compocn, mapbilnr, 'one', atm2ocn_smap)
+
+ call addfld(fldListFr(compatm)%flds, 'Sa_dens')
+ call addmap(fldListFr(compatm)%flds, 'Sa_dens', compocn, mapbilnr, 'one', atm2ocn_smap)
+
if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_shum_wiso', rc=rc)) then
call addfld(fldListFr(compatm)%flds, 'Sa_shum_wiso')
call addmap(fldListFr(compatm)%flds, 'Sa_shum_wiso', compocn, mapbilnr, 'one', atm2ocn_smap)
end if
-
- if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_ptem', rc=rc)) then
- call addfld(fldListFr(compatm)%flds, 'Sa_ptem')
- call addmap(fldListFr(compatm)%flds, 'Sa_ptem', compocn, mapbilnr, 'one', atm2ocn_smap)
- end if
-
- if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_dens', rc=rc)) then
- call addfld(fldListFr(compatm)%flds, 'Sa_dens')
- call addmap(fldListFr(compatm)%flds, 'Sa_dens', compocn, mapbilnr, 'one', atm2ocn_smap)
- end if
end if
! ---------------------------------------------------------------------
@@ -528,7 +445,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
else
if ( fldchk(is_local%wrap%FBExp(complnd) , trim(fldname), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(compglc, compglc), trim(fldname), rc=rc)) then
- call addmap(fldListFr(compglc)%flds, trim(fldname), complnd, mapconsf, 'one', glc2lnd_smap)
+ call addmap(fldListFr(compglc)%flds, trim(fldname), complnd, mapconsd, 'one', glc2lnd_smap)
call addmrg(fldListTo(complnd)%flds, trim(fldname), &
mrg_from1=compglc, mrg_fld1=trim(fldname), mrg_type1='copy')
end if
@@ -679,7 +596,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(compice)%flds, 'Faii_'//trim(suffix(n)))
call addfld(fldListTo(compatm)%flds, 'Faxx_'//trim(suffix(n)))
else
- ! (non aqua-planet)
+ ! CESM (non aqua-planet)
if ( fldchk(is_local%wrap%FBImp(complnd,complnd), 'Fall_'//trim(suffix(n)), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(compice,compice), 'Faii_'//trim(suffix(n)), rc=rc) .and. &
fldchk(is_local%wrap%FBMed_aoflux_o , 'Faox_'//trim(suffix(n)), rc=rc) .and. &
@@ -692,7 +609,6 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
mrg_from2=compice, mrg_fld2='Faii_'//trim(suffix(n)), mrg_type2='merge', mrg_fracname2='ifrac', &
mrg_from3=compmed, mrg_fld3='Faox_'//trim(suffix(n)), mrg_type3='merge', mrg_fracname3='ofrac')
- ! (cam, aqua-planet)
else if (fldchk(is_local%wrap%FBMed_aoflux_o, 'Faox_'//trim(suffix(n)), rc=rc) .and. &
fldchk(is_local%wrap%FBexp(compatm), 'Faxx_'//trim(suffix(n)), rc=rc)) then
call addmap(fldListMed_aoflux%flds , 'Faox_'//trim(suffix(n)), compatm, mapconsf, 'ofrac', ocn2atm_fmap)
@@ -710,11 +626,10 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(complnd)%flds, 'Sl_t')
call addfld(fldListFr(compice)%flds, 'Si_t')
call addfld(fldListFr(compocn)%flds, 'So_t')
-
call addfld(fldListTo(compatm)%flds, 'So_t')
call addfld(fldListTo(compatm)%flds, 'Sx_t')
else
- ! merged ocn/ice/lnd temp and unmerged ocn temp
+ ! CESM - merged ocn/ice/lnd temp and unmerged ocn temp
if (fldchk(is_local%wrap%FBexp(compatm) , 'Sx_t', rc=rc) .and. &
fldchk(is_local%wrap%FBImp(complnd,complnd), 'Sl_t', rc=rc) .and. &
fldchk(is_local%wrap%FBImp(compice,compice), 'Si_t', rc=rc) .and. &
@@ -1332,42 +1247,63 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
if (phase == 'advertise') then
do n = 1,size(iso)
+ ! Note that Flrr_flood below needs to be added to
+ ! fldlistFr(comprof) in order to be mapped correctly but the ocean
+ ! does not receive it so it is advertised but it will! not be connected
+
call addfld(fldListFr(compglc)%flds, 'Fogg_rofl'//iso(n))
call addfld(fldListFr(compglc)%flds, 'Fogg_rofi'//iso(n))
call addfld(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n))
call addfld(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n))
call addfld(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n))
call addfld(fldListTo(compocn)%flds, 'Foxx_rofi'//iso(n))
+ call addfld(fldListTo(compocn)%flds, 'Flrr_flood'//iso(n))
end do
else
do n = 1,size(iso)
- ! from both rof and glc to con
- if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n), rc=rc)) then
- call addmap(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n), compocn, mapconsf, 'none', rof2ocn_liq_rmap)
- call addmap(fldListFr(compglc)%flds, 'Fogg_rofl'//iso(n), compocn, mapconsf, 'one' , glc2ocn_liq_rmap)
+ ! liquid runoff from rof, flood and glc to ocn
+ if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n) , rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n) , rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n) , rc=rc)) then
+ call addmap(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n) , compocn, map_rof2ocn_liq, 'none', rof2ocn_liq_rmap)
+ call addmap(fldListFr(comprof)%flds, 'Flrr_flood'//iso(n), compocn, mapconsd , 'one' , rof2ocn_fmap)
+ call addmap(fldListFr(compglc)%flds, 'Fogg_rofl'//iso(n) , compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap)
call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n), &
mrg_from1=comprof, mrg_fld1='Forr_rofl:Flrr_flood', mrg_type1='sum', &
mrg_from2=compglc, mrg_fld2='Fogg_rofl'//iso(n) , mrg_type2='sum')
-
+ ! liquid runoff from both rof and glc to ocn
+ else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n) , rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n) , rc=rc) .and. .not. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n) , rc=rc)) then
+ call addmap(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n), compocn, map_rof2ocn_liq, 'none', rof2ocn_liq_rmap)
+ call addmap(fldListFr(compglc)%flds, 'Fogg_rofl'//iso(n), compocn, map_glc2ocn_liq, 'one' , glc2ocn_liq_rmap)
+ call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n), &
+ mrg_from1=comprof, mrg_fld1='Forr_rofl' , mrg_type1='sum', &
+ mrg_from2=compglc, mrg_fld2='Fogg_rofl'//iso(n), mrg_type2='sum')
! liquid runoff from rof and flood to ocn
- else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl' //iso(n), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl' //iso(n), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc)) then
- call addmap(fldListFr(comprof)%flds, 'Flrr_flood'//iso(n), compocn, mapconsf, 'none', rof2ocn_fmap)
- call addmap(fldListFr(comprof)%flds, 'Forr_rofl' //iso(n), compocn, mapconsf, 'none', rof2ocn_liq_rmap)
+ else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n) , rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n) , rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc) .and. .not. &
+ fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n) , rc=rc)) then
+ call addmap(fldListFr(comprof)%flds, 'Flrr_flood'//iso(n), compocn, mapconsf , 'one' , rof2ocn_fmap)
+ call addmap(fldListFr(comprof)%flds, 'Forr_rofl' //iso(n), compocn, map_rof2ocn_liq, 'none', rof2ocn_liq_rmap)
call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl' //iso(n), &
mrg_from1=comprof, mrg_fld1='Forr_rofl:Flrr_flood', mrg_type1='sum')
-
! liquid from just rof to ocn
- else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n), rc=rc)) then
+ else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n) , rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n) , rc=rc) .and. .not. &
+ fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc) .and. .not. &
+ fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n) , rc=rc)) then
call addmap(fldListFr(comprof)%flds, 'Forr_rofl'//iso(n), compocn, mapconsf, 'none', rof2ocn_liq_rmap)
call addmrg(fldListTo(compocn)%flds, 'Foxx_rofl'//iso(n), &
mrg_from1=comprof, mrg_fld1='Forr_rofl', mrg_type1='copy')
-
! liquid runoff from just glc to ocn
+ else if ( .not. fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n) , rc=rc) .and. &
+ .not. fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofl'//iso(n) , rc=rc) .and. &
+ .not. fldchk(is_local%wrap%FBImp(comprof, comprof), 'Flrr_flood'//iso(n), rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n) , rc=rc)) then
else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofl'//iso(n), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofl'//iso(n), rc=rc)) then
call addmap(fldListFr(compglc)%flds, 'Fogg_rofl'//iso(n), compocn, mapconsf, 'one', glc2ocn_liq_rmap)
@@ -1379,23 +1315,21 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofi'//iso(n), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi'//iso(n), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofi'//iso(n), rc=rc)) then
- call addmap(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n), compocn, mapconsf, 'none', rof2ocn_ice_rmap)
- call addmap(fldListFr(compglc)%flds, 'Fogg_rofi'//iso(n), compocn, mapconsf, 'one' , glc2ocn_ice_rmap)
+ call addmap(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n), compocn, map_rof2ocn_ice, 'none', rof2ocn_ice_rmap)
+ call addmap(fldListFr(compglc)%flds, 'Fogg_rofi'//iso(n), compocn, map_glc2ocn_ice, 'one' , glc2ocn_ice_rmap)
call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi'//iso(n), &
mrg_from1=comprof, mrg_fld1='Forr_rofi'//iso(n), mrg_type1='sum', &
mrg_from2=compglc, mrg_fld2='Fogg_rofi'//iso(n), mrg_type2='sum')
-
! ice runoff from just rof to ocn
else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofi'//iso(n), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(comprof, comprof), 'Forr_rofi'//iso(n), rc=rc)) then
- call addmap(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n), compocn, mapconsf, 'none', rof2ocn_ice_rmap)
+ call addmap(fldListFr(comprof)%flds, 'Forr_rofi'//iso(n), compocn, map_rof2ocn_ice, 'none', rof2ocn_ice_rmap)
call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi'//iso(n), &
mrg_from1=comprof, mrg_fld1='Forr_rofi', mrg_type1='copy')
-
! ice runoff from just glc to ocn
else if ( fldchk(is_local%wrap%FBExp(compocn) , 'Foxx_rofi'//iso(n), rc=rc) .and. &
fldchk(is_local%wrap%FBImp(compglc, compglc), 'Fogg_rofi'//iso(n), rc=rc)) then
- call addmap(fldListFr(compglc)%flds, 'Fogg_rofi'//iso(n), compocn, mapconsf, 'one', glc2ocn_ice_rmap)
+ call addmap(fldListFr(compglc)%flds, 'Fogg_rofi'//iso(n), compocn, map_glc2ocn_ice, 'one', glc2ocn_ice_rmap)
call addmrg(fldListTo(compocn)%flds, 'Foxx_rofi'//iso(n), &
mrg_from1=compglc, mrg_fld1='Fogg_rofi'//iso(n), mrg_type1='copy')
end if
@@ -1768,7 +1702,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
else
if ( fldchk(is_local%wrap%FBImp(complnd, complnd), trim(fldname), rc=rc) .and. &
fldchk(is_local%wrap%FBExp(comprof) , trim(fldname), rc=rc)) then
- call addmap(fldListFr(complnd)%flds, trim(fldname), comprof, mapconsd, 'lfrac', lnd2rof_fmap)
+ call addmap(fldListFr(complnd)%flds, trim(fldname), comprof, mapconsf, 'lfrac', lnd2rof_fmap)
call addmrg(fldListTo(comprof)%flds, trim(fldname), &
mrg_from1=complnd, mrg_fld1=trim(fldname), mrg_type1='copy_with_weights', mrg_fracname1='lfrac')
end if
@@ -1798,11 +1732,11 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(complnd)%flds, 'Flgl_qice_elev') ! glacier ice flux (1->glc_nec+1)
else
if ( fldchk(is_local%wrap%FBImp(complnd,complnd) , 'Flgl_qice_elev', rc=rc)) then
- ! custom merging will be done here
+ ! custom merging will be done here
call addmap(FldListFr(complnd)%flds, 'Flgl_qice_elev', compglc, mapbilnr, 'lfrac', lnd2glc_smap)
end if
if ( fldchk(is_local%wrap%FBImp(complnd,complnd) , 'Sl_tsrf_elev' , rc=rc)) then
- ! custom merging will be done here
+ ! custom merging will be done here
call addmap(FldListFr(complnd)%flds, 'Sl_tsrf_elev', compglc, mapbilnr, 'lfrac', lnd2glc_smap)
end if
if ( fldchk(is_local%wrap%FBImp(complnd,complnd) , 'Sl_topo_elev' , rc=rc)) then
@@ -1898,7 +1832,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(complnd)%flds, 'Fall_fco2_lnd')
call addfld(fldListTo(compatm)%flds, 'Fall_fco2_lnd')
else
- call addmap(fldListFr(complnd)%flds, 'Fall_fco2_lnd', compatm, mapconsf, 'one', atm2lnd_smap)
+ call addmap(fldListFr(complnd)%flds, 'Fall_fco2_lnd', compatm, mapconsf, 'one', lnd2atm_fmap)
call addmrg(fldListTo(compatm)%flds, 'Fall_fco2_lnd', &
mrg_from1=complnd, mrg_fld1='Fall_fco2_lnd', mrg_type1='copy_with_weights', mrg_fracname1='lfrac')
end if
@@ -1946,7 +1880,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(complnd)%flds, 'Fall_fco2_lnd')
call addfld(fldListTo(compatm)%flds, 'Fall_fco2_lnd')
else
- call addmap(fldListFr(complnd)%flds, 'Fall_fco2_lnd', compatm, mapconsf, 'one', atm2lnd_smap)
+ call addmap(fldListFr(complnd)%flds, 'Fall_fco2_lnd', compatm, mapconsf, 'one', lnd2atm_fmap)
call addmrg(fldListTo(compatm)%flds, 'Fall_fco2_lnd', &
mrg_from1=complnd, mrg_fld1='Fall_fco2_lnd', mrg_type1='copy_with_weights', mrg_fracname1='lfrac')
end if
@@ -1958,7 +1892,7 @@ subroutine esmFldsExchange_cesm(gcomp, phase, rc)
call addfld(fldListFr(compocn)%flds, 'Faoo_fco2_ocn')
call addfld(fldListTo(compatm)%flds, 'Faoo_fco2_ocn')
else
- call addmap(fldListFr(compocn)%flds, 'Faoo_fco2_ocn', compatm, mapconsf, 'one', atm2lnd_smap)
+ call addmap(fldListFr(compocn)%flds, 'Faoo_fco2_ocn', compatm, mapconsf, 'one', ocn2atm_fmap)
! custom merge in med_phases_prep_atm
end if
endif
diff --git a/mediator/esmFldsExchange_hafs_mod.F90 b/mediator/esmFldsExchange_hafs_mod.F90
index 92b90d16c..29fd506ed 100644
--- a/mediator/esmFldsExchange_hafs_mod.F90
+++ b/mediator/esmFldsExchange_hafs_mod.F90
@@ -1,5 +1,21 @@
module esmFldsExchange_hafs_mod
+ use ESMF
+ use NUOPC
+ use med_utils_mod, only : chkerr => med_utils_chkerr
+ use med_kind_mod, only : CX=>SHR_KIND_CX
+ use med_kind_mod, only : CS=>SHR_KIND_CS
+ use med_kind_mod, only : CL=>SHR_KIND_CL
+ use med_kind_mod, only : R8=>SHR_KIND_R8
+ use esmflds, only : compmed
+ use esmflds, only : compatm
+ use esmflds, only : compocn
+ use esmflds, only : compice
+ use esmflds, only : ncomps
+ use esmflds, only : fldListTo
+ use esmflds, only : fldListFr
+ use esmFlds, only : coupling_mode
+
!---------------------------------------------------------------------
! This is a mediator specific routine that determines ALL possible
! fields exchanged between components and their associated routing,
@@ -14,28 +30,50 @@ module esmFldsExchange_hafs_mod
character(*), parameter :: u_FILE_u = &
__FILE__
-!================================================================================
+ type gcomp_attr
+ character(len=CX) :: atm2ice_fmap='unset'
+ character(len=CX) :: atm2ice_smap='unset'
+ character(len=CX) :: atm2ice_vmap='unset'
+ character(len=CX) :: atm2ocn_fmap='unset'
+ character(len=CX) :: atm2ocn_smap='unset'
+ character(len=CX) :: atm2ocn_vmap='unset'
+ character(len=CX) :: ice2atm_fmap='unset'
+ character(len=CX) :: ice2atm_smap='unset'
+ character(len=CX) :: ocn2atm_fmap='unset'
+ character(len=CX) :: ocn2atm_smap='unset'
+ end type
+
+!===============================================================================
contains
-!================================================================================
+!===============================================================================
subroutine esmFldsExchange_hafs(gcomp, phase, rc)
- use ESMF
- use NUOPC
- use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
- use med_utils_mod , only : chkerr => med_utils_chkerr
- use med_methods_mod , only : fldchk => med_methods_FB_FldChk
- use med_internalstate_mod , only : InternalState
- use esmFlds , only : med_fldList_type
+ ! input/output parameters:
+ type(ESMF_GridComp) :: gcomp
+ character(len=*) , intent(in) :: phase
+ integer , intent(inout) :: rc
+
+ ! local variables:
+ !--------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ if (phase == 'advertise') then
+ call esmFldsExchange_hafs_advt(gcomp, phase, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else
+ call esmFldsExchange_hafs_init(gcomp, phase, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ endif
+
+ end subroutine esmFldsExchange_hafs
+
+ !-----------------------------------------------------------------------------
+
+ subroutine esmFldsExchange_hafs_advt(gcomp, phase, rc)
+
use esmFlds , only : addfld => med_fldList_AddFld
- use esmFlds , only : addmap => med_fldList_AddMap
- use esmFlds , only : addmrg => med_fldList_AddMrg
- use esmflds , only : compmed, compatm, compocn, compice, ncomps
- use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch
- use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf
- use esmflds , only : mapuv_with_cart3d
- use esmflds , only : fldListTo, fldListFr
- use esmFlds , only : coupling_mode
! input/output parameters:
type(ESMF_GridComp) :: gcomp
@@ -43,230 +81,337 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
integer , intent(inout) :: rc
! local variables:
- type(InternalState) :: is_local
- integer :: dbrc
integer :: num, i, n
- integer :: n1, n2, n3, n4
logical :: isPresent
!character(len=5) :: iso(2)
character(len=CL) :: cvalue
character(len=CS) :: name, fldname
- character(len=CX) :: atm2ice_fmap='unset', atm2ice_smap='unset', atm2ice_vmap='unset'
- character(len=CX) :: atm2ocn_fmap='unset', atm2ocn_smap='unset', atm2ocn_vmap='unset'
- character(len=CX) :: ice2atm_fmap='unset', ice2atm_smap='unset'
- character(len=CX) :: ocn2atm_fmap='unset', ocn2atm_smap='unset'
character(len=CS), allocatable :: flds(:)
character(len=CS), allocatable :: suffix(:)
- character(len=*) , parameter :: subname='(esmFldsExchange_hafs)'
+ character(len=*) , parameter :: subname='(esmFldsExchange_hafs_advt)'
!--------------------------------------
rc = ESMF_SUCCESS
- !---------------------------------------
- ! Get the internal state
- !---------------------------------------
+ !=====================================================================
+ ! scalar information
+ !=====================================================================
+ call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, &
+ rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,ncomps
+ call addfld(fldListFr(n)%flds, trim(cvalue))
+ call addfld(fldListTo(n)%flds, trim(cvalue))
+ end do
- if (phase /= 'advertise') then
- nullify(is_local%wrap)
- call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
+ !=====================================================================
+ ! FIELDS TO MEDIATOR component (for fractions and atm/ocn flux calculation)
+ !=====================================================================
- !--------------------------------------
- ! Merging arguments:
- ! mrg_fromN = source component index that for the field to be merged
- ! mrg_fldN = souce field name to be merged
- ! mrg_typeN = merge type ('copy', 'copy_with_weights', 'sum', 'sum_with_weights', 'merge')
- ! NOTE:
- ! mrg_from(compmed) can either be for mediator computed fields for atm/ocn fluxes or for ocn albedos
- !
- ! NOTE:
- ! FBMed_aoflux_o only refer to output fields to the atm/ocn that computed in the
- ! atm/ocn flux calculations. Input fields required from either the atm or the ocn for
- ! these computation will use the logical 'use_med_aoflux' below. This is used to determine
- ! mappings between the atm and ocn needed for these computations.
- !--------------------------------------
+ !----------------------------------------------------------
+ ! to med: masks from components
+ !----------------------------------------------------------
+ call addfld(fldListFr(compocn)%flds, 'So_omask')
+ call addfld(fldListFr(compice)%flds, 'Si_imask')
+
+ ! ---------------------------------------------------------------------
+ ! to med: swnet fluxes used for budget calculation
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds, 'Faxa_swnet')
+
+ !=====================================================================
+ ! FIELDS TO ATMOSPHERE
+ !=====================================================================
!----------------------------------------------------------
- ! Initialize mapping file names
+ ! to atm: Fractions
!----------------------------------------------------------
+ ! the following are computed in med_phases_prep_atm
+ call addfld(fldListTo(compatm)%flds, 'Si_ifrac')
+ call addfld(fldListTo(compatm)%flds, 'So_ofrac')
- ! to atm
+ !=====================================================================
+ ! FIELDS TO OCEAN (compocn)
+ !=====================================================================
- call NUOPC_CompAttributeGet(gcomp, name='ice2atm_fmapname', value=ice2atm_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ice2atm_fmapname = '// trim(ice2atm_fmap), ESMF_LOGMSG_INFO)
- end if
+ !----------------------------------------------------------
+ ! to ocn: req. fields to satisfy mediator (can be removed later)
+ !----------------------------------------------------------
+ allocate(flds(2))
+ flds = (/'Faxa_snowc', 'Faxa_snowl'/)
- call NUOPC_CompAttributeGet(gcomp, name='ice2atm_smapname', value=ice2atm_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ice2atm_smapname = '// trim(ice2atm_smap), ESMF_LOGMSG_INFO)
- end if
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ call addfld(fldListFr(compatm)%flds, trim(fldname))
+ call addfld(fldListTo(compocn)%flds, trim(fldname))
+ end do
+ deallocate(flds)
- call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', value=ocn2atm_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ocn2atm_smapname = '// trim(ocn2atm_smap), ESMF_LOGMSG_INFO)
- end if
+ allocate(flds(4))
+ flds = (/'Sa_topo', 'Sa_z ', 'Sa_ptem', 'Sa_pbot'/)
- call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', value=ocn2atm_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('ocn2atm_fmapname = '// trim(ocn2atm_fmap), ESMF_LOGMSG_INFO)
- end if
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ call addfld(fldListFr(compatm)%flds, trim(fldname))
+ call addfld(fldListTo(compocn)%flds, trim(fldname))
+ end do
+ deallocate(flds)
- ! to ice
+ !----------------------------------------------------------
+ ! to ocn: fractional ice coverage wrt ocean from ice
+ !----------------------------------------------------------
+ call addfld(fldListFr(compice)%flds, 'Si_ifrac')
+ call addfld(fldListTo(compocn)%flds, 'Si_ifrac')
- call NUOPC_CompAttributeGet(gcomp, name='atm2ice_fmapname', value=atm2ice_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ice_fmapname = '// trim(atm2ice_fmap), ESMF_LOGMSG_INFO)
- end if
+ ! ---------------------------------------------------------------------
+ ! to ocn: downward longwave heat flux from atm
+ ! to ocn: downward direct near-infrared incident solar radiation from atm
+ ! to ocn: downward diffuse near-infrared incident solar radiation from atm
+ ! to ocn: downward dirrect visible incident solar radiation from atm
+ ! to ocn: downward diffuse visible incident solar radiation from atm
+ ! ---------------------------------------------------------------------
+ allocate(flds(5))
+ flds = (/'Faxa_lwdn ', 'Faxa_swndr', 'Faxa_swndf', 'Faxa_swvdr', &
+ 'Faxa_swvdf'/)
- call NUOPC_CompAttributeGet(gcomp, name='atm2ice_smapname', value=atm2ice_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ice_smapname = '// trim(atm2ice_smap), ESMF_LOGMSG_INFO)
- end if
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ call addfld(fldListFr(compatm)%flds, trim(fldname))
+ call addfld(fldListTo(compocn)%flds, trim(fldname))
+ end do
+ deallocate(flds)
- call NUOPC_CompAttributeGet(gcomp, name='atm2ice_vmapname', value=atm2ice_vmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ice_vmapname = '// trim(atm2ice_vmap), ESMF_LOGMSG_INFO)
- end if
+ ! ---------------------------------------------------------------------
+ ! to ocn: longwave net heat flux
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds, 'Faxa_lwnet')
+ call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet')
- ! to ocn
+ ! ---------------------------------------------------------------------
+ ! to ocn: downward shortwave heat flux
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds, 'Faxa_swdn')
+ call addfld(fldListTo(compocn)%flds, 'Faxa_swdn')
- call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', value=atm2ocn_fmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ocn_fmapname = '// trim(atm2ocn_fmap), ESMF_LOGMSG_INFO)
- end if
+ ! ---------------------------------------------------------------------
+ ! to ocn: net shortwave radiation from atm
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds, 'Faxa_swnet')
+ call addfld(fldListTo(compocn)%flds, 'Foxx_swnet')
- call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', value=atm2ocn_smap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ocn_smapname = '// trim(atm2ocn_smap), ESMF_LOGMSG_INFO)
- end if
+ ! ---------------------------------------------------------------------
+ ! to ocn: precipitation rate from atm
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds, 'Faxa_rainc')
+ call addfld(fldListFr(compatm)%flds, 'Faxa_rainl')
+ call addfld(fldListFr(compatm)%flds, 'Faxa_rain' )
+ call addfld(fldListTo(compocn)%flds, 'Faxa_rain' )
- call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', value=atm2ocn_vmap, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_LogWrite('atm2ocn_vmapname = '// trim(atm2ocn_vmap), ESMF_LOGMSG_INFO)
- end if
+ ! ---------------------------------------------------------------------
+ ! to ocn: sensible heat flux from atm
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds , 'Faxa_sen')
+ call addfld(fldListTo(compocn)%flds , 'Foxx_sen')
- !----------------------------------------------------------
- ! Initialize if use 3d cartesian mapping for u,v
- !----------------------------------------------------------
+ ! ---------------------------------------------------------------------
+ ! to ocn: surface latent heat flux and evaporation water flux
+ ! ---------------------------------------------------------------------
+ call addfld(fldListFr(compatm)%flds , 'Faxa_lat')
+ call addfld(fldListTo(compocn)%flds , 'Foxx_lat')
- mapuv_with_cart3d = .false.
+ ! ---------------------------------------------------------------------
+ ! to ocn: sea level pressure from atm
+ ! to ocn: zonal wind at the lowest model level from atm
+ ! to ocn: meridional wind at the lowest model level from atm
+ ! to ocn: wind speed at the lowest model level from atm
+ ! to ocn: temperature at the lowest model level from atm
+ ! to ocn: sea surface skin temperature
+ ! to ocn: specific humidity at the lowest model level from atm
+ ! ---------------------------------------------------------------------
+ allocate(flds(7))
+ flds = (/'Sa_pslv', 'Sa_u ', 'Sa_v ', 'Sa_wspd', 'Sa_tbot', 'Sa_tskn', &
+ 'Sa_shum'/)
- !=====================================================================
- ! scalar information
- !=====================================================================
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ call addfld(fldListFr(compatm)%flds, trim(fldname))
+ call addfld(fldListTo(compocn)%flds, trim(fldname))
+ end do
+ deallocate(flds)
- if (phase == 'advertise') then
- call NUOPC_CompAttributeGet(gcomp, name="ScalarFieldName", value=cvalue, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- do n = 1,ncomps
- call addfld(fldListFr(n)%flds, trim(cvalue))
- call addfld(fldListTo(n)%flds, trim(cvalue))
- end do
- end if
+ ! ---------------------------------------------------------------------
+ ! to ocn: zonal and meridional surface stress from atm
+ ! ---------------------------------------------------------------------
+ allocate(suffix(2))
+ suffix = (/'taux', 'tauy'/)
+
+ do n = 1,size(suffix)
+ call addfld(fldListFr(compatm)%flds , 'Faxa_'//trim(suffix(n)))
+ call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(suffix(n)))
+ end do
+ deallocate(suffix)
!=====================================================================
- ! FIELDS TO MEDIATOR component (for fractions and atm/ocn flux calculation)
+ ! FIELDS TO ICE (compice)
!=====================================================================
- !----------------------------------------------------------
- ! to med: masks from components
- !----------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compocn)%flds, 'So_omask')
- call addfld(fldListFr(compice)%flds, 'Si_imask')
- else
- call addmap(fldListFr(compocn)%flds, 'So_omask', compice, mapfcopy, 'unset', 'unset')
- end if
-
! ---------------------------------------------------------------------
- ! to med: atm and ocn fields required for atm/ocn flux calculation
+ ! to ice: density at the lowest model level from atm
! ---------------------------------------------------------------------
- if (phase /= 'advertise') then
- allocate(flds(6))
- flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', 'Sa_shum'/)
- do n = 1,size(flds)
- fldname = trim(flds(n))
- call addfld(fldListFr(compatm)%flds, trim(fldname))
- if (trim(fldname) == 'Sa_u' .or. trim(fldname) == 'Sa_v') then
- !call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mappatch, 'one', atm2ocn_vmap)
- call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapbilnr, 'one', atm2ocn_smap)
- else
- call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapbilnr, 'one', atm2ocn_smap)
- end if
- end do
- deallocate(flds)
- end if
+ allocate(flds(1))
+ flds = (/'Sa_dens'/)
+
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ call addfld(fldListFr(compatm)%flds, trim(fldname))
+ call addfld(fldListTo(compice)%flds, trim(fldname))
+ end do
+ deallocate(flds)
! ---------------------------------------------------------------------
- ! to med: unused fields needed by the atm/ocn flux computation
+ ! to ice: zonal sea water velocity from ocn
! ---------------------------------------------------------------------
+ allocate(flds(2))
+ flds = (/'So_u ', 'So_v '/)
- if (phase /= 'advertise') then
- call addfld(fldListFr(compatm)%flds, 'Sa_u')
- !call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mappatch, 'one', atm2ocn_vmap)
- call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, mapbilnr, 'one', atm2ocn_vmap)
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ call addfld(fldListFr(compocn)%flds, trim(fldname))
+ call addfld(fldListTo(compice)%flds, trim(fldname))
+ end do
+ deallocate(flds)
- call addfld(fldListFr(compatm)%flds, 'Sa_v')
- !call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mappatch, 'one', atm2ocn_vmap)
- call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, mapbilnr, 'one', atm2ocn_vmap)
+ end subroutine esmFldsExchange_hafs_advt
- call addfld(fldListFr(compatm)%flds, 'Sa_z')
- call addmap(fldListFr(compatm)%flds, 'Sa_z' , compocn, mapbilnr, 'one', atm2ocn_smap)
+ !-----------------------------------------------------------------------------
- call addfld(fldListFr(compatm)%flds, 'Sa_tbot')
- call addmap(fldListFr(compatm)%flds, 'Sa_tbot', compocn, mapbilnr, 'one', atm2ocn_smap)
+ subroutine esmFldsExchange_hafs_init(gcomp, phase, rc)
+
+ use med_methods_mod , only : fldchk => med_methods_FB_FldChk
+ use med_internalstate_mod , only : InternalState
+ use esmFlds , only : med_fldList_type
+ use esmFlds , only : addmap => med_fldList_AddMap
+ use esmFlds , only : addmrg => med_fldList_AddMrg
+ use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch
+ use esmflds , only : mapfcopy, mapnstod, mapnstod_consd
+ use esmflds , only : mapnstod_consf
- call addfld(fldListFr(compatm)%flds, 'Sa_pbot')
- call addmap(fldListFr(compatm)%flds, 'Sa_pbot', compocn, mapbilnr, 'one', atm2ocn_smap)
+ ! input/output parameters:
+ type(ESMF_GridComp) :: gcomp
+ character(len=*) , intent(in) :: phase
+ integer , intent(inout) :: rc
- call addfld(fldListFr(compatm)%flds, 'Sa_shum')
- call addmap(fldListFr(compatm)%flds, 'Sa_shum', compocn, mapbilnr, 'one', atm2ocn_smap)
+ ! local variables:
+ type(InternalState) :: is_local
+ integer :: num, i, n
+ integer :: n1, n2, n3, n4
+ logical :: isPresent
+ !character(len=5) :: iso(2)
+ character(len=CL) :: cvalue
+ character(len=CS) :: name, fldname
+ type(gcomp_attr) :: hafs_attr
+ character(len=CS), allocatable :: flds(:)
+ character(len=CS), allocatable :: suffix(:)
+ character(len=*) , parameter :: subname='(esmFldsExchange_hafs_init)'
+ !--------------------------------------
- if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_ptem', rc=rc)) then
- call addfld(fldListFr(compatm)%flds, 'Sa_ptem')
- call addmap(fldListFr(compatm)%flds, 'Sa_ptem', compocn, mapbilnr, 'one', atm2ocn_smap)
- end if
+ rc = ESMF_SUCCESS
- if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Sa_dens', rc=rc)) then
- call addfld(fldListFr(compatm)%flds, 'Sa_dens')
- call addmap(fldListFr(compatm)%flds, 'Sa_dens', compocn, mapbilnr, 'one', atm2ocn_smap)
+ !---------------------------------------
+ ! Get the internal state
+ !---------------------------------------
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ !--------------------------------------
+ ! Merging arguments:
+ ! mrg_fromN = source component index that for the field to be merged
+ ! mrg_fldN = souce field name to be merged
+ ! mrg_typeN = merge type ('copy', 'copy_with_weights', 'sum',
+ ! 'sum_with_weights', 'merge')
+ ! NOTE:
+ ! mrg_from(compmed) can either be for mediator computed fields for atm/ocn
+ ! fluxes or for ocn albedos
+ !
+ ! NOTE:
+ ! FBMed_aoflux_o only refer to output fields to the atm/ocn that computed in
+ ! the atm/ocn flux calculations. Input fields required from either the atm
+ ! or the ocn for these computation will use the logical 'use_med_aoflux'
+ ! below. This is used to determine mappings between the atm and ocn needed
+ ! for these computations.
+ !--------------------------------------
+
+ call esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ !=====================================================================
+ ! FIELDS TO MEDIATOR component (for fractions and atm/ocn flux calculation)
+ !=====================================================================
+
+ !----------------------------------------------------------
+ ! to med: masks from components
+ !----------------------------------------------------------
+ call addmap(fldListFr(compocn)%flds, 'So_omask', compice, &
+ mapfcopy, 'unset', 'unset')
+
+ ! ---------------------------------------------------------------------
+ ! to med: atm and ocn fields required for atm/ocn flux calculation
+ ! ---------------------------------------------------------------------
+ allocate(flds(6))
+ flds = (/'Sa_u ', 'Sa_v ', 'Sa_z ', 'Sa_tbot', 'Sa_pbot', 'Sa_shum'/)
+ do n = 1,size(flds)
+ fldname = trim(flds(n))
+ if (trim(fldname) == 'Sa_u' .or. trim(fldname) == 'Sa_v') then
+ !call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ ! mappatch, 'one', hafs_attr%atm2ocn_vmap)
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ else
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
end if
+ end do
+ deallocate(flds)
+
+ ! ---------------------------------------------------------------------
+ ! to med: unused fields needed by the atm/ocn flux computation
+ ! ---------------------------------------------------------------------
+ !call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, &
+ ! mappatch, 'one', hafs_attr%atm2ocn_vmap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_u' , compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_vmap)
+ !call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, &
+ ! mappatch, 'one', hafs_attr%atm2ocn_vmap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_v' , compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_vmap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_z' , compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_tbot', compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_pbot', compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ call addmap(fldListFr(compatm)%flds, 'Sa_shum', compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ if (fldchk(is_local%wrap%FBImp(compatm,compatm),'Sa_ptem',rc=rc)) then
+ call addmap(fldListFr(compatm)%flds, 'Sa_ptem', compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ end if
+ if (fldchk(is_local%wrap%FBImp(compatm,compatm),'Sa_dens',rc=rc)) then
+ call addmap(fldListFr(compatm)%flds, 'Sa_dens', compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
end if
! ---------------------------------------------------------------------
! to med: swnet fluxes used for budget calculation
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, 'Faxa_swnet')
- else
- call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compocn, mapconsf, 'one', atm2ocn_fmap)
- end if
+ call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
!=====================================================================
! FIELDS TO ATMOSPHERE
!=====================================================================
- !----------------------------------------------------------
- ! to atm: Fractions
- !----------------------------------------------------------
- if (phase == 'advertise') then
- ! the following are computed in med_phases_prep_atm
- call addfld(fldListTo(compatm)%flds, 'Si_ifrac')
- call addfld(fldListTo(compatm)%flds, 'So_ofrac')
- end if
-
!=====================================================================
! FIELDS TO OCEAN (compocn)
!=====================================================================
@@ -279,16 +424,13 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
do n = 1,size(flds)
fldname = trim(flds(n))
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, trim(fldname))
- call addfld(fldListTo(compocn)%flds, trim(fldname))
- else
- if ( fldchk(is_local%wrap%FBexp(compocn) , trim(fldname), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compatm,compatm ), trim(fldname), rc=rc)) then
- call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, trim(fldname), &
- mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBexp(compocn),trim(fldname),rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, trim(fldname), &
+ mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
end if
end do
deallocate(flds)
@@ -298,16 +440,13 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
do n = 1,size(flds)
fldname = trim(flds(n))
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, trim(fldname))
- call addfld(fldListTo(compocn)%flds, trim(fldname))
- else
- if ( fldchk(is_local%wrap%FBexp(compocn) , trim(fldname), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compatm,compatm ), trim(fldname), rc=rc)) then
- call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapbilnr, 'one', atm2ocn_smap)
- call addmrg(fldListTo(compocn)%flds, trim(fldname), &
- mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBexp(compocn),trim(fldname),rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ call addmrg(fldListTo(compocn)%flds, trim(fldname), &
+ mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
end if
end do
deallocate(flds)
@@ -315,13 +454,10 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
!----------------------------------------------------------
! to ocn: fractional ice coverage wrt ocean from ice
!----------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compice)%flds, 'Si_ifrac')
- call addfld(fldListTo(compocn)%flds, 'Si_ifrac')
- else
- call addmap(fldListFr(compice)%flds, 'Si_ifrac', compocn, mapfcopy, 'unset', 'unset')
- call addmrg(fldListTo(compocn)%flds, 'Si_ifrac', mrg_from1=compice, mrg_fld1='Si_ifrac', mrg_type1='copy')
- end if
+ call addmap(fldListFr(compice)%flds, 'Si_ifrac', compocn, &
+ mapfcopy, 'unset', 'unset')
+ call addmrg(fldListTo(compocn)%flds, 'Si_ifrac', &
+ mrg_from1=compice, mrg_fld1='Si_ifrac', mrg_type1='copy')
! ---------------------------------------------------------------------
! to ocn: downward longwave heat flux from atm
@@ -331,20 +467,19 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
! to ocn: downward diffuse visible incident solar radiation from atm
! ---------------------------------------------------------------------
allocate(flds(5))
- flds = (/'Faxa_lwdn ', 'Faxa_swndr', 'Faxa_swndf', 'Faxa_swvdr', 'Faxa_swvdf'/)
+ flds = (/'Faxa_lwdn ', 'Faxa_swndr', 'Faxa_swndf', 'Faxa_swvdr', &
+ 'Faxa_swvdf'/)
do n = 1,size(flds)
fldname = trim(flds(n))
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, trim(fldname))
- call addfld(fldListTo(compocn)%flds, trim(fldname))
- else
- if ( fldchk(is_local%wrap%FBExp(compocn) , trim(fldname), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compatm,compatm), trim(fldname), rc=rc)) then
- call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, trim(fldname), mrg_from1=compatm, mrg_fld1=trim(fldname), &
- mrg_type1='copy_with_weights', mrg_fracname1='ofrac')
- end if
+ if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, trim(fldname), &
+ mrg_from1=compatm, mrg_fld1=trim(fldname), &
+ mrg_type1='copy_with_weights', mrg_fracname1='ofrac')
end if
end do
deallocate(flds)
@@ -352,90 +487,69 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
! ---------------------------------------------------------------------
! to ocn: longwave net heat flux
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, 'Faxa_lwnet')
- call addfld(fldListTo(compocn)%flds, 'Foxx_lwnet')
- else
- call addmap(fldListFr(compatm)%flds, 'Faxa_lwnet', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', &
- mrg_from1=compatm, mrg_fld1='Faxa_lwnet', mrg_type1='copy')
- end if
+ call addmap(fldListFr(compatm)%flds, 'Faxa_lwnet', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Foxx_lwnet', &
+ mrg_from1=compatm, mrg_fld1='Faxa_lwnet', mrg_type1='copy')
! ---------------------------------------------------------------------
! to ocn: downward shortwave heat flux
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, 'Faxa_swdn')
- call addfld(fldListTo(compocn)%flds, 'Faxa_swdn')
- else
- if (fldchk(is_local%wrap%FBImp(compatm, compatm), 'Faxa_swdn', rc=rc) .and. &
- fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_swdn', rc=rc)) then
- call addmap(fldListFr(compatm)%flds, 'Faxa_swdn', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Faxa_swdn', &
- mrg_from1=compatm, mrg_fld1='Faxa_swdn', mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBImp(compatm,compatm),'Faxa_swdn',rc=rc) .and. &
+ fldchk(is_local%wrap%FBExp(compocn),'Faxa_swdn',rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, 'Faxa_swdn', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Faxa_swdn', &
+ mrg_from1=compatm, mrg_fld1='Faxa_swdn', mrg_type1='copy')
end if
! ---------------------------------------------------------------------
! to ocn: net shortwave radiation from atm
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, 'Faxa_swnet')
- call addfld(fldListTo(compocn)%flds, 'Foxx_swnet')
- else
- call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Foxx_swnet', &
- mrg_from1=compatm, mrg_fld1='Faxa_swnet', mrg_type1='copy')
- end if
+ call addmap(fldListFr(compatm)%flds, 'Faxa_swnet', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Foxx_swnet', &
+ mrg_from1=compatm, mrg_fld1='Faxa_swnet', mrg_type1='copy')
! ---------------------------------------------------------------------
! to ocn: precipitation rate from atm
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, 'Faxa_rainc')
- call addfld(fldListFr(compatm)%flds, 'Faxa_rainl')
- call addfld(fldListFr(compatm)%flds, 'Faxa_rain' )
- call addfld(fldListTo(compocn)%flds, 'Faxa_rain' )
- else
- if (fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl', rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc', rc=rc) .and. &
- fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_rain' , rc=rc)) then
- call addmap(fldListFr(compatm)%flds, 'Faxa_rainl', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmap(fldListFr(compatm)%flds, 'Faxa_rainc', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Faxa_rain', &
- mrg_from1=compatm, mrg_fld1='Faxa_rainc:Faxa_rainl', &
- mrg_type1='sum_with_weights', mrg_fracname1='ofrac')
- else if (fldchk(is_local%wrap%FBExp(compocn) , 'Faxa_rain', rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rain', rc=rc)) then
- call addmap(fldListFr(compatm)%flds, 'Faxa_rain', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Faxa_rain', mrg_from1=compatm, mrg_fld1='Faxa_rain', &
- mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBImp(compatm,compatm),'Faxa_rainl',rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),'Faxa_rainc',rc=rc) .and. &
+ fldchk(is_local%wrap%FBExp(compocn),'Faxa_rain',rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, 'Faxa_rainl', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmap(fldListFr(compatm)%flds, 'Faxa_rainc', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Faxa_rain', &
+ mrg_from1=compatm, mrg_fld1='Faxa_rainc:Faxa_rainl', &
+ mrg_type1='sum_with_weights', mrg_fracname1='ofrac')
+ else if (fldchk(is_local%wrap%FBExp(compocn),'Faxa_rain',rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),'Faxa_rain',rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, 'Faxa_rain', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Faxa_rain', &
+ mrg_from1=compatm, mrg_fld1='Faxa_rain', mrg_type1='copy')
end if
! ---------------------------------------------------------------------
! to ocn: sensible heat flux from atm
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds , 'Faxa_sen')
- call addfld(fldListTo(compocn)%flds , 'Foxx_sen')
- else
- call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Foxx_sen', &
- mrg_from1=compatm, mrg_fld1='Faxa_sen', mrg_type1='copy')
- end if
+ call addmap(fldListFr(compatm)%flds, 'Faxa_sen', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Foxx_sen', &
+ mrg_from1=compatm, mrg_fld1='Faxa_sen', mrg_type1='copy')
! ---------------------------------------------------------------------
! to ocn: surface latent heat flux and evaporation water flux
! ---------------------------------------------------------------------
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds , 'Faxa_lat')
- call addfld(fldListTo(compocn)%flds , 'Foxx_lat')
- else
- call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Foxx_lat', &
- mrg_from1=compatm, mrg_fld1='Faxa_lat', mrg_type1='copy')
- end if
+ call addmap(fldListFr(compatm)%flds, 'Faxa_lat', compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Foxx_lat', &
+ mrg_from1=compatm, mrg_fld1='Faxa_lat', mrg_type1='copy')
! ---------------------------------------------------------------------
! to ocn: sea level pressure from atm
@@ -447,20 +561,18 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
! to ocn: specific humidity at the lowest model level from atm
! ---------------------------------------------------------------------
allocate(flds(7))
- flds = (/'Sa_pslv', 'Sa_u ', 'Sa_v ', 'Sa_wspd', 'Sa_tbot', 'Sa_tskn', 'Sa_shum'/)
+ flds = (/'Sa_pslv', 'Sa_u ', 'Sa_v ', 'Sa_wspd', 'Sa_tbot', 'Sa_tskn', &
+ 'Sa_shum'/)
do n = 1,size(flds)
fldname = trim(flds(n))
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, trim(fldname))
- call addfld(fldListTo(compocn)%flds, trim(fldname))
- else
- if (fldchk(is_local%wrap%FBImp(compatm, compatm), trim(fldname), rc=rc) .and. &
- fldchk(is_local%wrap%FBExp(compocn) , trim(fldname), rc=rc)) then
- call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, mapbilnr, 'one', atm2ocn_smap)
- call addmrg(fldListTo(compocn)%flds, trim(fldname), &
- mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBExp(compocn),trim(fldname),rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compocn, &
+ mapbilnr, 'one', hafs_attr%atm2ocn_smap)
+ call addmrg(fldListTo(compocn)%flds, trim(fldname), &
+ mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
end if
end do
deallocate(flds)
@@ -472,14 +584,11 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
suffix = (/'taux', 'tauy'/)
do n = 1,size(suffix)
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds , 'Faxa_'//trim(suffix(n)))
- call addfld(fldListTo(compocn)%flds , 'Foxx_'//trim(suffix(n)))
- else
- call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(suffix(n)), compocn, mapconsf, 'one', atm2ocn_fmap)
- call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(suffix(n)), &
- mrg_from1=compatm, mrg_fld1='Faxa_'//trim(suffix(n)), mrg_type1='copy')
- end if
+ call addmap(fldListFr(compatm)%flds, 'Faxa_'//trim(suffix(n)), compocn, &
+ mapconsf, 'one', hafs_attr%atm2ocn_fmap)
+ call addmrg(fldListTo(compocn)%flds, 'Foxx_'//trim(suffix(n)), &
+ mrg_from1=compatm, mrg_fld1='Faxa_'//trim(suffix(n)), &
+ mrg_type1='copy')
end do
deallocate(suffix)
@@ -495,16 +604,13 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
do n = 1,size(flds)
fldname = trim(flds(n))
- if (phase == 'advertise') then
- call addfld(fldListFr(compatm)%flds, trim(fldname))
- call addfld(fldListTo(compice)%flds, trim(fldname))
- else
- if ( fldchk(is_local%wrap%FBexp(compice) , trim(fldname), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compatm,compatm ), trim(fldname), rc=rc)) then
- call addmap(fldListFr(compatm)%flds, trim(fldname), compice, mapbilnr, 'one', atm2ice_smap)
- call addmrg(fldListTo(compice)%flds, trim(fldname), &
- mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBexp(compice),trim(fldname),rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compatm,compatm),trim(fldname),rc=rc) &
+ ) then
+ call addmap(fldListFr(compatm)%flds, trim(fldname), compice, &
+ mapbilnr, 'one', hafs_attr%atm2ice_smap)
+ call addmrg(fldListTo(compice)%flds, trim(fldname), &
+ mrg_from1=compatm, mrg_fld1=trim(fldname), mrg_type1='copy')
end if
end do
deallocate(flds)
@@ -517,20 +623,125 @@ subroutine esmFldsExchange_hafs(gcomp, phase, rc)
do n = 1,size(flds)
fldname = trim(flds(n))
- if (phase == 'advertise') then
- call addfld(fldListFr(compocn)%flds, trim(fldname))
- call addfld(fldListTo(compice)%flds, trim(fldname))
- else
- if ( fldchk(is_local%wrap%FBexp(compice) , trim(fldname), rc=rc) .and. &
- fldchk(is_local%wrap%FBImp(compocn,compocn), trim(fldname), rc=rc)) then
- call addmap(fldListFr(compocn)%flds, trim(fldname), compice, mapfcopy , 'unset', 'unset')
- call addmrg(fldListTo(compice)%flds, trim(fldname), &
- mrg_from1=compocn, mrg_fld1=trim(fldname), mrg_type1='copy')
- end if
+ if (fldchk(is_local%wrap%FBexp(compice),trim(fldname),rc=rc) .and. &
+ fldchk(is_local%wrap%FBImp(compocn,compocn),trim(fldname),rc=rc) &
+ ) then
+ call addmap(fldListFr(compocn)%flds, trim(fldname), compice, &
+ mapfcopy , 'unset', 'unset')
+ call addmrg(fldListTo(compice)%flds, trim(fldname), &
+ mrg_from1=compocn, mrg_fld1=trim(fldname), mrg_type1='copy')
end if
end do
deallocate(flds)
- end subroutine esmFldsExchange_hafs
+ end subroutine esmFldsExchange_hafs_init
+
+ !-----------------------------------------------------------------------------
+
+ subroutine esmFldsExchange_hafs_attr(gcomp, hafs_attr, rc)
+
+ ! input/output parameters:
+ type(ESMF_GridComp) :: gcomp
+ type(gcomp_attr) , intent(inout) :: hafs_attr
+ integer , intent(inout) :: rc
+
+ ! local variables:
+ logical :: isPresent
+ character(len=*) , parameter :: subname='(esmFldsExchange_hafs_attr)'
+ !--------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ !----------------------------------------------------------
+ ! Initialize mapping file names
+ !----------------------------------------------------------
+
+ ! to atm
+
+ call NUOPC_CompAttributeGet(gcomp, name='ice2atm_fmapname', &
+ value=hafs_attr%ice2atm_fmap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('ice2atm_fmapname = '//trim(hafs_attr%ice2atm_fmap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='ice2atm_smapname', &
+ value=hafs_attr%ice2atm_smap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('ice2atm_smapname = '//trim(hafs_attr%ice2atm_smap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_smapname', &
+ value=hafs_attr%ocn2atm_smap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('ocn2atm_smapname = '//trim(hafs_attr%ocn2atm_smap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='ocn2atm_fmapname', &
+ value=hafs_attr%ocn2atm_fmap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('ocn2atm_fmapname = '//trim(hafs_attr%ocn2atm_fmap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ ! to ice
+
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ice_fmapname', &
+ value=hafs_attr%atm2ice_fmap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('atm2ice_fmapname = '//trim(hafs_attr%atm2ice_fmap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ice_smapname', &
+ value=hafs_attr%atm2ice_smap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('atm2ice_smapname = '//trim(hafs_attr%atm2ice_smap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ice_vmapname', &
+ value=hafs_attr%atm2ice_vmap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('atm2ice_vmapname = '//trim(hafs_attr%atm2ice_vmap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ ! to ocn
+
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_fmapname', &
+ value=hafs_attr%atm2ocn_fmap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('atm2ocn_fmapname = '//trim(hafs_attr%atm2ocn_fmap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_smapname', &
+ value=hafs_attr%atm2ocn_smap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('atm2ocn_smapname = '//trim(hafs_attr%atm2ocn_smap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='atm2ocn_vmapname', &
+ value=hafs_attr%atm2ocn_vmap, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call ESMF_LogWrite('atm2ocn_vmapname = '//trim(hafs_attr%atm2ocn_vmap), &
+ ESMF_LOGMSG_INFO)
+ end if
+
+ end subroutine esmFldsExchange_hafs_attr
end module esmFldsExchange_hafs_mod
diff --git a/mediator/esmFldsExchange_nems_mod.F90 b/mediator/esmFldsExchange_nems_mod.F90
index 7d5e7eabe..cc61512b8 100644
--- a/mediator/esmFldsExchange_nems_mod.F90
+++ b/mediator/esmFldsExchange_nems_mod.F90
@@ -31,7 +31,7 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc)
use esmflds , only : compmed, compatm, compocn, compice, comprof, ncomps
use esmflds , only : mapbilnr, mapconsf, mapconsd, mappatch
use esmflds , only : mapfcopy, mapnstod, mapnstod_consd, mapnstod_consf
- use esmflds , only : coupling_mode, mapuv_with_cart3d, mapnames
+ use esmflds , only : coupling_mode, mapnames
use esmflds , only : fldListTo, fldListFr, fldListMed_aoflux, fldListMed_ocnalb
use med_internalstate_mod , only : mastertask, logunit
@@ -51,9 +51,6 @@ subroutine esmFldsExchange_nems(gcomp, phase, rc)
rc = ESMF_SUCCESS
- ! Initialize if use 3d cartesian mapping for u,v
- mapuv_with_cart3d = .false.
-
! Set maptype according to coupling_mode
if (trim(coupling_mode) == 'nems_orig' .or. trim(coupling_mode) == 'nems_orig_data') then
maptype = mapnstod_consf
diff --git a/mediator/med.F90 b/mediator/med.F90
index eb51b936b..d65d935f1 100644
--- a/mediator/med.F90
+++ b/mediator/med.F90
@@ -14,16 +14,15 @@ module MED
use med_utils_mod , only : chkerr => med_utils_ChkErr
use med_methods_mod , only : Field_GeomPrint => med_methods_Field_GeomPrint
use med_methods_mod , only : State_GeomPrint => med_methods_State_GeomPrint
- use med_methods_mod , only : State_GeomWrite => med_methods_State_GeomWrite
use med_methods_mod , only : State_reset => med_methods_State_reset
use med_methods_mod , only : State_getNumFields => med_methods_State_getNumFields
use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
use med_methods_mod , only : FB_Init => med_methods_FB_init
use med_methods_mod , only : FB_Init_pointer => med_methods_FB_Init_pointer
use med_methods_mod , only : FB_Reset => med_methods_FB_Reset
- use med_methods_mod , only : FB_Copy => med_methods_FB_Copy
use med_methods_mod , only : FB_FldChk => med_methods_FB_FldChk
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
+ use med_methods_mod , only : FB_getFieldN => med_methods_FB_getFieldN
use med_methods_mod , only : clock_timeprint => med_methods_clock_timeprint
use med_time_mod , only : alarmInit => med_time_alarmInit
use med_utils_mod , only : memcheck => med_memcheck
@@ -56,6 +55,8 @@ module MED
private InitializeIPDv03p5 ! realize all Fields with transfer action "accept"
private DataInitialize ! finish initialization and resolve data dependencies
private SetRunClock
+ private med_meshinfo_create
+ private med_grid_write
private med_finalize
character(len=*), parameter :: grid_arbopt = "grid_reg" ! grid_reg or grid_arb
@@ -69,7 +70,8 @@ module MED
subroutine SetServices(gcomp, rc)
- use ESMF , only: ESMF_SUCCESS, ESMF_GridCompSetEntryPoint, ESMF_METHOD_INITIALIZE, ESMF_METHOD_RUN
+ use ESMF , only: ESMF_SUCCESS, ESMF_GridCompSetEntryPoint
+ use ESMF , only: ESMF_METHOD_INITIALIZE, ESMF_METHOD_RUN
use ESMF , only: ESMF_GridComp, ESMF_MethodRemove
use NUOPC , only: NUOPC_CompDerive, NUOPC_CompSetEntryPoint, NUOPC_CompSpecialize, NUOPC_NOOP
use NUOPC_Mediator , only: mediator_routine_SS => SetServices
@@ -96,12 +98,23 @@ subroutine SetServices(gcomp, rc)
use med_phases_prep_ocn_mod , only: med_phases_prep_ocn_accum_avg
use med_phases_ocnalb_mod , only: med_phases_ocnalb_run
use med_phases_aofluxes_mod , only: med_phases_aofluxes_run
+ use med_diag_mod , only: med_phases_diag_accum, med_phases_diag_print
+ use med_diag_mod , only: med_phases_diag_atm
+ use med_diag_mod , only: med_phases_diag_lnd
+ use med_diag_mod , only: med_phases_diag_rof
+ use med_diag_mod , only: med_phases_diag_glc
+ use med_diag_mod , only: med_phases_diag_ocn
+ use med_diag_mod , only: med_phases_diag_ice_ice2med, med_phases_diag_ice_med2ice
use med_fraction_mod , only: med_fraction_init, med_fraction_set
use med_phases_profile_mod , only: med_phases_profile
+ ! input/output variables
type(ESMF_GridComp) :: gcomp
integer, intent(out) :: rc
- character(len=*),parameter :: subname='(module_MED:SetServices)'
+
+ ! local variables
+ character(len=*),parameter :: subname=' (module_MED:SetServices) '
+ !-----------------------------------------------------------
rc = ESMF_SUCCESS
if (profile_memory) call ESMF_VMLogMemInfo("Entering "//trim(subname))
@@ -345,6 +358,64 @@ subroutine SetServices(gcomp, rc)
specPhaseLabel="med_fraction_set", specRoutine=med_fraction_set, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ !------------------
+ ! phase routines for budget diagnostics
+ !------------------
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_atm"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_atm", specRoutine=med_phases_diag_atm, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_lnd"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_lnd", specRoutine=med_phases_diag_lnd, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_rof"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_rof", specRoutine=med_phases_diag_rof, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_ocn"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_ocn", specRoutine=med_phases_diag_ocn, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_glc"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_glc", specRoutine=med_phases_diag_glc, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_ice_ice2med"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_ice_ice2med", specRoutine=med_phases_diag_ice_ice2med, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_ice_med2ice"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_ice_med2ice", specRoutine=med_phases_diag_ice_med2ice, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_accum"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaselabel="med_phases_diag_accum", specRoutine=med_phases_diag_accum, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call NUOPC_CompSetEntryPoint(gcomp, ESMF_METHOD_RUN, &
+ phaseLabelList=(/"med_phases_diag_print"/), userRoutine=mediator_routine_Run, rc=rc)
+ call NUOPC_CompSpecialize(gcomp, specLabel=mediator_label_Advance, &
+ specPhaseLabel="med_phases_diag_print", specRoutine=med_phases_diag_print, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
!------------------
! attach specializing method(s)
! -> NUOPC specializes by default --->>> first need to remove the default
@@ -383,7 +454,7 @@ end subroutine SetServices
subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
use ESMF , only : ESMF_GridComp, ESMF_State, ESMF_Clock, ESMF_VM, ESMF_SUCCESS
- use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_AttributeGet
+ use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_AttributeGet, ESMF_AttributeSet
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_METHOD_INITIALIZE
use NUOPC , only : NUOPC_CompFilterPhaseMap, NUOPC_CompAttributeGet
use med_internalstate_mod, only : mastertask, logunit
@@ -401,7 +472,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
character(len=CX) :: msgString
character(len=CX) :: diro
character(len=CX) :: logfile
- character(len=*),parameter :: subname='(module_MED:InitializeP0)'
+ character(len=*),parameter :: subname=' (module_MED:InitializeP0) '
!-----------------------------------------------------------
rc = ESMF_SUCCESS
@@ -436,11 +507,6 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call ESMF_LogWrite(trim(subname)//": Mediator verbosity is "//trim(cvalue), ESMF_LOGMSG_INFO)
- call ESMF_AttributeGet(gcomp, name="Verbosity", value=cvalue, &
- convention="NUOPC", purpose="Instance", rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_LogWrite(trim(subname)//": Mediator verbosity is set to "//trim(cvalue), ESMF_LOGMSG_INFO)
-
call ESMF_AttributeGet(gcomp, name="Profiling", value=cvalue, &
convention="NUOPC", purpose="Instance", rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -504,7 +570,7 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc)
character(len=8) :: glc_present, med_present
character(len=8) :: ocn_present, wav_present
character(len=CS) :: attrList(8)
- character(len=*),parameter :: subname='(module_MED:InitializeIPDv03p1)'
+ character(len=*),parameter :: subname=' (module_MED:InitializeIPDv03p1) '
!-----------------------------------------------------------
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
@@ -637,6 +703,12 @@ subroutine InitializeIPDv03p1(gcomp, importState, exportState, clock, rc)
if (trim(cvalue) /= 'sglc') glc_present = "true"
end if
+ call NUOPC_CompAttributeGet(gcomp, name='mediator_present', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ med_present = trim(cvalue)
+ end if
+
call NUOPC_CompAttributeSet(gcomp, name="atm_present", value=atm_present, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
call NUOPC_CompAttributeSet(gcomp, name="lnd_present", value=lnd_present, rc=rc)
@@ -764,7 +836,7 @@ subroutine InitializeIPDv03p3(gcomp, importState, exportState, clock, rc)
type(InternalState) :: is_local
type(ESMF_VM) :: vm
integer :: n
- character(len=*),parameter :: subname='(module_MED:InitializeIPDv03p3)'
+ character(len=*),parameter :: subname=' (module_MED:InitializeIPDv03p3) '
!-----------------------------------------------------------
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
@@ -829,7 +901,7 @@ subroutine InitializeIPDv03p4(gcomp, importState, exportState, clock, rc)
! local variables
type(InternalState) :: is_local
integer :: n1,n2
- character(len=*),parameter :: subname='(module_MED:realizeConnectedGrid)'
+ character(len=*),parameter :: subname=' (module_MED:InitalizeIPDv03p4) '
!-----------------------------------------------------------
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
@@ -899,7 +971,7 @@ subroutine realizeConnectedGrid(State,string,rc)
character(ESMF_MAXSTR),allocatable :: fieldNameList(:)
type(ESMF_FieldStatus_Flag) :: fieldStatus
character(len=CX) :: msgString
- character(len=*),parameter :: subname='(module_MEDIATOR:realizeConnectedGrid)'
+ character(len=*),parameter :: subname=' (module_MED:realizeConnectedGrid) '
!-----------------------------------------------------------
!NOTE: All of the Fields that set their TransferOfferGeomObject Attribute
@@ -1277,7 +1349,7 @@ subroutine InitializeIPDv03p5(gcomp, importState, exportState, clock, rc)
! local variables
type(InternalState) :: is_local
integer :: n1,n2
- character(len=*),parameter :: subname='(module_MED:InitializeIPDv03p5)'
+ character(len=*),parameter :: subname=' (module_MED:InitializeIPDv03p5) '
!-----------------------------------------------------------
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
@@ -1317,9 +1389,6 @@ subroutine InitializeIPDv03p5(gcomp, importState, exportState, clock, rc)
if (dbug_flag > 1) then
call State_GeomPrint(is_local%wrap%NStateExp(n1),'gridExp'//trim(compname(n1)),rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
- call State_GeomWrite(is_local%wrap%NStateExp(n1), 'grid_med_'//trim(compname(n1)), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
endif
enddo
@@ -1349,7 +1418,7 @@ subroutine completeFieldInitialization(State,rc)
type(ESMF_Grid) :: grid
type(ESMF_Mesh) :: mesh
type(ESMF_Field) :: meshField
- type(ESMF_Field),pointer :: fieldList(:)
+ type(ESMF_Field),pointer :: fieldList(:) => null()
type(ESMF_FieldStatus_Flag) :: fieldStatus
type(ESMF_GeomType_Flag) :: geomtype
integer :: gridToFieldMapCount, ungriddedCount
@@ -1357,7 +1426,7 @@ subroutine completeFieldInitialization(State,rc)
integer, allocatable :: ungriddedLBound(:), ungriddedUBound(:)
logical :: isPresent
logical :: meshcreated
- character(len=*),parameter :: subname='(module_MED:completeFieldInitialization)'
+ character(len=*),parameter :: subname=' (module_MED:completeFieldInitialization) '
!-----------------------------------------------------------
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
@@ -1503,7 +1572,8 @@ subroutine DataInitialize(gcomp, rc)
use med_phases_ocnalb_mod , only : med_phases_ocnalb_run
use med_phases_aofluxes_mod , only : med_phases_aofluxes_run
use med_phases_profile_mod , only : med_phases_profile
- use med_map_mod , only : med_map_MapNorm_init, med_map_RouteHandles_init
+ use med_diag_mod , only : med_diag_zero, med_diag_init
+ use med_map_mod , only : med_map_mapnorm_init, med_map_routehandles_init, med_map_packed_field_create
use med_io_mod , only : med_io_init
! input/output variables
@@ -1520,11 +1590,12 @@ subroutine DataInitialize(gcomp, rc)
type(ESMF_StateItem_Flag) :: itemType
logical :: atCorrectTime, connected
integer :: n1,n2,n
+ integer :: nsrc,ndst
integer :: cntn1, cntn2
integer :: fieldCount
character(ESMF_MAXSTR),allocatable :: fieldNameList(:)
character(CL) :: value
- character(CL), pointer :: fldnames(:)
+ character(CL), pointer :: fldnames(:) => null()
character(CL) :: cvalue
character(CL) :: start_type
logical :: read_restart
@@ -1533,7 +1604,7 @@ subroutine DataInitialize(gcomp, rc)
logical,save :: first_call = .true.
real(r8) :: real_nx, real_ny
character(len=CX) :: msgString
- character(len=*), parameter :: subname='(module_MED:DataInitialize)'
+ character(len=*), parameter :: subname=' (module_MED:DataInitialize) '
!-----------------------------------------------------------
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
@@ -1689,6 +1760,10 @@ subroutine DataInitialize(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
is_local%wrap%FBExpAccumCnt(n1) = 0
+ ! Create mesh info data
+ call med_meshinfo_create(is_local%wrap%FBImp(n1,n1), &
+ is_local%wrap%mesh_info(n1), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
! The following are FBImp and FBImpAccum mapped to different grids.
@@ -1812,14 +1887,49 @@ subroutine DataInitialize(gcomp, rc)
!---------------------------------------
! Initialize route handles and required normalization field bunds
+ ! Initialized packed field data structures
!---------------------------------------
call med_map_RouteHandles_init(gcomp, logunit, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call med_map_MapNorm_init(gcomp, logunit, rc)
+ call med_map_mapnorm_init(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ do ndst = 1,ncomps
+ do nsrc = 1,ncomps
+ if (is_local%wrap%med_coupling_active(nsrc,ndst)) then
+ call med_map_packed_field_create(ndst, &
+ is_local%wrap%flds_scalar_name, &
+ fldsSrc=fldListFr(nsrc)%flds, &
+ FBSrc=is_local%wrap%FBImp(nsrc,nsrc), &
+ FBDst=is_local%wrap%FBImp(nsrc,ndst), &
+ packed_data=is_local%wrap%packed_data(nsrc,ndst,:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ end do
+ end do
+ if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o) .and. &
+ ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_a)) then
+ call med_map_packed_field_create(compatm, &
+ is_local%wrap%flds_scalar_name, &
+ fldsSrc=fldListMed_aoflux%flds, &
+ FBSrc=is_local%wrap%FBMed_aoflux_o, &
+ FBDst=is_local%wrap%FBMed_aoflux_a, &
+ packed_data=is_local%wrap%packed_data_aoflux_o2a(:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ if ( ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_o) .and. &
+ ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_ocnalb_a)) then
+ call med_map_packed_field_create(compatm, &
+ is_local%wrap%flds_scalar_name, &
+ fldsSrc=fldListMed_ocnalb%flds, &
+ FBSrc=is_local%wrap%FBMed_ocnalb_o, &
+ FBDst=is_local%wrap%FBMed_ocnalb_a, &
+ packed_data=is_local%wrap%packed_data_ocnalb_o2a(:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+
!---------------------------------------
! Set the data initialize flag to false
!---------------------------------------
@@ -1897,7 +2007,7 @@ subroutine DataInitialize(gcomp, rc)
allocate(fieldNameList(fieldCount))
call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemNameList=fieldNameList, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- do n=1, fieldCount
+ do n = 1,fieldCount
call ESMF_StateGet(is_local%wrap%NStateImp(n1), itemName=fieldNameList(n), field=field, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
atCorrectTime = NUOPC_IsAtTime(field, time, rc=rc)
@@ -2037,9 +2147,18 @@ subroutine DataInitialize(gcomp, rc)
call med_io_init()
- !---------------------------------------
- ! read mediator restarts
- !---------------------------------------
+ !---------------------------------------
+ ! Initialize mediator water/heat budget diags
+ !---------------------------------------
+
+ call med_diag_init(gcomp, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_diag_zero(gcomp, mode='all', rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ !---------------------------------------
+ ! read mediator restarts
+ !---------------------------------------
call NUOPC_CompAttributeGet(gcomp, name="read_restart", value=cvalue, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -2056,12 +2175,10 @@ subroutine DataInitialize(gcomp, rc)
else ! Not all done
call NUOPC_CompAttributeSet(gcomp, name="InitializeDataComplete", value="false", rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
call ESMF_LogWrite("MED - Initialize-Data-Dependency allDone check Failed, another loop is required", &
ESMF_LOGMSG_INFO)
end if
-
if (profile_memory) call ESMF_VMLogMemInfo("Leaving "//trim(subname))
if (dbug_flag > 5) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
@@ -2090,17 +2207,12 @@ subroutine SetRunClock(gcomp, rc)
type(ESMF_Time) :: currTime
type(ESMF_TimeInterval) :: timeStep
character(len=CL) :: cvalue
- character(len=CL) :: restart_option ! Restart option units
- integer :: restart_n ! Number until restart interval
- integer :: restart_ymd ! Restart date (YYYYMMDD)
- type(ESMF_ALARM) :: restart_alarm
type(ESMF_ALARM) :: glc_avg_alarm
logical :: glc_present
character(len=CS) :: glc_avg_period
integer :: glc_cpl_dt
- type(ESMF_ALARM) :: alarm
logical :: first_time = .true.
- character(len=*),parameter :: subname='(module_MED:SetRunClock)'
+ character(len=*),parameter :: subname=' (module_MED:SetRunClock) '
!-----------------------------------------------------------
rc = ESMF_SUCCESS
@@ -2138,6 +2250,7 @@ subroutine SetRunClock(gcomp, rc)
!--------------------------------
if (first_time) then
+
! Set glc averaging alarm if appropriate
call NUOPC_CompAttributeGet(gcomp, name="glc_present", value=cvalue, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -2170,7 +2283,6 @@ subroutine SetRunClock(gcomp, rc)
call ESMF_AlarmSet(glc_avg_alarm, clock=mediatorclock, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
-
first_time = .false.
end if
@@ -2192,24 +2304,74 @@ end subroutine SetRunClock
!-----------------------------------------------------------------------------
- subroutine med_finalize(gcomp, rc)
+ subroutine med_meshinfo_create(FB, mesh_info, rc)
- use ESMF, only : ESMF_GridComp, ESMF_SUCCESS
+ use ESMF , only : ESMF_Array, ESMF_ArrayCreate, ESMF_ArrayDestroy, ESMF_Field, ESMF_FieldGet
+ use ESMF , only : ESMF_DistGrid, ESMF_FieldBundle, ESMF_FieldRegridGetArea, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8
+ use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_LogWrite, ESMF_LOGMSG_INFO
+ use med_internalstate_mod , only : mesh_info_type
- type(ESMF_GridComp) :: gcomp
- integer, intent(out) :: rc
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ type(mesh_info_type) , intent(inout) :: mesh_info
+ integer , intent(out) :: rc
- rc = ESMF_SUCCESS
- call memcheck("med_finalize", 0, mastertask)
- if (mastertask) then
- write(logunit,*)' SUCCESSFUL TERMINATION OF CMEPS'
- call med_phases_profile_finalize()
- end if
+ ! local variables
+ type(ESMF_Field) :: lfield
+ type(ESMF_Mesh) :: lmesh
+ type(ESMF_Array) :: lArray
+ type(ESMF_DistGrid) :: lDistGrid
+ integer :: numOwnedElements
+ integer :: spatialDim
+ real(r8), allocatable :: ownedElemCoords(:)
+ real(r8), pointer :: dataptr(:) => null()
+ integer :: n, dimcount, fieldcount
+ character(len=*),parameter :: subname=' (module_MED:med_meshinfo_create) '
+ !-------------------------------------------------------------------------------
- end subroutine med_finalize
+ rc= ESMF_SUCCESS
- !-----------------------------------------------------------------------------
+ call ESMF_FieldBundleGet(FB, fieldCount=fieldCount, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! Find the first field in FB with dimcount==1
+ do n=1,fieldCount
+ call FB_getFieldN(FB, fieldnum=n, field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_FieldGet(lfield, mesh=lmesh, dimcount=dimCount, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (dimCount==1) exit
+ enddo
+ call ESMF_FieldRegridGetArea(lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_MeshGet(lmesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, &
+ elementDistGrid=lDistGrid, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! Allocate mesh_info data, we need a copy here because the FB may get reset later
+ allocate(mesh_info%areas(numOwnedElements))
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ mesh_info%areas = dataptr
+
+ allocate(mesh_info%lats(numOwnedElements))
+ allocate(mesh_info%lons(numOwnedElements))
+
+ ! Obtain mesh longitudes and latitudes
+ allocate(ownedElemCoords(spatialDim*numOwnedElements))
+ call ESMF_MeshGet(lmesh, ownedElemCoords=ownedElemCoords)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,numOwnedElements
+ mesh_info%lons(n) = ownedElemCoords(2*n-1)
+ mesh_info%lats(n) = ownedElemCoords(2*n)
+ end do
+ deallocate(ownedElemCoords)
+
+ end subroutine med_meshinfo_create
+
+ !-----------------------------------------------------------------------------
subroutine med_grid_write(grid, fileName, rc)
use ESMF, only : ESMF_Grid, ESMF_Array, ESMF_ArrayBundle
@@ -2229,7 +2391,7 @@ subroutine med_grid_write(grid, fileName, rc)
type(ESMF_ArrayBundle) :: arrayBundle
integer :: tileCount
logical :: isPresent
- character(len=*), parameter :: subname='(module_MED_Map:med_grid_write)'
+ character(len=*), parameter :: subname=' (module_MED_map:med_grid_write) '
!-------------------------------------------------------------------------------
rc = ESMF_SUCCESS
@@ -2383,4 +2545,20 @@ end subroutine med_grid_write
!-----------------------------------------------------------------------------
+ subroutine med_finalize(gcomp, rc)
+
+ use ESMF, only : ESMF_GridComp, ESMF_SUCCESS
+
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out) :: rc
+
+ rc = ESMF_SUCCESS
+ call memcheck("med_finalize", 0, mastertask)
+ if (mastertask) then
+ write(logunit,*)' SUCCESSFUL TERMINATION OF CMEPS'
+ call med_phases_profile_finalize()
+ end if
+
+ end subroutine med_finalize
+
end module MED
diff --git a/mediator/med_diag_mod.F90 b/mediator/med_diag_mod.F90
new file mode 100644
index 000000000..cae818903
--- /dev/null
+++ b/mediator/med_diag_mod.F90
@@ -0,0 +1,2417 @@
+module med_diag_mod
+
+ !----------------------------------------------------------------------------
+ ! Compute spatial and time averages of fluxed quatities for water and
+ ! energy balance
+ !
+ ! Sign convention for fluxes is positive downward with hierarchy being
+ ! atm/glc/lnd/rof/ice/ocn
+ ! Sign convention:
+ ! positive value <=> the model is gaining water, heat, momentum, etc.
+ ! Unit convention:
+ ! heat flux ~ W/m^2
+ ! momentum flux ~ N/m^2
+ ! water flux ~ (kg/s)/m^2
+ ! salt flux ~ (kg/s)/m^2
+ !----------------------------------------------------------------------------
+
+ use NUOPC , only : NUOPC_CompAttributeGet, NUOPC_CompAttributeSet, NUOPC_CompAttributeAdd
+ use NUOPC_Mediator , only : NUOPC_MediatorGet
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
+ use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR
+ use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time
+ use ESMF , only : ESMF_VM, ESMF_VMReduce, ESMF_REDUCE_SUM
+ use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet
+ use ESMF , only : ESMF_Alarm, ESMF_ClockGetAlarm, ESMF_AlarmIsRinging
+ use ESMF , only : ESMF_FieldBundle, ESMF_AlarmRingerOff
+ 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_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
+ use med_methods_mod , only : FB_FldChk => med_methods_FB_FldChk
+ use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
+ use med_time_mod , only : alarmInit => med_time_alarmInit
+ use med_utils_mod , only : chkerr => med_utils_ChkErr
+
+ implicit none
+ private
+
+ public :: med_diag_init
+ public :: med_diag_zero
+ public :: med_phases_diag_accum
+ public :: med_phases_diag_atm
+ public :: med_phases_diag_lnd
+ public :: med_phases_diag_rof
+ public :: med_phases_diag_glc
+ public :: med_phases_diag_ocn
+ public :: med_phases_diag_ice_ice2med
+ public :: med_phases_diag_ice_med2ice
+ public :: med_phases_diag_print
+
+ private :: med_diag_sum_master
+ private :: med_diag_print_atm
+ private :: med_diag_print_lnd_ice_ocn
+ private :: med_diag_print_summary
+
+ type, public :: budget_diag_type
+ character(CS) :: name
+ end type budget_diag_type
+ type, public :: budget_diag_indices
+ type(budget_diag_type), pointer :: comps(:) => null()
+ type(budget_diag_type), pointer :: fields(:) => null()
+ type(budget_diag_type), pointer :: periods(:) => null()
+ end type budget_diag_indices
+ type(budget_diag_indices) :: budget_diags
+
+ ! ---------------------------------
+ ! print options (obtained from mediator config input)
+ ! ---------------------------------
+
+ ! sets the diagnotics level of the annual budgets. [0,1,2,3],
+ ! 0 = none,
+ ! 1 = net summary budgets
+ ! 2 = 1 + detailed lnd/ocn/ice component budgets
+ ! 3 = 2 + detailed atm budgets
+
+ integer :: budget_print_inst ! default is 0
+ integer :: budget_print_daily ! default is 0
+ integer :: budget_print_month ! default is 1
+ integer :: budget_print_ann ! default is 1
+ integer :: budget_print_ltann ! default is 1
+ integer :: budget_print_ltend ! default is 0
+
+ ! formats for output tables
+ character(*), parameter :: F00 = "('(med_phases_diag_print) ',4a)"
+ character(*), parameter :: FAH = "(4a,i9,i6)"
+ character(*), parameter :: FA0 = "(' ',12x,6(6x,a8,1x))"
+ character(*), parameter :: FA1 = "(' ',a12,6f15.8)"
+ character(*), parameter :: FA0r = "(' ',12x,8(6x,a8,1x))"
+ character(*), parameter :: FA1r = "(' ',a12,8f15.8)"
+
+ ! ---------------------------------
+ ! C for component
+ ! ---------------------------------
+
+ ! "r" is receive from the component to the mediator
+ ! "s" is send from the mediator to the component
+
+ integer :: c_atm_send ! model index: atm
+ integer :: c_atm_recv ! model index: atm
+ integer :: c_inh_send ! model index: ice, northern
+ integer :: c_inh_recv ! model index: ice, northern
+ integer :: c_ish_send ! model index: ice, southern
+ integer :: c_ish_recv ! model index: ice, southern
+ integer :: c_lnd_send ! model index: lnd
+ integer :: c_lnd_recv ! model index: lnd
+ integer :: c_ocn_send ! model index: ocn
+ integer :: c_ocn_recv ! model index: ocn
+ integer :: c_rof_send ! model index: rof
+ integer :: c_rof_recv ! model index: rof
+ integer :: c_glc_send ! model index: glc
+ integer :: c_glc_recv ! model index: glc
+
+ ! The folowing is needed for detailing the atm budgets and breakdown into components
+ integer :: c_inh_asend ! model index: ice, northern, on atm grid
+ integer :: c_inh_arecv ! model index: ice, northern, on atm grid
+ integer :: c_ish_asend ! model index: ice, southern, on atm grid
+ integer :: c_ish_arecv ! model index: ice, southern, on atm grid
+ integer :: c_lnd_asend ! model index: lnd, on atm grid
+ integer :: c_lnd_arecv ! model index: lnd, on atm grid
+ integer :: c_ocn_asend ! model index: ocn, on atm grid
+ integer :: c_ocn_arecv ! model index: ocn, on atm grid
+
+ ! ---------------------------------
+ ! 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
+
+ ! ---------------------------------
+ ! water isotopes names and indices
+ ! ---------------------------------
+
+ logical :: flds_wiso = .false.! If water isotope fields are active -
+ ! TODO: for now set to .false. - but this needs to be set in an initialization phase
+
+ integer, parameter :: nisotopes = 3
+ integer :: iso0(nisotopes)
+ integer :: isof(nisotopes)
+ character(len=5) :: isoname(nisotopes)
+
+ ! ---------------------------------
+ ! P for period
+ ! ---------------------------------
+
+ integer :: period_inst
+ integer :: period_day
+ integer :: period_mon
+ integer :: period_ann
+ integer :: period_inf
+
+ ! ---------------------------------
+ ! local constants
+ ! ---------------------------------
+
+ real(r8), parameter :: HFLXtoWFLX = & ! water flux implied by latent heat of fusion
+ & - (shr_const_ocn_ref_sal-shr_const_ice_ref_sal) / &
+ & (shr_const_ocn_ref_sal*shr_const_latice)
+ real(r8), parameter :: SFLXtoWFLX = & ! water flux implied by salt flux (kg/m^2s)
+ -1._r8/(shr_const_ocn_ref_sal*1.e-3_r8)
+
+ ! ---------------------------------
+ ! public data members
+ ! ---------------------------------
+
+ ! note: call med_diag_sum_master then save budget_global and budget_counter on restart from/to root pe ---
+
+ real(r8), allocatable :: budget_local (:,:,:) ! local sum, valid on all pes
+ real(r8), allocatable :: budget_global (:,:,:) ! global sum, valid only on root pe
+ real(r8), allocatable :: budget_counter(:,:,:) ! counter, valid only on root pe
+ real(r8), allocatable :: budget_global_1d(:) ! needed for ESMF_VMReduce call
+
+ character(len=*), parameter :: modName = "(med_diag) "
+ character(len=*), parameter :: u_FILE_u = &
+ __FILE__
+
+!===============================================================================
+contains
+!===============================================================================
+
+ subroutine med_diag_init(gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Initialize module variables and allocate dynamic memory
+ ! ------------------------------------------------------------------
+
+ ! input/output variables
+ type(ESMF_GridComp) , intent(inout) :: gcomp
+ integer , intent(out) :: rc
+
+ ! local variables
+
+ integer :: c_size ! number of component send/recvs
+ 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
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ 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
+ call add_to_budget_diag(budget_diags%comps, c_inh_recv , 'i2c_inh' ) ! comp index: ice, northern
+ call add_to_budget_diag(budget_diags%comps, c_ish_send , 'c2i_ish' ) ! comp index: ice, southern
+ call add_to_budget_diag(budget_diags%comps, c_ish_recv , 'i2c_ish' ) ! comp index: ice, southern
+ call add_to_budget_diag(budget_diags%comps, c_lnd_send , 'c2l_lnd' ) ! comp index: lnd
+ call add_to_budget_diag(budget_diags%comps, c_lnd_recv , 'l2c_lnd' ) ! comp index: lnd
+ call add_to_budget_diag(budget_diags%comps, c_ocn_send , 'c2o_ocn' ) ! comp index: ocn
+ call add_to_budget_diag(budget_diags%comps, c_ocn_recv , 'o2c_ocn' ) ! comp index: ocn
+ call add_to_budget_diag(budget_diags%comps, c_rof_send , 'c2r_rof' ) ! comp index: rof
+ call add_to_budget_diag(budget_diags%comps, c_rof_recv , 'r2c_rof' ) ! comp index: rof
+ call add_to_budget_diag(budget_diags%comps, c_glc_send , 'c2g_glc' ) ! comp index: glc
+ call add_to_budget_diag(budget_diags%comps, c_glc_recv , 'g2c_glc' ) ! comp index: glc
+ call add_to_budget_diag(budget_diags%comps, c_inh_asend, 'c2a_inh' ) ! comp index: ice, northern, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_inh_arecv, 'a2c_inh' ) ! comp index: ice, northern, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_ish_asend, 'c2a_ish' ) ! comp index: ice, southern, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_ish_arecv, 'a2c_ish' ) ! comp index: ice, southern, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_lnd_asend, 'c2a_lnd' ) ! comp index: lnd, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_lnd_arecv, 'a2c_lnd' ) ! comp index: lnd, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_ocn_asend, 'c2a_ocn' ) ! comp index: ocn, on atm grid
+ call add_to_budget_diag(budget_diags%comps, c_ocn_arecv, 'a2c_ocn' ) ! comp index: ocn, on atm grid
+
+ call add_to_budget_diag(budget_diags%fields, f_area ,'area' ) ! field area (wrt to unit sphere)
+ 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
+ call add_to_budget_diag(budget_diags%fields, f_heat_swnet ,'hnetsw' ) ! field heat : short wave, net
+ call add_to_budget_diag(budget_diags%fields, f_heat_lwdn ,'hlwdn' ) ! field heat : longwave down
+ call add_to_budget_diag(budget_diags%fields, f_heat_lwup ,'hlwup' ) ! field heat : longwave up
+ call add_to_budget_diag(budget_diags%fields, f_heat_latvap ,'hlatvap' ) ! field heat : latent, vaporization
+ 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
+ call add_to_budget_diag(budget_diags%fields, f_watr_frz ,'wfreeze' ) ! field water: freezing
+ 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
+ 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
+ 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
+
+ ! 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' /)
+
+ ! period types
+ call add_to_budget_diag(budget_diags%periods, period_inst,' inst')
+ call add_to_budget_diag(budget_diags%periods, period_day ,' daily')
+ call add_to_budget_diag(budget_diags%periods, period_mon ,' monthly')
+ 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
+ c_size = size(budget_diags%comps)
+ f_size = size(budget_diags%fields)
+ p_size = size(budget_diags%periods)
+
+ allocate(budget_local (f_size , c_size , p_size)) ! local sum, valid on all pes
+ allocate(budget_global (f_size , c_size , p_size)) ! global sum, valid only on root pe
+ allocate(budget_counter (f_size , c_size , p_size)) ! counter, valid only on root pe
+ allocate(budget_global_1d(f_size * c_size * p_size)) ! needed for ESMF_VMReduce call
+ !-------------------------------------------------------------------------------
+ ! Get config variables
+ !-------------------------------------------------------------------------------
+
+ budget_print_inst = get_diag_attribute(gcomp, 'budget_inst', rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ budget_print_daily = get_diag_attribute(gcomp, 'budget_daily', 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)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ 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)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (budget_print_inst + budget_print_daily + budget_print_month + budget_print_ann + budget_print_ltann + budget_print_ltend > 0) then
+ ! Set stop alarm (needed for budgets)
+ call NUOPC_CompAttributeGet(gcomp, name="stop_option", value=stop_option, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call NUOPC_CompAttributeGet(gcomp, name="stop_n", value=cvalue, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) stop_n
+ call NUOPC_CompAttributeGet(gcomp, name="stop_ymd", value=cvalue, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) stop_ymd
+ call NUOPC_MediatorGet(gcomp, mediatorClock=mediatorClock, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call alarmInit(mediatorclock, stop_alarm, stop_option, opt_n=stop_n, opt_ymd=stop_ymd, &
+ alarmname='alarm_stop', rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ contains
+ integer function get_diag_attribute(gcomp, name, rc)
+ type(ESMF_GridComp) , intent(inout) :: gcomp
+ character(len=*), intent(in) :: name
+ integer, intent(out) :: rc
+
+ character(CS) :: cvalue
+ logical :: isPresent
+
+ rc = ESMF_SUCCESS
+ get_diag_attribute = 0
+ call NUOPC_CompAttributeGet(gcomp, name=name, isPresent=isPresent, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent) then
+ call NUOPC_CompAttributeGet(gcomp, name=name, value=cvalue, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ read(cvalue,*) get_diag_attribute
+ else
+ call NUOPC_CompAttributeAdd(gcomp, (/name/), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call NUOPC_CompAttributeSet(gcomp, name=name, value='0', rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ end function get_diag_attribute
+
+ end subroutine med_diag_init
+
+ !===============================================================================
+
+ subroutine med_diag_zero( gcomp, mode, rc)
+
+ ! ------------------------------------------------------------------
+ ! Zero out global budget diagnostic data.
+ ! ------------------------------------------------------------------
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ character(len=*), intent(in),optional :: mode
+ integer, intent(out) :: rc
+
+ ! local variables
+ type(ESMF_Clock) :: clock
+ type(ESMF_Time) :: currTime
+ integer :: ip
+ integer :: curr_year, curr_mon, curr_day, curr_tod
+ character(*), parameter :: subName = '(med_diag_zero) '
+ ! ------------------------------------------------------------------
+
+ if (present(mode)) then
+
+ if (trim(mode) == 'inst') then
+ budget_local(:,:,period_inst) = 0.0_r8
+ budget_global(:,:,period_inst) = 0.0_r8
+ budget_counter(:,:,period_inst) = 0.0_r8
+ elseif (trim(mode) == 'day') then
+ budget_local(:,:,period_day) = 0.0_r8
+ budget_global(:,:,period_day) = 0.0_r8
+ budget_counter(:,:,period_day) = 0.0_r8
+ elseif (trim(mode) == 'mon') then
+ budget_local(:,:,period_mon) = 0.0_r8
+ budget_global(:,:,period_mon) = 0.0_r8
+ budget_counter(:,:,period_mon) = 0.0_r8
+ elseif (trim(mode) == 'ann') then
+ budget_local(:,:,period_ann) = 0.0_r8
+ budget_global(:,:,period_ann) = 0.0_r8
+ budget_counter(:,:,period_ann) = 0.0_r8
+ elseif (trim(mode) == 'inf') then
+ budget_local(:,:,period_inf) = 0.0_r8
+ budget_global(:,:,period_inf) = 0.0_r8
+ budget_counter(:,:,period_inf) = 0.0_r8
+ elseif (trim(mode) == 'all') then
+ budget_local(:,:,:) = 0.0_r8
+ budget_global(:,:,:) = 0.0_r8
+ budget_counter(:,:,:) = 0.0_r8
+ else
+ call ESMF_LogWrite(trim(subname)//' mode '//trim(mode)//&
+ ' not recognized', &
+ ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
+ rc = ESMF_FAILURE
+ return
+ endif
+
+ else
+ call ESMF_GridCompGet(gcomp, clock=clock, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_ClockGet( clock, currTime=currTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_TimeGet( currTime, yy=curr_year, mm=curr_mon, dd=curr_day, s=curr_tod, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ do ip = 1,size(budget_diags%periods)
+ if (ip == period_inst) then
+ budget_local(:,:,ip) = 0.0_r8
+ budget_global(:,:,ip) = 0.0_r8
+ budget_counter(:,:,ip) = 0.0_r8
+ endif
+ if (ip==period_day .and. curr_tod==0) then
+ budget_local(:,:,ip) = 0.0_r8
+ budget_global(:,:,ip) = 0.0_r8
+ budget_counter(:,:,ip) = 0.0_r8
+ endif
+ if (ip==period_mon .and. curr_day==1 .and. curr_tod==0) then
+ budget_local(:,:,ip) = 0.0_r8
+ budget_global(:,:,ip) = 0.0_r8
+ budget_counter(:,:,ip) = 0.0_r8
+ endif
+ if (ip==period_ann .and. curr_mon==1 .and. curr_day==1 .and. curr_tod==0) then
+ budget_local(:,:,ip) = 0.0_r8
+ budget_global(:,:,ip) = 0.0_r8
+ budget_counter(:,:,ip) = 0.0_r8
+ endif
+ enddo
+ end if
+ end subroutine med_diag_zero
+
+ !===============================================================================
+
+ subroutine med_phases_diag_accum(gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Accumulate out global budget diagnostic data.
+ ! ------------------------------------------------------------------
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out) :: rc
+
+ ! local variables
+ integer :: ip, ic
+ character(*), parameter :: subName = '(med_diag_accum) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+ do ip = period_inst+1,size(budget_diags%periods)
+ budget_local(:,:,ip) = budget_local(:,:,ip) + budget_local(:,:,period_inst)
+ enddo
+ budget_counter(:,:,:) = budget_counter(:,:,:) + 1.0_r8
+ end subroutine med_phases_diag_accum
+
+ !===============================================================================
+
+ subroutine med_diag_sum_master(gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Sum local values to global on root
+ ! ------------------------------------------------------------------
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out) :: rc
+
+ ! local variables
+ type(ESMF_VM) :: vm
+ integer :: count
+ integer :: c_size ! number of component send/recvs
+ integer :: f_size ! number of fields
+ integer :: p_size ! number of period types
+ character(*), parameter :: subName = '(med_diag_sum_master) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ f_size = size(budget_diags%fields)
+ c_size = size(budget_diags%comps)
+ p_size = size(budget_diags%periods)
+
+ count = size(budget_global)
+ budget_global_1d(:) = 0.0_r8
+
+
+ call ESMF_VMReduce(vm, reshape(budget_local,(/count/)) , budget_global_1d, count, ESMF_REDUCE_SUM, 0, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ budget_global = reshape(budget_global_1d,(/f_size,c_size,p_size/))
+ budget_local(:,:,:) = 0.0_r8
+
+ end subroutine med_diag_sum_master
+
+ !===============================================================================
+
+ subroutine med_phases_diag_atm(gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global atm input/output flux diagnostics
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : compatm
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ integer :: n,nf,ic,ip
+ real(r8), pointer :: afrac(:) => null()
+ real(r8), pointer :: lfrac(:) => null()
+ real(r8), pointer :: ifrac(:) => null()
+ real(r8), pointer :: ofrac(:) => null()
+ real(r8), pointer :: areas(:) => null()
+ real(r8), pointer :: lats(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_atm) '
+ !-------------------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! Get fractions on atm mesh
+ call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'lfrac', fldptr1=lfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ifrac', fldptr1=ifrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ofrac', fldptr1=ofrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ areas => is_local%wrap%mesh_info(compatm)%areas
+ lats => is_local%wrap%mesh_info(compatm)%lats
+ allocate(afrac(size(areas)))
+ afrac = 1.0_R8
+ !-------------------------------
+ ! from atm to mediator
+ !-------------------------------
+
+ ip = period_inst
+ do n = 1,size(afrac)
+ nf = f_area
+ budget_local(nf,c_atm_recv ,ip) = budget_local(nf,c_atm_recv ,ip) - areas(n)*afrac(n)
+ budget_local(nf,c_lnd_arecv,ip) = budget_local(nf,c_lnd_arecv,ip) + areas(n)*lfrac(n)
+ budget_local(nf,c_ocn_arecv,ip) = budget_local(nf,c_ocn_arecv,ip) + areas(n)*ofrac(n)
+ if (is_local%wrap%mesh_info(compatm)%lats(n) > 0.0_r8) then
+ budget_local(nf,c_inh_arecv,ip) = budget_local(nf,c_inh_arecv,ip) + areas(n)*ifrac(n)
+ else
+ budget_local(nf,c_ish_arecv,ip) = budget_local(nf,c_ish_arecv,ip) + areas(n)*ifrac(n)
+ end if
+ end do
+
+ call diag_atm(is_local%wrap%FBImp(compatm,compatm), 'Faxa_swnet', f_heat_swnet, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBImp(compatm,compatm), 'Faxa_lwdn', f_heat_lwdn, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainc', f_watr_rain, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBImp(compatm,compatm), 'Faxa_rainl', f_watr_rain, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowc', f_watr_snow, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBImp(compatm,compatm), 'Faxa_snowl', f_watr_snow, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call diag_atm_wiso(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
+ call diag_atm_wiso(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
+ ! heat implied by snow flux
+ budget_local(f_heat_latf,c_atm_recv ,ip) = -budget_local(f_watr_snow,c_atm_recv ,ip)*shr_const_latice
+ budget_local(f_heat_latf,c_lnd_arecv,ip) = -budget_local(f_watr_snow,c_lnd_arecv,ip)*shr_const_latice
+ budget_local(f_heat_latf,c_ocn_arecv,ip) = -budget_local(f_watr_snow,c_ocn_arecv,ip)*shr_const_latice
+ budget_local(f_heat_latf,c_inh_arecv,ip) = -budget_local(f_watr_snow,c_inh_arecv,ip)*shr_const_latice
+ budget_local(f_heat_latf,c_ish_arecv,ip) = -budget_local(f_watr_snow,c_ish_arecv,ip)*shr_const_latice
+
+ !-------------------------------
+ ! from mediator to atm
+ !-------------------------------
+
+ ip = period_inst
+
+ do n = 1,size(afrac)
+ budget_local(f_area,c_atm_send ,ip) = budget_local(f_area,c_atm_send ,ip) - areas(n)*afrac(n)
+ budget_local(f_area,c_lnd_asend,ip) = budget_local(f_area,c_lnd_asend,ip) + areas(n)*lfrac(n)
+ budget_local(f_area,c_ocn_asend,ip) = budget_local(f_area,c_ocn_asend,ip) + areas(n)*ofrac(n)
+ if (is_local%wrap%mesh_info(compatm)%lats(n) > 0.0_r8) then
+ budget_local(f_area,c_inh_asend,ip) = budget_local(f_area,c_inh_asend,ip) + areas(n)*ifrac(n)
+ else
+ budget_local(f_area,c_ish_asend,ip) = budget_local(f_area,c_ish_asend,ip) + areas(n)*ifrac(n)
+ end if
+ end do
+
+ call diag_atm(is_local%wrap%FBExp(compatm), 'Faxx_lwup', f_heat_lwup, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBExp(compatm), 'Faxx_lat', f_heat_latvap, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBExp(compatm), 'Faxx_sen', f_heat_sen, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call diag_atm(is_local%wrap%FBExp(compatm), 'Faxx_evap', f_watr_evap, &
+ areas, lats, afrac, lfrac, ofrac, ifrac, budget_local, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! water isotopes
+ call diag_atm_wiso(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)
+
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_atm(FB, fldname, nf, areas, lats, afrac, lfrac, ofrac, ifrac, budget, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lats(:)
+ real(r8) , intent(in) :: afrac(:)
+ real(r8) , intent(in) :: lfrac(:)
+ real(r8) , intent(in) :: ofrac(:)
+ real(r8) , intent(in) :: ifrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data , rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1,size(data)
+ budget(nf,c_atm_send,ip) = budget(nf,c_atm_send,ip) - areas(n)*afrac(n)*data(n)
+ budget(nf,c_lnd_asend,ip) = budget(nf,c_lnd_asend,ip) + areas(n)*lfrac(n)*data(n)
+ budget(nf,c_ocn_asend,ip) = budget(nf,c_ocn_asend,ip) + areas(n)*ofrac(n)*data(n)
+ if (lats(n) > 0.0_r8) then
+ budget(nf,c_inh_asend,ip) = budget(nf,c_inh_asend,ip) + areas(n)*ifrac(n)*data(n)
+ else
+ budget(nf,c_ish_asend,ip) = budget(nf,c_ish_asend,ip) + areas(n)*ifrac(n)*data(n)
+ end if
+ end do
+ end if
+ end subroutine diag_atm
+
+ subroutine diag_atm_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, &
+ afrac, lfrac, ofrac, ifrac, budget, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf_16O
+ integer , intent(in) :: nf_18O
+ integer , intent(in) :: nf_HDO
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lats(:)
+ real(r8) , intent(in) :: afrac(:)
+ real(r8) , intent(in) :: lfrac(:)
+ real(r8) , intent(in) :: ofrac(:)
+ real(r8) , intent(in) :: ifrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:,:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr2=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1,size(data, dim=2)
+ budget(nf_16O,c_atm_recv,ip) = budget(nf_16O,c_atm_recv,ip) - areas(n)*afrac(n)*data(1,n)
+ budget(nf_16O,c_lnd_arecv,ip) = budget(nf_16O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(1,n)
+ budget(nf_16O,c_ocn_arecv,ip) = budget(nf_16O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(1,n)
+ if (lats(n) > 0.0_r8) then
+ budget(nf_16O,c_inh_arecv,ip) = budget(nf_16O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(1,n)
+ else
+ budget(nf_16O,c_ish_arecv,ip) = budget(nf_16O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(1,n)
+ end if
+
+ budget(nf_18O,c_atm_recv,ip) = budget(nf_18O,c_atm_recv,ip) - areas(n)*afrac(n)*data(2,n)
+ budget(nf_18O,c_lnd_arecv,ip) = budget(nf_18O,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(2,n)
+ budget(nf_18O,c_ocn_arecv,ip) = budget(nf_18O,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(2,n)
+ if (lats(n) > 0.0_r8) then
+ budget(nf_18O,c_inh_arecv,ip) = budget(nf_18O,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(2,n)
+ else
+ budget(nf_18O,c_ish_arecv,ip) = budget(nf_18O,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(2,n)
+ end if
+
+ budget(nf_HDO,c_atm_recv,ip) = budget(nf_HDO,c_atm_recv,ip) - areas(n)*afrac(n)*data(3,n)
+ budget(nf_HDO,c_lnd_arecv,ip) = budget(nf_HDO,c_lnd_arecv,ip) + areas(n)*lfrac(n)*data(3,n)
+ budget(nf_HDO,c_ocn_arecv,ip) = budget(nf_HDO,c_ocn_arecv,ip) + areas(n)*ofrac(n)*data(3,n)
+ if (lats(n) > 0.0_r8) then
+ budget(nf_HDO,c_inh_arecv,ip) = budget(nf_HDO,c_inh_arecv,ip) + areas(n)*ifrac(n)*data(3,n)
+ else
+ budget(nf_HDO,c_ish_arecv,ip) = budget(nf_HDO,c_ish_arecv,ip) + areas(n)*ifrac(n)*data(3,n)
+ end if
+ end do
+ end if
+ end subroutine diag_atm_wiso
+
+ end subroutine med_phases_diag_atm
+
+ !===============================================================================
+
+ subroutine med_phases_diag_lnd( gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global lnd input/output flux diagnostics
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : complnd
+
+ ! intput/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ real(r8), pointer :: lfrac(:) => null()
+ integer :: n,ip, ic
+ real(r8), pointer :: areas(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_lnd) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! get fractions on lnd mesh
+ call FB_getFldPtr(is_local%wrap%FBfrac(complnd), 'lfrac', lfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ areas => is_local%wrap%mesh_info(complnd)%areas
+
+ !-------------------------------
+ ! from land to mediator
+ !-------------------------------
+
+ ic = c_lnd_recv
+ ip = period_inst
+ do n = 1, size(lfrac)
+ budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*lfrac(n)
+ end do
+
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_swnet', f_heat_swnet , ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_lwup' , f_heat_lwup , ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_lat' , f_heat_latvap , ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_sen' , f_heat_sen , ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Fall_evap' , f_watr_evap , ic, areas, lfrac, budget_local, rc=rc)
+
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsur', f_watr_roff, ic, &
+ areas, lfrac, budget_local, minus=.true., rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofgwl', f_watr_roff, ic,&
+ areas, lfrac, budget_local, minus=.true., rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofsub', f_watr_roff, ic,&
+ areas, lfrac, budget_local, minus=.true., rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofdto', f_watr_roff, ic,&
+ areas, lfrac, budget_local, minus=.true., rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_irrig' , f_watr_roff, ic,&
+ areas, lfrac, budget_local, minus=.true., rc=rc)
+ call diag_lnd(is_local%wrap%FBImp(complnd,complnd), 'Flrl_rofi' , f_watr_ioff, ic,&
+ areas, lfrac, budget_local, minus=.true., rc=rc)
+
+ 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)
+
+ !-------------------------------
+ ! to land from mediator
+ !-------------------------------
+
+ ic = c_lnd_send
+ ip = period_inst
+
+ do n = 1,size(lfrac)
+ 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)
+ call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_rainc', f_watr_rain, ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_rainl', f_watr_rain, ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_snowc', f_watr_snow, ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBExp(complnd), 'Faxa_snowl', f_watr_snow, ic, areas, lfrac, budget_local, rc=rc)
+ call diag_lnd(is_local%wrap%FBExp(complnd), 'Flrl_flood', f_watr_roff, ic, areas, lfrac, budget_local, minus=.true., rc=rc)
+
+ 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)
+
+ budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice
+ budget_local(f_heat_latf,ic,ip) = -budget_local(f_watr_snow,ic,ip)*shr_const_latice
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_lnd(FB, fldname, nf, ic, areas, lfrac, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lfrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data)
+ if (present(minus)) then
+ budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*lfrac(n)*data(n)
+ else
+ budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*lfrac(n)*data(n)
+ end if
+ end do
+ end if
+ end subroutine diag_lnd
+
+ subroutine diag_lnd_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, lfrac, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf_16O
+ integer , intent(in) :: nf_18O
+ integer , intent(in) :: nf_HDO
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lfrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:,:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr2=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data, dim=2)
+ if (present(minus)) then
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*lfrac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*lfrac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*lfrac(n)*data(3,n)
+ else
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*lfrac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*lfrac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*lfrac(n)*data(3,n)
+ end if
+ end do
+ end if
+ end subroutine diag_lnd_wiso
+
+ end subroutine med_phases_diag_lnd
+
+ !===============================================================================
+
+ subroutine med_phases_diag_rof( gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global river input/output
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : comprof
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ integer :: ic, ip, n
+ real(r8), pointer :: areas(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_rof) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ areas => is_local%wrap%mesh_info(comprof)%areas
+
+ !-------------------------------
+ ! from river to mediator
+ !-------------------------------
+
+ ic = c_rof_send
+ ip = period_inst
+
+ call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Flrr_flood', f_watr_roff, ic, areas, budget_local, rc=rc)
+ call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofl' , f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc)
+ call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Forr_rofi' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc)
+ call diag_rof(is_local%wrap%FBImp(comprof,comprof), 'Firr_rofi' , f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc)
+
+ 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)
+
+ budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice
+
+ !-------------------------------
+ ! to river from mediator
+ !-------------------------------
+
+ ic = c_rof_recv
+ ip = period_inst
+
+ call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsur', f_watr_roff, ic, areas, budget_local, rc=rc)
+ call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofgwl', f_watr_roff, ic, areas, budget_local, rc=rc)
+ call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofsub', f_watr_roff, ic, areas, budget_local, rc=rc)
+ call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofdto', f_watr_roff, ic, areas, budget_local, rc=rc)
+ call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_irrig' , f_watr_roff, ic, areas, budget_local, rc=rc)
+ call diag_rof(is_local%wrap%FBExp(comprof), 'Flrl_rofi' , f_watr_ioff, ic, areas, budget_local, rc=rc)
+
+ 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', &
+ f_watr_ioff_16O, f_watr_ioff_18O, f_watr_ioff_HDO, ic, areas, budget_local, rc=rc)
+
+ budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_rof(FB, fldname, nf, ic, areas, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data)
+ if (present(minus)) then
+ budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*data(n)
+ else
+ budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*data(n)
+ end if
+ end do
+ end if
+ end subroutine diag_rof
+
+ subroutine diag_rof_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf_16O
+ integer , intent(in) :: nf_18O
+ integer , intent(in) :: nf_HDO
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:,:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr2=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data, dim=2)
+ if (present(minus)) then
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*data(3,n)
+ else
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*data(3,n)
+ end if
+ end do
+ end if
+ end subroutine diag_rof_wiso
+
+ end subroutine med_phases_diag_rof
+
+ !===============================================================================
+
+ subroutine med_phases_diag_glc( gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global glc output
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : compglc
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ integer :: ic, ip
+ real(r8), pointer :: areas(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_glc) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ areas => is_local%wrap%mesh_info(compglc)%areas
+
+ !-------------------------------
+ ! from glc to mediator
+ !-------------------------------
+
+ ic = c_glc_send
+ ip = period_inst
+
+ call diag_glc(is_local%wrap%FBImp(compglc,compglc), 'Fogg_rofl', f_watr_roff, ic, areas, budget_local, minus=.true., rc=rc)
+ call diag_glc(is_local%wrap%FBImp(compglc,compglc), 'Fogg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc)
+ call diag_glc(is_local%wrap%FBImp(compglc,compglc), 'Figg_rofi', f_watr_ioff, ic, areas, budget_local, minus=.true., rc=rc)
+
+ budget_local(f_heat_ioff,ic,ip) = -budget_local(f_watr_ioff,ic,ip)*shr_const_latice
+
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_glc(FB, fldname, nf, ic, areas, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data)
+ if (present(minus)) then
+ budget(nf,ic,ip) = budget(nf,ic,ip) - areas(n)*data(n)
+ else
+ budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*data(n)
+ end if
+ end do
+ end if
+ end subroutine diag_glc
+
+ end subroutine med_phases_diag_glc
+
+ !===============================================================================
+
+ subroutine med_phases_diag_ocn( gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global ocn input from mediator
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : compocn
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ integer :: n,ic,ip
+ real(r8) :: wgt_i,wgt_o
+ real(r8), pointer :: ifrac(:) => null() ! ice fraction in ocean grid cell
+ real(r8), pointer :: ofrac(:) => null() ! non-ice fraction nin ocean grid cell
+ real(r8), pointer :: sfrac(:) => null() ! sum of ifrac and ofrac
+ real(r8), pointer :: areas(:) => null()
+ real(r8), pointer :: data(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_ocn) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call FB_getFldPtr(is_local%wrap%FBfrac(compocn), 'ifrac', fldptr1=ifrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call FB_getFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac', fldptr1=ofrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(sfrac(size(ofrac)))
+ sfrac(:) = ifrac(:) + ofrac(:)
+
+ areas => is_local%wrap%mesh_info(compocn)%areas
+
+ !-------------------------------
+ ! from ocn to mediator
+ !-------------------------------
+
+ ip = period_inst
+ ic = c_ocn_recv
+ do n = 1,size(ofrac)
+ budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*ofrac(n)
+ end do
+
+ if ( FB_fldchk(is_local%wrap%FBImp(compocn,compocn), 'Fioo_q', rc=rc)) then
+ call FB_getFldPtr(is_local%wrap%FBImp(compocn,compocn), 'Fioo_q', fldptr1=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,size(ifrac)
+ wgt_o = areas(n) * ofrac(n)
+ wgt_i = areas(n) * ifrac(n)
+ budget_local(f_heat_frz,ic,ip) = budget_local(f_heat_frz,ic,ip) + (wgt_o + wgt_i)*max(0.0_r8,data(n))
+ 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
+
+ !-------------------------------
+ ! from mediator to ocn
+ !-------------------------------
+
+ ic = c_ocn_send
+ ip = period_inst
+
+ do n = 1,size(ofrac)
+ budget_local(f_area,ic,ip) = budget_local(f_area,ic,ip) + areas(n)*ofrac(n)
+ end do
+
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lwup' , f_heat_lwup , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_lat' , f_heat_latvap , ic, areas, sfrac, budget_local, rc=rc)
+ 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)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_bergw', f_watr_melt , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_melth', f_heat_melt , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_bergh', f_heat_melt , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Fioi_salt' , f_watr_salt , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_swnet', f_heat_swnet , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_lwdn' , f_heat_lwdn , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_rain' , f_watr_rain , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Faxa_snow' , f_watr_snow , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_rofl' , f_watr_roff , ic, areas, sfrac, budget_local, rc=rc)
+ call diag_ocn(is_local%wrap%FBExp(compocn), 'Foxx_rofi' , f_watr_ioff , ic, areas, sfrac, budget_local, rc=rc)
+
+ 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)
+
+ 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
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_ocn(FB, fldname, nf, ic, areas, frac, budget, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: frac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data)
+ budget(nf,ic,ip) = budget(nf,ic,ip) + areas(n)*frac(n)*data(n)
+ end do
+ end if
+ end subroutine diag_ocn
+
+ subroutine diag_ocn_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, ic, areas, frac, budget, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf_16O
+ integer , intent(in) :: nf_18O
+ integer , intent(in) :: nf_HDO
+ integer , intent(in) :: ic
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: frac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ integer , intent(out) :: rc
+
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:,:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr2=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data, dim=2)
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*frac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*frac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*frac(n)*data(3,n)
+ end do
+ end if
+ end subroutine diag_ocn_wiso
+
+ end subroutine med_phases_diag_ocn
+
+ !===============================================================================
+
+ subroutine med_phases_diag_ice_ice2med( gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global ice input/output flux diagnostics
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : compice
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ integer :: n,ic,ip
+ real(r8), pointer :: ofrac(:) => null()
+ real(r8), pointer :: ifrac(:) => null()
+ real(r8), pointer :: areas(:) => null()
+ real(r8), pointer :: lats(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_ice_ice2med) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ifrac', fldptr1=ifrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ofrac', fldptr1=ofrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ areas => is_local%wrap%mesh_info(compice)%areas
+ lats => is_local%wrap%mesh_info(compice)%lats
+
+ ip = period_inst
+
+ do n = 1,size(ifrac)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_recv
+ else
+ ic = c_ish_recv
+ endif
+ budget_local(f_area ,ic,ip) = budget_local(f_area ,ic,ip) + areas(n)*ifrac(n)
+ end do
+
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Fioi_melth', f_heat_melt, &
+ areas, lats, ifrac, budget_local, minus=.true., rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Fioi_meltw', f_watr_melt, &
+ areas, lats, ifrac, budget_local, minus=.true., rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Fioi_salt', f_watr_salt, &
+ areas, lats, ifrac, budget_local, minus=.true., scale=SFLXtoWFLX, rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Fioi_swpen', f_heat_swnet, &
+ areas, lats, ifrac, budget_local, minus=.true., rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Faii_swnet', f_heat_swnet, &
+ areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Faii_lwup', f_heat_lwup, &
+ areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Faii_lat', f_heat_latvap, &
+ areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Faii_sen', f_heat_sen, &
+ areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBImp(compice,compice), 'Faii_evap', f_watr_evap, &
+ areas, lats, ifrac, budget_local, rc=rc)
+
+ call diag_ice_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_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)
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_ice(FB, fldname, nf, areas, lats, ifrac, budget, minus, scale, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lats(:)
+ real(r8) , intent(in) :: ifrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ real(r8), optional , intent(in) :: scale
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data , rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1,size(data)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_recv
+ else
+ ic = c_ish_recv
+ endif
+ if (present(minus)) then
+ if (present(scale)) then
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n)*scale
+ else
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n)
+ end if
+ else
+ if (present(scale)) then
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n)*scale
+ else
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n)
+ end if
+ end if
+ end do
+ end if
+ end subroutine diag_ice
+
+ subroutine diag_ice_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf_16O
+ integer , intent(in) :: nf_18O
+ integer , intent(in) :: nf_HDO
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lats(:)
+ real(r8) , intent(in) :: ifrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:,:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr2=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data, dim=2)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_recv
+ else
+ ic = c_ish_recv
+ endif
+ if (present(minus)) then
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*ifrac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*ifrac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*ifrac(n)*data(3,n)
+ else
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n)
+ end if
+ end do
+ end if
+ end subroutine diag_ice_wiso
+
+
+ end subroutine med_phases_diag_ice_ice2med
+
+ !===============================================================================
+
+ subroutine med_phases_diag_ice_med2ice( gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Compute global ice input/output flux diagnostics
+ ! ------------------------------------------------------------------
+
+ use esmFlds, only : compice
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(InternalState) :: is_local
+ integer :: n,ic,ip
+ real(r8) :: wgt_i, wgt_o
+ real(r8), pointer :: ofrac(:) => null()
+ real(r8), pointer :: ifrac(:) => null()
+ real(r8), pointer :: data(:) => null()
+ real(r8), pointer :: areas(:) => null()
+ real(r8), pointer :: lats(:) => null()
+ character(*), parameter :: subName = '(med_phases_diag_ice_med2ice) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ nullify(is_local%wrap)
+ call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ifrac', fldptr1=ifrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ofrac', fldptr1=ofrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ areas => is_local%wrap%mesh_info(compice)%areas
+ lats => is_local%wrap%mesh_info(compice)%lats
+
+ ip = period_inst
+
+ do n = 1,size(ifrac)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_send
+ else
+ ic = c_ish_send
+ endif
+ budget_local(f_area ,ic,ip) = budget_local(f_area ,ic,ip) + areas(n)*ifrac(n)
+ end do
+
+ call diag_ice(is_local%wrap%FBExp(compice), 'Faxa_lwdn', f_heat_lwdn, areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBExp(compice), 'Faxa_rain', f_watr_rain, areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBExp(compice), 'Faxa_snow', f_watr_snow, areas, lats, ifrac, budget_local, rc=rc)
+ call diag_ice(is_local%wrap%FBExp(compice), 'Fixx_rofi', f_watr_ioff, areas, lats, ifrac, budget_local, rc=rc)
+
+ call diag_ice_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_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 ( FB_fldchk(is_local%wrap%FBExp(compice), 'Fioo_q', rc=rc)) then
+ call FB_getFldPtr(is_local%wrap%FBExp(compice), 'Fioo_q', fldptr1=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,size(data)
+ wgt_o = areas(n) * ofrac(n)
+ wgt_i = areas(n) * ifrac(n)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_send
+ else
+ ic = c_ish_send
+ endif
+ budget_local(f_heat_frz,ic,ip) = budget_local(f_heat_frz,ic,ip) - (wgt_o + wgt_i)*max(0.0_r8,data(n))
+ end do
+ end if
+
+ ic = c_inh_send
+ 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
+ budget_local(f_watr_frz ,ic,ip) = budget_local(f_heat_frz ,ic,ip)*HFLXtoWFLX
+
+ ic = c_ish_send
+ 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
+ budget_local(f_watr_frz ,ic,ip) = budget_local(f_heat_frz ,ic,ip)*HFLXtoWFLX
+
+ !-----------
+ contains
+ !-----------
+
+ subroutine diag_ice(FB, fldname, nf, areas, lats, ifrac, budget, minus, scale, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lats(:)
+ real(r8) , intent(in) :: ifrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ real(r8), optional , intent(in) :: scale
+ integer , intent(out) :: rc
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr1=data , rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1,size(data)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_recv
+ else
+ ic = c_ish_recv
+ endif
+ if (present(minus)) then
+ if (present(scale)) then
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n)*scale
+ else
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) - areas(n)*ifrac(n)*data(n)
+ end if
+ else
+ if (present(scale)) then
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n)*scale
+ else
+ budget(nf ,ic,ip) = budget(nf ,ic,ip) + areas(n)*ifrac(n)*data(n)
+ end if
+ end if
+ end do
+ end if
+ end subroutine diag_ice
+
+ subroutine diag_ice_wiso(FB, fldname, nf_16O, nf_18O, nf_HDO, areas, lats, ifrac, budget, minus, rc)
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FB
+ character(len=*) , intent(in) :: fldname
+ integer , intent(in) :: nf_16O
+ integer , intent(in) :: nf_18O
+ integer , intent(in) :: nf_HDO
+ real(r8) , intent(in) :: areas(:)
+ real(r8) , intent(in) :: lats(:)
+ real(r8) , intent(in) :: ifrac(:)
+ real(r8) , intent(inout) :: budget(:,:,:)
+ logical, optional , intent(in) :: minus
+ integer , intent(out) :: rc
+
+ ! local variables
+ integer :: n, ip
+ real(r8), pointer :: data(:,:) => null()
+ ! ------------------------------------------------------------------
+ rc = ESMF_SUCCESS
+
+ if ( FB_fldchk(FB, trim(fldname), rc=rc)) then
+ call FB_GetFldPtr(FB, trim(fldname), fldptr2=data, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ip = period_inst
+ do n = 1, size(data, dim=2)
+ if (lats(n) > 0.0_r8) then
+ ic = c_inh_recv
+ else
+ ic = c_ish_recv
+ endif
+ if (present(minus)) then
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) - areas(n)*ifrac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) - areas(n)*ifrac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) - areas(n)*ifrac(n)*data(3,n)
+ else
+ budget(nf_16O,ic,ip) = budget(nf_16O,ic,ip) + areas(n)*ifrac(n)*data(1,n)
+ budget(nf_18O,ic,ip) = budget(nf_18O,ic,ip) + areas(n)*ifrac(n)*data(2,n)
+ budget(nf_HDO,ic,ip) = budget(nf_HDO,ic,ip) + areas(n)*ifrac(n)*data(3,n)
+ end if
+ end do
+ end if
+ end subroutine diag_ice_wiso
+
+ end subroutine med_phases_diag_ice_med2ice
+
+ !===============================================================================
+
+ subroutine med_phases_diag_print(gcomp, rc)
+
+ ! ------------------------------------------------------------------
+ ! Print global budget diagnostics.
+ ! ------------------------------------------------------------------
+
+ ! input/output variables
+ type(ESMF_GridComp) :: gcomp
+ integer, intent(out):: rc
+
+ ! local variables
+ type(ESMF_Clock) :: clock
+ type(ESMF_Alarm) :: stop_alarm
+ type(ESMF_Time) :: currTime
+ integer :: cdate ! coded date, seconds
+ integer :: curr_year
+ integer :: curr_mon
+ integer :: curr_day
+ integer :: curr_tod
+ integer :: output_level ! print level
+ logical :: sumdone ! has a sum been computed yet
+ character(CS) :: cvalue
+ integer :: ip
+ integer :: c_size ! number of component send/recvs
+ integer :: f_size ! number of fields
+ integer :: p_size ! number of period types
+ real(r8), allocatable :: datagpr(:,:,:)
+ character(len=20) :: name
+ logical, save :: firstcall = .true.
+ integer :: yr,mon,day,sec ! time units
+ character(len=64) :: currtimestr
+ character(*), parameter :: subName = '(med_phases_diag_print) '
+ ! ------------------------------------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ !-------------------------------------------------------------------------------
+ ! Print budget data if appropriate
+ !-------------------------------------------------------------------------------
+
+ ! Get clock and alarm info
+ call ESMF_GridCompGet(gcomp, clock=clock, name=name, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_ClockGet( clock, currTime=currTime, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_TimeGet( currTime, yy=curr_year, mm=curr_mon, dd=curr_day, s=curr_tod, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ cdate = curr_year*10000 + curr_mon*100 + curr_day
+#ifdef DEBUG
+ if(mastertask) then
+ write(currtimestr,'(i4.4,a,i2.2,a,i2.2,a,i5.5)') curr_year,'-',curr_mon,'-',curr_day,'-',curr_tod
+ write(logunit,' (a)') trim(subname)//": currtime = "//trim(currtimestr)
+ endif
+#endif
+ if(firstcall) then
+ firstcall = .false.
+ return
+ endif
+ sumdone = .false.
+ do ip = 1,size(budget_diags%periods)
+
+ ! Determine output level for this period type
+ output_level = 0
+ if (ip == period_inst) then
+ output_level = max(output_level, budget_print_inst)
+ end if
+ if (ip == period_day .and. curr_tod == 0) then
+ output_level = max(output_level, budget_print_daily)
+ end if
+ if (ip == period_mon .and. curr_day == 1 .and. curr_tod == 0) then
+ output_level = max(output_level, budget_print_month)
+ end if
+ if (ip == period_ann .and. curr_mon == 1 .and. curr_day == 1 .and. curr_tod == 0) then
+ output_level = max(output_level, budget_print_ann)
+ end if
+ if (ip == period_inf .and. curr_mon == 1 .and. curr_day == 1 .and. curr_tod == 0) then
+ output_level = max(output_level, budget_print_ltann)
+ end if
+ if (ip == period_inf) then
+ call ESMF_ClockGetAlarm(clock, alarmname='alarm_stop', alarm=stop_alarm, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then
+ output_level = max(output_level, budget_print_ltend)
+ call ESMF_AlarmRingerOff( stop_alarm, rc=rc )
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ endif
+ endif
+ if (output_level > 0) exit
+ enddo ! ip = 1, period_types
+
+ ! Currently output_level is limited to levels of 0,1,2, 3
+ ! (see comment for print options at top)
+
+ if (output_level > 0) then
+ if (.not. sumdone) then
+ ! Some budgets will be printed for this period type
+ ! Determine sums if not already done
+ call med_diag_sum_master(gcomp, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ sumdone = .true.
+ end if
+
+ if (mastertask) then
+ c_size = size(budget_diags%comps)
+ f_size = size(budget_diags%fields)
+ p_size = size(budget_diags%periods)
+ allocate(datagpr(f_size, c_size, p_size))
+ datagpr(:,:,:) = budget_global(:,:,:)
+
+ ! budget normalizations (global area and 1e6 for water)
+ datagpr = datagpr/(4.0_r8*shr_const_pi)
+ datagpr(f_watr_beg:f_watr_end,:,:) = datagpr(f_watr_beg:f_watr_end,:,:) * 1.0e6_r8
+ if ( flds_wiso ) then
+ datagpr(iso0(1):isof(nisotopes),:,:) = datagpr(iso0(1):isof(nisotopes),:,:) * 1.0e6_r8
+ end if
+ datagpr(:,:,:) = datagpr(:,:,:)/budget_counter(:,:,:)
+
+ ! Write diagnostic tables to logunit (mastertask only)
+ if (output_level >= 3) then
+ ! detail atm budgets and breakdown into components ---
+ call med_diag_print_atm(datagpr, ip, cdate, curr_tod)
+ end if
+ if (output_level >= 2) then
+ ! detail lnd/ocn/ice component budgets ----
+ call med_diag_print_lnd_ice_ocn(datagpr, ip, cdate, curr_tod)
+ end if
+ if (output_level >= 1) then
+ ! net summary budgets
+ call med_diag_print_summary(datagpr, ip, cdate, curr_tod)
+ endif
+ write(logunit,*) ' '
+
+ deallocate(datagpr)
+ endif ! output_level > 0 and mastertask
+ end if ! if mastertask
+ !-------------------------------------------------------------------------------
+ ! Zero budget data
+ !-------------------------------------------------------------------------------
+
+ call med_diag_zero(gcomp, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ end subroutine med_phases_diag_print
+
+ !===============================================================================
+
+ subroutine med_diag_print_atm(data, ip, cdate, curr_tod)
+
+ ! ---------------------------------------------------------
+ ! detail atm budgets and breakdown into components
+ ! ---------------------------------------------------------
+
+ ! intput/output variables
+ real(r8), intent(in) :: data(:,:,:) ! values to print, scaled and such
+ integer , intent(in) :: ip ! period index
+ integer , intent(in) :: cdate
+ integer , intent(in) :: curr_tod
+
+ ! local variables
+ integer :: ic,nf,is ! data array indicies
+ integer :: ica,icl
+ integer :: icn,ics,ico
+ character(len=40) :: str ! string
+ character(*), parameter:: subName = '(med_phases_diag_print_level3) '
+ ! ------------------------------------------------------------------
+
+ do ic = 1,2
+ if (ic == 1) then ! from atm to mediator
+ ica = c_atm_recv ! total from atm
+ icl = c_lnd_arecv ! from land to med on atm grid
+ icn = c_inh_arecv ! from ice-nh to med on atm grid
+ ics = c_ish_arecv ! from ice-sh to med on atm grid
+ ico = c_ocn_arecv ! from ocn to to med on atm grid
+ str = "ATM_to_CPL"
+ elseif (ic == 2) then ! from mediator to atm
+ ica = c_atm_send ! merged to atm
+ icl = c_lnd_asend ! from land to atm
+ icn = c_inh_asend ! from ice-nh to atm
+ ics = c_ish_asend ! from ice-sh to atm
+ ico = c_ocn_asend ! from ocn to atm
+ str = "CPL_TO_ATM"
+ endif
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//' AREA BUDGET (m2/m2): period = ', &
+ trim(budget_diags%periods(ip)%name), ': date = ', cdate, curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(ica)%name,&
+ budget_diags%comps(icl)%name,&
+ budget_diags%comps(icn)%name,&
+ budget_diags%comps(ics)%name,&
+ budget_diags%comps(ico)%name,' *SUM* '
+ write(logunit,FA1) budget_diags%fields(f_area)%name,&
+ data(f_area,ica,ip), &
+ data(f_area,icl,ip), &
+ data(f_area,icn,ip), &
+ data(f_area,ics,ip), &
+ data(f_area,ico,ip), &
+ data(f_area,ica,ip) + data(f_area,icl,ip) + &
+ data(f_area,icn,ip) + data(f_area,ics,ip) + data(f_area,ico,ip)
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',&
+ trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(ica)%name,&
+ budget_diags%comps(icl)%name,&
+ budget_diags%comps(icn)%name,&
+ budget_diags%comps(ics)%name,&
+ budget_diags%comps(ico)%name,' *SUM* '
+ do nf = f_heat_beg, f_heat_end
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ data(nf,ica,ip), &
+ data(nf,icl,ip), &
+ data(nf,icn,ip), &
+ data(nf,ics,ip), &
+ data(nf,ico,ip), &
+ data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip)
+ enddo
+ write(logunit,FA1) ' *SUM*' ,&
+ sum(data(f_heat_beg:f_heat_end,ica,ip)), &
+ sum(data(f_heat_beg:f_heat_end,icl,ip)), &
+ sum(data(f_heat_beg:f_heat_end,icn,ip)), &
+ sum(data(f_heat_beg:f_heat_end,ics,ip)), &
+ sum(data(f_heat_beg:f_heat_end,ico,ip)), &
+ sum(data(f_heat_beg:f_heat_end,ica,ip)) + sum(data(f_heat_beg:f_heat_end,icl,ip)) + &
+ sum(data(f_heat_beg:f_heat_end,icn,ip)) + sum(data(f_heat_beg:f_heat_end,ics,ip)) + &
+ sum(data(f_heat_beg:f_heat_end,ico,ip))
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',&
+ trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(ica)%name,&
+ budget_diags%comps(icl)%name,&
+ budget_diags%comps(icn)%name,&
+ budget_diags%comps(ics)%name,&
+ budget_diags%comps(ico)%name,' *SUM* '
+ do nf = f_watr_beg, f_watr_end
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ data(nf,ica,ip), &
+ data(nf,icl,ip), &
+ data(nf,icn,ip), &
+ data(nf,ics,ip), &
+ data(nf,ico,ip), &
+ data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip)
+ enddo
+ write(logunit,FA1) ' *SUM*' ,&
+ sum(data(f_watr_beg:f_watr_end,ica,ip)), &
+ sum(data(f_watr_beg:f_watr_end,icl,ip)), &
+ sum(data(f_watr_beg:f_watr_end,icn,ip)), &
+ sum(data(f_watr_beg:f_watr_end,ics,ip)), &
+ sum(data(f_watr_beg:f_watr_end,ico,ip)), &
+ sum(data(f_watr_beg:f_watr_end,ica,ip)) + sum(data(f_watr_beg:f_watr_end,icl,ip)) + &
+ sum(data(f_watr_beg:f_watr_end,icn,ip)) + sum(data(f_watr_beg:f_watr_end,ics,ip)) + &
+ sum(data(f_watr_beg:f_watr_end,ico,ip))
+
+ if ( flds_wiso ) then
+ do is = 1, nisotopes
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//' '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', &
+ trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(ica)%name,&
+ budget_diags%comps(icl)%name,&
+ budget_diags%comps(icn)%name,&
+ budget_diags%comps(ics)%name,&
+ budget_diags%comps(ico)%name,' *SUM* '
+ do nf = iso0(is), isof(is)
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ data(nf,ica,ip), &
+ data(nf,icl,ip), &
+ data(nf,icn,ip), &
+ data(nf,ics,ip), &
+ data(nf,ico,ip), &
+ data(nf,ica,ip) + data(nf,icl,ip) + data(nf,icn,ip) + data(nf,ics,ip) + data(nf,ico,ip)
+ enddo
+ write(logunit,FA1) ' *SUM*', &
+ sum(data(iso0(is):isof(is),ica,ip)), &
+ sum(data(iso0(is):isof(is),icl,ip)), &
+ sum(data(iso0(is):isof(is),icn,ip)), &
+ sum(data(iso0(is):isof(is),ics,ip)), &
+ sum(data(iso0(is):isof(is),ico,ip)), &
+ sum(data(iso0(is):isof(is),ica,ip)) + sum(data(iso0(is):isof(is),icl,ip)) + &
+ sum(data(iso0(is):isof(is),icn,ip)) + sum(data(iso0(is):isof(is),ics,ip)) + &
+ sum(data(iso0(is):isof(is),ico,ip))
+ end do
+ end if
+
+ enddo
+
+ end subroutine med_diag_print_atm
+
+ !===============================================================================
+
+ subroutine med_diag_print_lnd_ice_ocn(data, ip, cdate, curr_tod)
+
+ ! ---------------------------------------------------------
+ ! detail lnd/ocn/ice component budgets
+ ! ---------------------------------------------------------
+
+ ! intput/output variables
+ real(r8), intent(in) :: data(:,:,:) ! values to print, scaled and such
+ integer , intent(in) :: ip
+ integer , intent(in) :: cdate
+ integer , intent(in) :: curr_tod
+
+ ! local variables
+ integer :: ic,nf,is ! data array indicies
+ integer :: icar,icas
+ integer :: icxs,icxr
+ character(len=40) :: str ! string
+ character(*), parameter :: subName = '(med_diag_print_lnd_ocn_ice) '
+ ! ------------------------------------------------------------------
+
+ do ic = 1,4
+
+ if (ic == 1) then
+ icar = c_lnd_arecv
+ icxs = c_lnd_send
+ icxr = c_lnd_recv
+ icas = c_lnd_asend
+ str = "LND"
+ elseif (ic == 2) then
+ icar = c_ocn_arecv
+ icxs = c_ocn_send
+ icxr = c_ocn_recv
+ icas = c_ocn_asend
+ str = "OCN"
+ elseif (ic == 3) then
+ icar = c_inh_arecv
+ icxs = c_inh_send
+ icxr = c_inh_recv
+ icas = c_inh_asend
+ str = "ICE_NH"
+ elseif (ic == 4) then
+ icar = c_ish_arecv
+ icxs = c_ish_send
+ icxr = c_ish_recv
+ icas = c_ish_asend
+ str = "ICE_SH"
+ endif
+
+ ! heat budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh,
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//' HEAT BUDGET (W/m2): period = ',&
+ trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod
+ write(logunit,FA0) budget_diags%comps(icar)%name,&
+ budget_diags%comps(icxs)%name,&
+ budget_diags%comps(icxr)%name,&
+ budget_diags%comps(icas)%name,' *SUM* '
+ do nf = f_heat_beg, f_heat_end
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ -data(nf,icar,ip), &
+ data(nf,icxs,ip), &
+ data(nf,icxr,ip), &
+ -data(nf,icas,ip), &
+ -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip)
+ enddo
+ write(logunit,FA1)' *SUM*',&
+ -sum(data(f_heat_beg:f_heat_end,icar,ip)), &
+ sum(data(f_heat_beg:f_heat_end,icxs,ip)), &
+ sum(data(f_heat_beg:f_heat_end,icxr,ip)), &
+ -sum(data(f_heat_beg:f_heat_end,icas,ip)), &
+ -sum(data(f_heat_beg:f_heat_end,icar,ip)) + sum(data(f_heat_beg:f_heat_end,icxs,ip)) + &
+ sum(data(f_heat_beg:f_heat_end,icxr,ip)) - sum(data(f_heat_beg:f_heat_end,icas,ip))
+
+ ! water budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh,
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//' WATER BUDGET (kg/m2s*1e6): period = ',&
+ trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(icar)%name,&
+ budget_diags%comps(icxs)%name,&
+ budget_diags%comps(icxr)%name,&
+ budget_diags%comps(icas)%name,' *SUM* '
+ do nf = f_watr_beg, f_watr_end
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ -data(nf,icar,ip),&
+ data(nf,icxs,ip), &
+ data(nf,icxr,ip),&
+ -data(nf,icas,ip), &
+ -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip)
+ enddo
+ write(logunit,FA1) ' *SUM*',&
+ -sum(data(f_watr_beg:f_watr_end,icar,ip)), &
+ sum(data(f_watr_beg:f_watr_end,icxs,ip)), &
+ sum(data(f_watr_beg:f_watr_end,icxr,ip)), &
+ -sum(data(f_watr_beg:f_watr_end,icas,ip)), &
+ -sum(data(f_watr_beg:f_watr_end,icar,ip)) + sum(data(f_watr_beg:f_watr_end,icxs,ip)) + &
+ sum(data(f_watr_beg:f_watr_end,icxr,ip)) - sum(data(f_watr_beg:f_watr_end,icas,ip))
+
+ if ( flds_wiso ) then
+ do is = 1, nisotopes
+
+ ! heat budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh for water isotopes
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',&
+ trim(budget_diags%periods(ip)%name), &
+ ': date = ',cdate,curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(icar)%name,&
+ budget_diags%comps(icxs)%name,&
+ budget_diags%comps(icxr)%name,&
+ budget_diags%comps(icas)%name,' *SUM* '
+ do nf = iso0(is), isof(is)
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ -data(nf,icar,ip), &
+ data(nf,icxs,ip), &
+ data(nf,icxr,ip), &
+ -data(nf,icas,ip), &
+ -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip)
+ enddo
+ write(logunit,FA1) ' *SUM*',&
+ -sum(data(iso0(is):isof(is),icar,ip)),&
+ sum(data(iso0(is):isof(is),icxs,ip)), &
+ sum(data(iso0(is):isof(is),icxr,ip)), &
+ -sum(data(iso0(is):isof(is),icas,ip)), &
+ -sum(data(iso0(is):isof(is),icar,ip)) + sum(data(iso0(is):isof(is),icxs,ip)) + &
+ sum(data(iso0(is):isof(is),icxr,ip)) - sum(data(iso0(is):isof(is),icas,ip))
+
+ ! water budgets atm<->lnd, atm<->ocn, atm<->ice_nh, atm<->ice_sh for water isotopes
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,trim(str)//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ',&
+ trim(budget_diags%periods(ip)%name),&
+ ': date = ',cdate,curr_tod
+ write(logunit,FA0) &
+ budget_diags%comps(icar)%name,&
+ budget_diags%comps(icxs)%name,&
+ budget_diags%comps(icxr)%name,&
+ budget_diags%comps(icas)%name,' *SUM* '
+ do nf = iso0(is), isof(is)
+ write(logunit,FA1) budget_diags%fields(nf)%name,&
+ -data(nf,icar,ip), &
+ data(nf,icxs,ip), &
+ data(nf,icxr,ip), &
+ -data(nf,icas,ip), &
+ -data(nf,icar,ip) + data(nf,icxs,ip) + data(nf,icxr,ip) - data(nf,icas,ip)
+ enddo
+ write(logunit,FA1) ' *SUM*', &
+ -sum(data(iso0(is):isof(is), icar, ip)), &
+ sum(data(iso0(is):isof(is), icxs, ip)), &
+ sum(data(iso0(is):isof(is), icxr, ip)), &
+ -sum(data(iso0(is):isof(is), icas, ip)), &
+ -sum(data(iso0(is):isof(is), icar, ip)) + sum(data(iso0(is):isof(is), icxs, ip)) + &
+ sum(data(iso0(is):isof(is), icxr, ip)) - sum(data(iso0(is):isof(is), icas, ip))
+ end do
+ end if
+ enddo
+
+ end subroutine med_diag_print_lnd_ice_ocn
+
+ !===============================================================================
+
+ subroutine med_diag_print_summary(data, ip, cdate, curr_tod)
+
+ ! ---------------------------------------------------------
+ ! net summary budgets
+ ! ---------------------------------------------------------
+
+ ! intput/output variables
+ real(r8), intent(in) :: data(:,:,:) ! values to print, scaled and such
+ integer , intent(in) :: ip
+ integer , intent(in) :: cdate
+ integer , intent(in) :: curr_tod
+
+ ! local variables
+ integer :: ic,nf,is ! data array indicies
+ real(r8) :: atm_area, lnd_area, ocn_area
+ real(r8) :: ice_area_nh, ice_area_sh
+ real(r8) :: sum_area, sum_area_tot
+ real(r8) :: net_water_atm , sum_net_water_atm
+ real(r8) :: net_water_lnd , sum_net_water_lnd
+ real(r8) :: net_water_rof , sum_net_water_rof
+ real(r8) :: net_water_ocn , sum_net_water_ocn
+ real(r8) :: net_water_glc , sum_net_water_glc
+ real(r8) :: net_water_ice_nh , sum_net_water_ice_nh
+ real(r8) :: net_water_ice_sh , sum_net_water_ice_sh
+ real(r8) :: net_water_tot , sum_net_water_tot
+ real(r8) :: net_heat_atm , sum_net_heat_atm
+ real(r8) :: net_heat_lnd , sum_net_heat_lnd
+ real(r8) :: net_heat_rof , sum_net_heat_rof
+ real(r8) :: net_heat_ocn , sum_net_heat_ocn
+ real(r8) :: net_heat_glc , sum_net_heat_glc
+ 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
+ character(len=40) :: str
+ character(*), parameter:: subName = '(med_diag_print_summary) '
+ ! ------------------------------------------------------------------
+
+ ! write out areas
+
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,'NET AREA BUDGET (m2/m2): period = ',&
+ trim(budget_diags%periods(ip)%name),&
+ ': date = ',cdate,curr_tod
+ write(logunit,FA0) ' atm',' lnd',' ocn',' ice nh',' ice sh',' *SUM* '
+ atm_area = data(f_area,c_atm_recv,ip)
+ lnd_area = data(f_area,c_lnd_recv,ip)
+ ocn_area = data(f_area,c_ocn_recv,ip)
+ ice_area_nh = data(f_area,c_inh_recv,ip)
+ 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(logunit,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(logunit,*) ' '
+ write(logunit,FAH) subname,'NET HEAT BUDGET (W/m2): period = ',&
+ trim(budget_diags%periods(ip)%name), ': date = ',cdate,curr_tod
+ write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* '
+ do nf = f_heat_beg, f_heat_end
+ net_heat_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip)
+ net_heat_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip)
+ net_heat_rof = data(nf, c_rof_recv, ip) + data(nf, c_rof_send, ip)
+ net_heat_ocn = data(nf, c_ocn_recv, ip) + data(nf, c_ocn_send, ip)
+ net_heat_ice_nh = data(nf, c_inh_recv, ip) + data(nf, c_inh_send, ip)
+ net_heat_ice_sh = data(nf, c_ish_recv, ip) + data(nf, c_ish_send, ip)
+ net_heat_glc = data(nf, c_glc_recv, ip) + data(nf, c_glc_send, ip)
+ net_heat_tot = net_heat_atm + net_heat_lnd + net_heat_rof + net_heat_ocn + &
+ net_heat_ice_nh + net_heat_ice_sh + net_heat_glc
+
+ write(logunit,FA1r) budget_diags%fields(nf)%name,&
+ net_heat_atm, net_heat_lnd, net_heat_rof, net_heat_ocn, &
+ net_heat_ice_nh, net_heat_ice_sh, net_heat_glc, net_heat_tot
+ 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)) + &
+ sum(data(f_heat_beg:f_heat_end, c_lnd_send, ip))
+ sum_net_heat_rof = sum(data(f_heat_beg:f_heat_end, c_rof_recv, ip)) + &
+ sum(data(f_heat_beg:f_heat_end, c_rof_send, ip))
+ sum_net_heat_ocn = sum(data(f_heat_beg:f_heat_end, c_ocn_recv, ip)) + &
+ sum(data(f_heat_beg:f_heat_end, c_ocn_send, ip))
+ sum_net_heat_ice_nh = sum(data(f_heat_beg:f_heat_end, c_inh_recv, ip)) + &
+ sum(data(f_heat_beg:f_heat_end, c_inh_send, ip))
+ sum_net_heat_ice_sh = sum(data(f_heat_beg:f_heat_end, c_ish_recv, ip)) + &
+ sum(data(f_heat_beg:f_heat_end, c_ish_send, ip))
+ sum_net_heat_glc = sum(data(f_heat_beg:f_heat_end, c_glc_recv, ip)) + &
+ sum(data(f_heat_beg:f_heat_end, c_glc_send, ip))
+ sum_net_heat_tot = 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
+
+ write(logunit,FA1r)' *SUM*',&
+ 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(logunit,*) ' '
+ write(logunit,FAH) subname,'NET WATER BUDGET (kg/m2s*1e6): period = ',&
+ trim(budget_diags%periods(ip)%name), ': date = ',cdate,curr_tod
+ write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* '
+ do nf = f_watr_beg, f_watr_end
+ net_water_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip)
+ net_water_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip)
+ net_water_rof = data(nf, c_rof_recv, ip) + data(nf, c_rof_send, ip)
+ net_water_ocn = data(nf, c_ocn_recv, ip) + data(nf, c_ocn_send, ip)
+ net_water_ice_nh = data(nf, c_inh_recv, ip) + data(nf, c_inh_send, ip)
+ net_water_ice_sh = data(nf, c_ish_recv, ip) + data(nf, c_ish_send, ip)
+ net_water_glc = data(nf, c_glc_recv, ip) + data(nf, c_glc_send, ip)
+ net_water_tot = net_water_atm + net_water_lnd + net_water_rof + net_water_ocn + &
+ net_water_ice_nh + net_water_ice_sh + net_water_glc
+
+ write(logunit,FA1r) budget_diags%fields(nf)%name,&
+ net_water_atm, net_water_lnd, net_water_rof, net_water_ocn, &
+ 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)
+
+ 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)) + &
+ sum(data(f_watr_beg:f_watr_end, c_lnd_send, ip))
+ sum_net_water_rof = sum(data(f_watr_beg:f_watr_end, c_rof_recv, ip)) + &
+ sum(data(f_watr_beg:f_watr_end, c_rof_send, ip))
+ sum_net_water_ocn = sum(data(f_watr_beg:f_watr_end, c_ocn_recv, ip)) + &
+ sum(data(f_watr_beg:f_watr_end, c_ocn_send, ip))
+ sum_net_water_ice_nh = sum(data(f_watr_beg:f_watr_end, c_inh_recv, ip)) + &
+ sum(data(f_watr_beg:f_watr_end, c_inh_send, ip))
+ sum_net_water_ice_sh = sum(data(f_watr_beg:f_watr_end, c_ish_recv, ip)) + &
+ sum(data(f_watr_beg:f_watr_end, c_ish_send, ip))
+ sum_net_water_glc = sum(data(f_watr_beg:f_watr_end, c_glc_recv, ip)) + &
+ sum(data(f_watr_beg:f_watr_end, c_glc_send, ip))
+ sum_net_water_tot = sum_net_water_atm + sum_net_water_lnd + sum_net_water_rof + sum_net_water_ocn + &
+ sum_net_water_ice_nh + sum_net_water_ice_sh + sum_net_water_glc
+
+ write(logunit,FA1r)' *SUM*',&
+ sum_net_water_atm, sum_net_water_lnd, sum_net_water_rof, sum_net_water_ocn, &
+ sum_net_water_ice_nh, sum_net_water_ice_sh, sum_net_water_glc, sum_net_water_tot
+
+ ! write out net water water-isoptope budgets
+
+ if ( flds_wiso ) then
+
+ do is = 1, nisotopes
+ write(logunit,*) ' '
+ write(logunit,FAH) subname,'NET '//isoname(is)//' WATER BUDGET (kg/m2s*1e6): period = ', &
+ trim(budget_diags%periods(ip)%name),': date = ',cdate,curr_tod
+ write(logunit,FA0r) ' atm',' lnd',' rof',' ocn',' ice nh',' ice sh',' glc',' *SUM* '
+ do nf = iso0(is), isof(is)
+ net_water_atm = data(nf, c_atm_recv, ip) + data(nf, c_atm_send, ip)
+ net_water_lnd = data(nf, c_lnd_recv, ip) + data(nf, c_lnd_send, ip)
+ net_water_rof = data(nf, c_rof_recv, ip) + data(nf, c_rof_send, ip)
+ net_water_ocn = data(nf, c_ocn_recv, ip) + data(nf, c_ocn_send, ip)
+ net_water_ice_nh = data(nf, c_inh_recv, ip) + data(nf, c_inh_send, ip)
+ net_water_ice_sh = data(nf, c_ish_recv, ip) + data(nf, c_ish_send, ip)
+ net_water_glc = data(nf, c_glc_recv, ip) + data(nf, c_glc_send, ip)
+ net_water_tot = net_water_atm + net_water_lnd + net_water_rof + net_water_ocn + &
+ net_water_ice_nh + net_water_ice_sh + net_water_glc
+
+ write(logunit,FA1r) budget_diags%fields(nf)%name,&
+ net_water_atm, net_water_lnd, net_water_rof, net_water_ocn, &
+ net_water_ice_nh, net_water_ice_sh, net_water_glc, net_water_tot
+ enddo
+
+ sum_net_water_atm = sum(data(iso0(is):isof(is), c_atm_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_atm_send, ip))
+ sum_net_water_lnd = sum(data(iso0(is):isof(is), c_lnd_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_lnd_send, ip))
+ sum_net_water_rof = sum(data(iso0(is):isof(is), c_rof_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_rof_send, ip))
+ sum_net_water_ocn = sum(data(iso0(is):isof(is), c_ocn_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_ocn_send, ip))
+ sum_net_water_ice_nh = sum(data(iso0(is):isof(is), c_inh_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_inh_send, ip))
+ sum_net_water_ice_sh = sum(data(iso0(is):isof(is), c_ish_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_ish_send, ip))
+ sum_net_water_glc = sum(data(iso0(is):isof(is), c_glc_recv, ip)) + &
+ sum(data(iso0(is):isof(is), c_glc_send, ip))
+ sum_net_water_tot = sum_net_water_atm + sum_net_water_lnd + sum_net_water_rof + &
+ sum_net_water_ocn + sum_net_water_ice_nh + sum_net_water_ice_sh + &
+ sum_net_water_glc
+
+ write(logunit,FA1r)' *SUM*',&
+ sum_net_water_atm, sum_net_water_lnd, sum_net_water_rof, sum_net_water_ocn, &
+ sum_net_water_ice_nh, sum_net_water_ice_sh, sum_net_water_glc, sum_net_water_tot
+ end do
+ end if
+
+ end subroutine med_diag_print_summary
+
+ !===============================================================================
+
+ subroutine add_to_budget_diag(entries, index, name)
+
+ ! input/output variablesn
+ type(budget_diag_type) , pointer :: entries(:)
+ integer , intent(out) :: index
+ character(len=*) , intent(in) :: name
+
+ ! local variables
+ integer :: n
+ integer :: oldsize
+ logical :: found
+ type(budget_diag_type), pointer :: new_entries(:) => null()
+ character(len=*), parameter :: subname='(add_to_budget_diag)'
+ !----------------------------------------------------------------------
+
+ if (associated(entries)) then
+ oldsize = size(entries)
+ found = .false.
+ do n= 1,oldsize
+ if (trim(name) == trim(entries(n)%name)) then
+ found = .true.
+ exit
+ end if
+ end do
+ else
+ oldsize = 0
+ found = .false.
+ end if
+ index = oldsize + 1
+
+ ! create new entry if fldname is not in original list
+
+ if (.not. found) then
+
+ ! 1) allocate newfld to be size (one element larger than input flds)
+ allocate(new_entries(index))
+
+ ! 2) copy entries into first N-1 elements of new_entries
+ do n = 1,oldsize
+ new_entries(n)%name = entries(n)%name
+ end do
+
+ ! 3) deallocate / nullify entries
+ if (oldsize > 0) then
+ deallocate(entries)
+ nullify(entries)
+ end if
+ entries => new_entries
+
+ ! 4) point entries => new_entries
+ entries => new_entries
+
+ ! 5) now update entries information for new entry
+ entries(index)%name = trim(name)
+ end if
+
+ end subroutine add_to_budget_diag
+
+end module med_diag_mod
diff --git a/mediator/med_fraction_mod.F90 b/mediator/med_fraction_mod.F90
index 14cb9f4c3..8cc6152d7 100644
--- a/mediator/med_fraction_mod.F90
+++ b/mediator/med_fraction_mod.F90
@@ -3,29 +3,24 @@ module med_fraction_mod
!-----------------------------------------------------------------------------
! Mediator Component.
! Sets fractions on all component grids
- ! the fractions fields are now afrac, ifrac, ofrac, lfrac, and lfrin.
- ! afrac = fraction of atm on a grid
+ ! the fractions fields are now ifrac, ofrac, lfrac
! lfrac = fraction of lnd on a grid
! ifrac = fraction of ice on a grid
! ofrac = fraction of ocn on a grid
- ! lfrin = land fraction defined by the land model
! ifrad = fraction of ocn on a grid at last radiation time
! ofrad = fraction of ice on a grid at last radiation time
!
- ! afrac, lfrac, ifrac, and ofrac:
+ ! lfrac, ifrac, and ofrac:
! are the self-consistent values in the system
- ! lfrin:
- ! is the fraction on the land grid and is allowed to
- ! vary from the self-consistent value as descibed below.
! ifrad and ofrad:
! are needed for the swnet calculation.
!
! the fractions fields are defined for each grid in the fraction bundles as
! needed as follows.
- ! character(*),parameter :: fraclist_a = 'afrac:ifrac:ofrac:lfrac:lfrin'
- ! character(*),parameter :: fraclist_o = 'afrac:ifrac:ofrac:ifrad:ofrad'
- ! character(*),parameter :: fraclist_i = 'afrac:ifrac:ofrac'
- ! character(*),parameter :: fraclist_l = 'afrac:lfrac:lfrin'
+ ! character(*),parameter :: fraclist_a = 'ifrac:ofrac:lfrac
+ ! character(*),parameter :: fraclist_o = 'ifrac:ofrac:ifrad:ofrad'
+ ! character(*),parameter :: fraclist_i = 'ifrac:ofrac'
+ ! character(*),parameter :: fraclist_l = 'lfrac'
! character(*),parameter :: fraclist_g = 'gfrac:lfrac'
! character(*),parameter :: fraclist_r = 'lfrac:rfrac'
!
@@ -39,34 +34,26 @@ module med_fraction_mod
! we assume that component fractions sent at runtime
! are always the relative fraction covered.
! for example, if an ice cell can be up to 50% covered in
- ! ice and 50% land, then the ice domain should have a fraction
+ ! ice and 50% land, then the ice should have a fraction
! value of 0.5 at that grid cell. at run time though, the ice
! fraction will be between 0.0 and 1.0 meaning that grid cells
! is covered with between 0.0 and 0.5 by ice. the "relative" fractions
! sent at run-time are corrected by the model to be total fractions
! such that in general, on every grid,
- ! fractions_*(afrac) = 1.0
! fractions_*(ifrac) + fractions_*(ofrac) + fractions_*(lfrac) = 1.0
! where fractions_* are a bundle of fractions on a particular grid and
- ! *frac (ie afrac) is the fraction of a particular component in the bundle.
+ ! *frac is the fraction of a particular component in the bundle.
!
! the fractions are computed fundamentally as follows (although the
! detailed implementation might be slightly different)
!
! initialization:
- ! afrac is set on all grids
- ! fractions_a(afrac) = 1.0
- ! fractions_o(afrac) = mapa2o(fractions_a(afrac))
- ! fractions_i(afrac) = mapa2i(fractions_a(afrac))
- ! fractions_l(afrac) = mapa2l(fractions_a(afrac))
! initially assume ifrac on all grids is zero
! fractions_*(ifrac) = 0.0
! fractions/masks provided by surface components
! fractions_o(ofrac) = ocean "mask" provided by ocean
- ! fractions_l(lfrin) = land "fraction provided by land
! then mapped to the atm model
! fractions_a(ofrac) = mapo2a(fractions_o(ofrac))
- ! fractions_a(lfrin) = mapl2a(fractions_l(lfrin))
! and a few things are then derived
! fractions_a(lfrac) = 1.0 - fractions_a(ofrac)
! this is truncated to zero for very small values (< 0.001)
@@ -92,10 +79,8 @@ module med_fraction_mod
! fraction corrections in mapping are as follows
! mapo2a uses *fractions_o(ofrac) and /fractions_a(ofrac)
! mapi2a uses *fractions_i(ifrac) and /fractions_a(ifrac)
- ! mapl2a uses *fractions_l(lfrin) and /fractions_a(lfrin)
+ ! mapl2a uses *fractions_l(lfrac)
! mapl2g weights by fractions_l(lfrac) with normalization and multiplies by fractions_g(lfrac)
- ! mapa2* should use *fractions_a(afrac) and /fractions_*(afrac) but this
- ! has been defered since the ratio always close to 1.0
!
! run time:
! fractions_a(lfrac) + fractions_a(ofrac) + fractions_a(ifrac) ~ 1.0
@@ -118,10 +103,9 @@ module med_fraction_mod
use med_utils_mod , only : chkErr => med_utils_ChkErr
use med_methods_mod , only : FB_init => med_methods_FB_init
use med_methods_mod , only : FB_reset => med_methods_FB_reset
- use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
use med_methods_mod , only : FB_fldChk => med_methods_FB_fldChk
- use med_map_mod , only : FB_FieldRegrid => med_map_FB_Field_Regrid
+ use med_map_mod , only : med_map_field
use esmFlds , only : ncomps
implicit none
@@ -133,10 +117,10 @@ module med_fraction_mod
integer, parameter :: nfracs = 5
character(len=5) :: fraclist(nfracs,ncomps)
- character(len=5),parameter,dimension(5) :: fraclist_a = (/'afrac','ifrac','ofrac','lfrac','lfrin'/)
- character(len=5),parameter,dimension(5) :: fraclist_o = (/'afrac','ifrac','ofrac','ifrad','ofrad'/)
- character(len=5),parameter,dimension(3) :: fraclist_i = (/'afrac','ifrac','ofrac'/)
- character(len=5),parameter,dimension(3) :: fraclist_l = (/'afrac','lfrac','lfrin'/)
+ character(len=5),parameter,dimension(3) :: fraclist_a = (/'ifrac','ofrac','lfrac'/)
+ character(len=5),parameter,dimension(4) :: fraclist_o = (/'ifrac','ofrac','ifrad','ofrad'/)
+ character(len=5),parameter,dimension(2) :: fraclist_i = (/'ifrac','ofrac'/)
+ character(len=5),parameter,dimension(1) :: fraclist_l = (/'lfrac'/)
character(len=5),parameter,dimension(2) :: fraclist_g = (/'gfrac','lfrac'/)
character(len=5),parameter,dimension(2) :: fraclist_r = (/'rfrac','lfrac'/)
character(len=5),parameter,dimension(1) :: fraclist_w = (/'wfrac'/)
@@ -146,24 +130,26 @@ module med_fraction_mod
character(*), parameter :: u_FILE_u = &
__FILE__
-!-----------------------------------------------------------------------------
+!================================================================================================
contains
-!-----------------------------------------------------------------------------
+!================================================================================================
subroutine med_fraction_init(gcomp, rc)
! Initialize FBFrac(:) field bundles
- use ESMF , only : ESMF_GridComp, ESMF_Field
- use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only : ESMF_GridCompGet, ESMF_StateIsCreated
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR
+ use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_StateIsCreated
use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleIsCreated, ESMF_FieldBundleDestroy
+ use ESMF , only : ESMF_FieldBundleGet
+ use ESMF , only : ESMF_Field, ESMF_FieldGet
use esmFlds , only : coupling_mode
use esmFlds , only : compatm, compocn, compice, complnd
use esmFlds , only : comprof, compglc, compwav, compname
- use esmFlds , only : mapconsf, mapfcopy, mapnstod_consf
- use med_map_mod , only : med_map_Fractions_init, med_map_RH_is_created
- use med_internalstate_mod , only : InternalState
+ use esmFlds , only : mapfcopy, mapconsd, mapnstod_consd
+ use med_map_mod , only : med_map_routehandles_init, med_map_rh_is_created
+ use med_internalstate_mod , only : InternalState, logunit, mastertask
use perf_mod , only : t_startf, t_stopf
! input/output variables
@@ -171,27 +157,27 @@ subroutine med_fraction_init(gcomp, rc)
integer, intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- type(ESMF_FieldBundle) :: FBtemp
- real(R8), pointer :: frac(:)
- real(R8), pointer :: ofrac(:)
- real(R8), pointer :: lfrac(:)
- real(R8), pointer :: ifrac(:)
- real(R8), pointer :: afrac(:)
- real(R8), pointer :: gfrac(:)
- real(R8), pointer :: lfrin(:)
- real(R8), pointer :: rfrac(:)
- real(R8), pointer :: wfrac(:)
- real(R8), pointer :: Sl_lfrin(:)
- real(R8), pointer :: Si_imask(:)
- real(R8), pointer :: So_omask(:)
- integer :: i,j,n,n1
- integer :: maptype
+ type(InternalState) :: is_local
+ type(ESMF_Field) :: field_src
+ type(ESMF_Field) :: field_dst
+ type(ESMF_Field) :: lfield
+ real(R8), pointer :: frac(:) => null()
+ real(R8), pointer :: ofrac(:) => null()
+ real(R8), pointer :: lfrac(:) => null()
+ real(R8), pointer :: ifrac(:) => null()
+ real(R8), pointer :: gfrac(:) => null()
+ real(R8), pointer :: rfrac(:) => null()
+ real(R8), pointer :: wfrac(:) => null()
+ real(R8), pointer :: Sl_lfrin(:) => null()
+ real(R8), pointer :: Si_imask(:) => null()
+ real(R8), pointer :: So_omask(:) => null()
+ integer :: i,j,n,n1
+ integer :: maptype
logical, save :: first_call = .true.
- character(len=*),parameter :: subname='(med_fraction_init)'
+ character(len=*),parameter :: subname=' (med_fraction_init)'
!---------------------------------------
- call t_startf('MED:'//subname)
+ call t_startf('MED:'//subname)
if (dbug_flag > 20) then
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
end if
@@ -218,203 +204,171 @@ subroutine med_fraction_init(gcomp, rc)
fraclist(1:size(fraclist_g),compglc) = fraclist_g
!---------------------------------------
- ! Initialize FBFrac(:) to zero
+ ! Create field bundles and initialize them to zero
!---------------------------------------
! Note - must use import state here - since export state might not
! contain anything other than scalar data if the component is not prognostic
do n1 = 1,ncomps
- if (is_local%wrap%comp_present(n1) .and. ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then
-
+ if ( is_local%wrap%comp_present(n1) .and. &
+ ESMF_StateIsCreated(is_local%wrap%NStateImp(n1),rc=rc)) then
+ ! create FBFrac and zero out FBfrac(n1)
call FB_init(is_local%wrap%FBfrac(n1), is_local%wrap%flds_scalar_name, &
STgeom=is_local%wrap%NStateImp(n1), fieldNameList=fraclist(:,n1), &
name='FBfrac'//trim(compname(n1)), rc=rc)
-
- ! zero out FBfracs
call FB_reset(is_local%wrap%FBfrac(n1), value=czero, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
end do
first_call = .false.
+
endif
!---------------------------------------
- ! Set 'afrac' for FBFrac(compatm), FBFrac(compice), FBFrac(compocn), FBFrac(complnd)
+ ! Set 'lfrac' for FBFrac(complnd) - this might be overwritten later
!---------------------------------------
- if (is_local%wrap%comp_present(compatm)) then
-
- ! Set 'afrac' for FBFrac(compatm) to 1
- call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'afrac', afrac, rc=rc)
+ if (is_local%wrap%comp_present(complnd)) then
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd) , fieldname='Sl_lfrin', &
+ field=lfield, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- afrac(:) = 1.0_R8
-
- ! Set 'afrac' for FBFrac(compice), FBFrac(compocn) and FBFrac(complnd)
- do n = 1,ncomps
- if (n == compice .or. n == compocn .or. n == complnd) then
- if (is_local%wrap%med_coupling_active(compatm,n)) then
- if (med_map_RH_is_created(is_local%wrap%RH(compatm,n,:),mapfcopy, rc=rc)) then
- maptype = mapfcopy
- else
- maptype = mapconsf
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compatm,n,:),mapconsf, rc=rc)) then
- call med_map_Fractions_init( gcomp, compatm, n, &
- FBSrc=is_local%wrap%FBImp(compatm,compatm), &
- FBDst=is_local%wrap%FBImp(compatm,n), &
- RouteHandle=is_local%wrap%RH(compatm,n,mapconsf), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- end if
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compatm), 'afrac', &
- is_local%wrap%FBfrac(n), 'afrac', &
- is_local%wrap%RH(compatm,n,:),maptype, rc=rc)
- if(ChkErr(rc,__LINE__,u_FILE_u)) return
- endif
- end if
- end do
-
+ call ESMF_FieldGet(lfield, farrayPtr=Sl_lfrin, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(complnd) , fieldname='lfrac', &
+ field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=lfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ lfrac(:) = Sl_lfrin(:)
end if
!---------------------------------------
- ! Set 'lfrin' for FBFrac(complnd) and FBFrac(compatm)
+ ! Set 'ifrac' in FBFrac(compice) and FBFrac(compatm)
!---------------------------------------
- ! The following is just an initial "guess", updated later
-
- if (is_local%wrap%comp_present(complnd)) then
+ if (is_local%wrap%comp_present(compice)) then
- ! Set 'lfrin' for FBFrac(complnd)
- call FB_getFldPtr(is_local%wrap%FBImp(complnd,complnd) , 'Sl_lfrin' , Sl_lfrin, rc=rc)
+ ! Set 'ifrac' FBFrac(compice)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compice,compice) , fieldname='Si_imask', &
+ field=lfield, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(complnd), 'lfrin', lfrin, rc=rc)
+ call ESMF_FieldGet(lfield, farrayPtr=Si_imask, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- lfrin(:) = Sl_lfrin(:)
-
- ! Set 'lfrin for FBFrac(compatm)
- if (is_local%wrap%comp_present(compatm) .and. (is_local%wrap%med_coupling_active(compatm,complnd))) then
- ! Note - need to do the following if compatm->complnd is active, even if complnd->compatm is not active
-
- ! Create a temporary field bundle if one does not exists
- if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(complnd,compatm))) then
- call FB_init(FBout=FBtemp, &
- flds_scalar_name=is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(compatm,compatm), &
- fieldNameList=(/'Fldtemp'/), name='FBtemp', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compice) , fieldname='ifrac', &
+ field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=ifrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ifrac(:) = Si_imask(:)
+
+ ! Set 'ifrac' in FBFrac(compatm) - at this point this is the ice mask mapped to the atm mesh
+ ! This maps the ice mask (which is the same as the ocean mask) to the atm mesh
+ if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%med_coupling_active(compice,compatm)) then
- ! Determine map type
- if (med_map_RH_is_created(is_local%wrap%RH(compatm,complnd,:),mapfcopy, rc=rc)) then
+ if (med_map_RH_is_created(is_local%wrap%RH(compice,compatm,:),mapfcopy, rc=rc)) then
+ ! If ice and atm are on the same mesh - a redist route handle has already been created
maptype = mapfcopy
else
- maptype = mapconsf
- end if
-
- ! Create route handle from lnd->atm if necessary
- if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,compatm,:),maptype, rc=rc)) then
- if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(complnd,compatm))) then
- call med_map_Fractions_init( gcomp, complnd, compatm, &
- FBSrc=is_local%wrap%FBImp(complnd,complnd), &
- FBDst=is_local%wrap%FBImp(complnd,compatm), &
- RouteHandle=is_local%wrap%RH(complnd,compatm,maptype), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (trim(coupling_mode) == 'nems_orig' ) then
+ maptype = mapnstod_consd
else
- call med_map_Fractions_init( gcomp, complnd, compatm, &
- FBSrc=is_local%wrap%FBImp(complnd,complnd), &
- FBDst=FBtemp, &
- RouteHandle=is_local%wrap%RH(complnd,compatm,maptype), rc=rc)
+ maptype = mapconsd
+ end if
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(compice,compatm,:),maptype, rc=rc)) then
+ call med_map_routehandles_init( compice, compatm, &
+ FBSrc=is_local%wrap%FBImp(compice,compice), &
+ FBDst=is_local%wrap%FBImp(compice,compatm), &
+ mapindex=maptype, RouteHandle=is_local%wrap%RH, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
end if
-
- ! Regrid 'lfrin' from FBFrac(complnd) -> FBFrac(compatm)
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(complnd), 'lfrin', &
- is_local%wrap%FBfrac(compatm), 'lfrin', &
- is_local%wrap%RH(complnd,compatm,:),maptype, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compice), 'ifrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'ifrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compice,compatm,:), maptype, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
- ! Destroy temporary field bundle if created
- if (ESMF_FieldBundleIsCreated(FBTemp)) then
- call ESMF_FieldBundleDestroy(FBtemp, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
end if
end if
!---------------------------------------
- ! Set 'ifrac' in FBFrac(compice) and FBFrac(compatm)
+ ! Set 'ofrac' in FBFrac(compocn) and 'ofrac' in FBFrac(compatm)
!---------------------------------------
- if (is_local%wrap%comp_present(compice)) then
+ if (is_local%wrap%comp_present(compocn)) then
- ! Set 'ifrac' FBFrac(compice)
- call FB_getFldPtr(is_local%wrap%FBImp(compice,compice) , 'Si_imask' , Si_imask, rc=rc)
+ ! Set 'ofrac' in FBFrac(compocn)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compocn,compocn), fieldName='So_omask', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=So_omask, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compocn), fieldName='ofrac', field=lfield, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ifrac', ifrac, rc=rc)
+ call ESMF_FieldGet(lfield, farrayPtr=ofrac, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ofrac(:) = So_omask(:)
- ifrac(:) = Si_imask(:)
+ ! Set 'ofrac' in FBFrac(compatm) - at this point this is the ocean mask mapped to the atm grid
+ ! This is mapping the ocean mask to the atm grid - so in effect it is (1-land fraction) on the atm grid
+ if (is_local%wrap%comp_present(compatm) .and. is_local%wrap%med_coupling_active(compocn,compatm)) then
- ! Set 'ifrac' in FBFrac(compatm)
- if (is_local%wrap%comp_present(compatm)) then
- if (is_local%wrap%med_coupling_active(compice,compatm)) then
- if (med_map_RH_is_created(is_local%wrap%RH(compice,compatm,:),mapfcopy, rc=rc)) then
- maptype = mapfcopy
+ if (med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:),mapfcopy, rc=rc)) then
+ ! If ocn and atm are on the same mesh - a redist route handle has already been created
+ maptype = mapfcopy
+ else
+ if (trim(coupling_mode) == 'nems_orig' ) then
+ maptype = mapnstod_consd
else
- maptype = mapconsf
+ maptype = mapconsd
end if
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compice,compatm,:),maptype, rc=rc)) then
- call med_map_Fractions_init( gcomp, compice, compatm, &
- FBSrc=is_local%wrap%FBImp(compice,compice), &
- FBDst=is_local%wrap%FBImp(compice,compatm), &
- RouteHandle=is_local%wrap%RH(compice,compatm,maptype), rc=rc)
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:),maptype, rc=rc)) then
+ call med_map_routehandles_init( compocn, compatm, &
+ FBSrc=is_local%wrap%FBImp(compocn,compocn), &
+ FBDst=is_local%wrap%FBImp(compocn,compatm), &
+ mapindex=maptype, RouteHandle=is_local%wrap%RH, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compice), 'ifrac', &
- is_local%wrap%FBfrac(compatm), 'ifrac', &
- is_local%wrap%RH(compice,compatm,:),maptype, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- endif
- endif
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compocn), fieldname='ofrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), fieldname='ofrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compocn,compatm,:), maptype, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ end if
+ end if
!---------------------------------------
- ! Set 'ofrac' in FBFrac(compocn) and FBFrac(compatm)
+ ! Reset 'lfrac' in FBFrac(complnd) by mapping FBFrac(compatm) if appropriate
!---------------------------------------
- if (is_local%wrap%comp_present(compocn)) then
+ if (is_local%wrap%comp_present(complnd) .and. is_local%wrap%med_coupling_active(complnd,compatm)) then
- call FB_getFldPtr(is_local%wrap%FBImp(compocn,compocn) , 'So_omask', So_omask, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compocn), 'ofrac', ofrac, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ! Reset 'lfrac' in FBFrac(complnd) by mapping the Frac
+ ! If lnd -> atm coupling is active - map 'lfrac' from FBFrac(compatm) to FBFrac(complnd)
- ofrac(:) = So_omask(:)
-
- if (is_local%wrap%med_coupling_active(compocn,compatm)) then
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compocn,compatm,:),mapconsf, rc=rc)) then
- call med_map_Fractions_init( gcomp, compocn, compatm, &
- FBSrc=is_local%wrap%FBImp(compocn,compocn), &
- FBDst=is_local%wrap%FBImp(compocn,compatm), &
- RouteHandle=is_local%wrap%RH(compocn,compatm,mapconsf), rc=rc)
+ if (med_map_RH_is_created(is_local%wrap%RH(compatm,complnd,:),mapfcopy, rc=rc)) then
+ maptype = mapfcopy
+ else
+ maptype = mapconsd
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(compatm,complnd,:),maptype, rc=rc)) then
+ call med_map_routehandles_init( compatm, complnd, &
+ FBSrc=is_local%wrap%FBImp(compatm,compatm), &
+ FBDst=is_local%wrap%FBImp(compatm,complnd), &
+ mapindex=maptype, RouteHandle=is_local%wrap%RH, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compocn), 'ofrac', &
- is_local%wrap%FBfrac(compatm), 'ofrac', &
- is_local%wrap%RH(compocn,compatm,:),mapconsf, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'lfrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(complnd), 'lfrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compatm,complnd,:), maptype, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
-
-
!---------------------------------------
! Set 'lfrac' in FBFrac(compatm) and correct 'ofrac' in FBFrac(compatm)
! ---------------------------------------
-
! These should actually be mapo2a of ofrac and lfrac but we can't
! map lfrac from o2a due to masked mapping weights. So we have to
! settle for a residual calculation that is truncated to zero to
@@ -423,28 +377,60 @@ subroutine med_fraction_init(gcomp, rc)
if (is_local%wrap%comp_present(compatm)) then
if (is_local%wrap%comp_present(compocn) .or. is_local%wrap%comp_present(compice)) then
- call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'lfrac', lfrac, rc=rc)
- call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ofrac', ofrac, rc=rc)
- if (.not. is_local%wrap%comp_present(complnd)) then
- lfrac(:) = 0.0_R8
- else
+ ! Ocean is present
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'lfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=lfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'ofrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=ofrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (is_local%wrap%comp_present(complnd)) then
do n = 1,size(lfrac)
lfrac(n) = 1.0_R8 - ofrac(n)
if (abs(lfrac(n)) < eps_fraclim) then
lfrac(n) = 0.0_R8
end if
end do
+ else
+ lfrac(:) = 0.0_R8
end if
- else if (is_local%wrap%comp_present(complnd)) then
+ else if (is_local%wrap%comp_present(complnd) .and. is_local%wrap%med_coupling_active(complnd,compatm)) then
+
+ ! If the ocean or ice are absent, regrid 'lfrac' from FBFrac(complnd) -> FBFrac(compatm)
+ if (med_map_RH_is_created(is_local%wrap%RH(complnd,compatm,:),mapfcopy, rc=rc)) then
+ maptype = mapfcopy
+ else
+ maptype = mapconsd
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,compatm,:),maptype, rc=rc)) then
+ if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(complnd,compatm))) then
+ call med_map_routehandles_init( complnd, compatm, &
+ FBSrc=is_local%wrap%FBImp(complnd,complnd), &
+ FBDst=is_local%wrap%FBImp(complnd,compatm), &
+ mapindex=maptype, RouteHandle=is_local%wrap%RH, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ end if
+ end if
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(complnd), 'lfrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'lfrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(complnd,compatm,:), maptype, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
- ! If the ocean or ice are absent, then simply set 'lfrac' to 'lfrin' for FBFrac(compatm)
- call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'lfrin', lfrin, rc=rc)
- call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'lfrac', lfrac, rc=rc)
- call FB_getFldPtr(is_local%wrap%FBfrac(compatm), 'ofrac', ofrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'lfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=lfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'ofrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=ofrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
do n = 1,size(lfrac)
- lfrac(n) = lfrin(n)
ofrac(n) = 1.0_R8 - lfrac(n)
if (abs(ofrac(n)) < eps_fraclim) then
ofrac(n) = 0.0_R8
@@ -454,40 +440,6 @@ subroutine med_fraction_init(gcomp, rc)
end if
end if
- !---------------------------------------
- ! Set 'lfrac' in FBFrac(complnd)
- !---------------------------------------
-
- if (is_local%wrap%comp_present(complnd)) then
-
- ! Set 'lfrac' in FBFrac(complnd)
- if (is_local%wrap%comp_present(compatm)) then
- ! If atm -> lnd coupling is active - map 'lfrac' from FBFrac(compatm) to FBFrac(complnd)
- if (is_local%wrap%med_coupling_active(compatm,complnd)) then
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compatm,complnd,:),mapconsf, rc=rc)) then
- call med_map_Fractions_init( gcomp, compatm, complnd, &
- FBSrc=is_local%wrap%FBImp(compatm,compatm), &
- FBDst=is_local%wrap%FBImp(compatm,complnd), &
- RouteHandle=is_local%wrap%RH(compatm,complnd,mapconsf), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compatm), 'lfrac', &
- is_local%wrap%FBfrac(complnd), 'lfrac', &
- is_local%wrap%RH(compatm,complnd,:),mapconsf, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- else
- ! If the atm ->lnd coupling is not active - simply set 'lfrac' to 'lfrin'
- call FB_getFldPtr(is_local%wrap%FBfrac(complnd), 'lfrin', lfrin, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(complnd), 'lfrac', lfrac, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- lfrac(:) = lfrin(:)
- endif
-
- endif
-
!---------------------------------------
! Set 'rfrac' and 'lfrac' for FBFrac(comprof)
!---------------------------------------
@@ -495,31 +447,41 @@ subroutine med_fraction_init(gcomp, rc)
if (is_local%wrap%comp_present(comprof)) then
! Set 'rfrac' in FBFrac(comprof)
- if ( FB_FldChk(is_local%wrap%FBfrac(comprof) , 'rfrac', rc=rc) .and. &
- FB_FldChk(is_local%wrap%FBImp(comprof, comprof), 'frac' , rc=rc)) then
- call FB_getFldPtr(is_local%wrap%FBfrac(comprof) , 'rfrac', rfrac, rc=rc)
- call FB_getFldPtr(is_local%wrap%FBImp(comprof,comprof), 'frac' , frac, rc=rc)
+ if ( FB_FldChk(is_local%wrap%FBfrac(comprof) , 'rfrac', rc=rc) .and. &
+ FB_FldChk(is_local%wrap%FBImp(comprof,comprof), 'frac' , rc=rc)) then
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), 'frac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=frac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(comprof), 'rfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=rfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
rfrac(:) = frac(:)
else
! Set 'rfrac' in FBfrac(comprof) to 1.
- call FB_getFldPtr(is_local%wrap%FBfrac(comprof), 'rfrac', rfrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(comprof), 'rfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=rfrac, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
rfrac(:) = 1.0_R8
endif
! Set 'lfrac' in FBFrac(comprof)
if (is_local%wrap%comp_present(complnd)) then
- if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,comprof,:),mapconsf, rc=rc)) then
- call med_map_Fractions_init( gcomp, complnd, comprof, &
+ maptype = mapconsd
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,comprof,:),maptype, rc=rc)) then
+ call med_map_routehandles_init( complnd, comprof, &
FBSrc=is_local%wrap%FBImp(complnd,complnd), &
FBDst=is_local%wrap%FBImp(complnd,comprof), &
- RouteHandle=is_local%wrap%RH(complnd,comprof,mapconsf), rc=rc)
+ mapindex=maptype, RouteHandle=is_local%wrap%RH, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(complnd), 'lfrac', &
- is_local%wrap%FBfrac(comprof), 'lfrac', &
- is_local%wrap%RH(complnd,comprof,:),mapconsf, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(complnd), 'lfrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(comprof), 'lfrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(complnd,comprof,:), maptype, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
endif
@@ -532,29 +494,40 @@ subroutine med_fraction_init(gcomp, rc)
! Set 'gfrac' in FBFrac(compglc)
if ( FB_FldChk(is_local%wrap%FBfrac(compglc) , 'gfrac', rc=rc) .and. &
FB_FldChk(is_local%wrap%FBImp(compglc, compglc), 'frac' , rc=rc)) then
- call FB_getFldPtr(is_local%wrap%FBfrac(compglc) , 'gfrac', gfrac, rc=rc)
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), 'frac' , frac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), 'frac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=frac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compglc), 'gfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=gfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
gfrac(:) = frac(:)
else
! Set 'gfrac' in FBfrac(compglc) to 1.
- call FB_getFldPtr(is_local%wrap%FBfrac(compglc), 'gfrac', gfrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compglc), 'gfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=gfrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (ChkErr(rc,__LINE__,u_FILE_u)) return
gfrac(:) = 1.0_R8
endif
! Set 'lfrac' in FBFrac(compglc)
if ( is_local%wrap%comp_present(complnd) .and. is_local%wrap%med_coupling_active(complnd,compglc)) then
- if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,compglc,:),mapconsf, rc=rc)) then
- call med_map_Fractions_init( gcomp, complnd, compglc, &
+ maptype = mapconsd
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,compglc,:),maptype, rc=rc)) then
+ call med_map_routehandles_init( complnd, compglc, &
FBSrc=is_local%wrap%FBImp(complnd,complnd), &
FBDst=is_local%wrap%FBImp(complnd,compglc), &
- RouteHandle=is_local%wrap%RH(complnd,compglc,mapconsf), rc=rc)
+ mapindex=maptype, RouteHandle=is_local%wrap%RH, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(complnd), 'lfrac', &
- is_local%wrap%FBfrac(compglc), 'lfrac', &
- is_local%wrap%RH(complnd,compglc,:),mapconsf, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(complnd), 'lfrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compglc), 'lfrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(complnd,compglc,:), maptype, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
endif
@@ -565,11 +538,48 @@ subroutine med_fraction_init(gcomp, rc)
if (is_local%wrap%comp_present(compwav)) then
! Set 'wfrac' in FBfrac(compwav) to 1.
- call FB_getFldPtr(is_local%wrap%FBfrac(compwav), 'wfrac', wfrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compwav), 'wfrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=wfrac, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
wfrac(:) = 1.0_R8
endif
+ !---------------------------------------
+ ! Create route handles ocn<->ice if not created
+ !---------------------------------------
+
+ if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compocn)) then
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(compice,compocn,:),mapfcopy, rc=rc)) then
+ if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compice,compocn))) then
+ call FB_init(is_local%wrap%FBImp(compice,compocn), is_local%wrap%flds_scalar_name, &
+ STgeom=is_local%wrap%NStateImp(compocn), &
+ STflds=is_local%wrap%NStateImp(compice), &
+ name='FBImp'//trim(compname(compice))//'_'//trim(compname(compocn)), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ call med_map_routehandles_init(compice, compocn, &
+ FBSrc=is_local%wrap%FBImp(compice,compice), &
+ FBDst=is_local%wrap%FBImp(compice,compocn), &
+ mapindex=mapfcopy, RouteHandle=is_local%wrap%RH, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ if (.not. med_map_RH_is_created(is_local%wrap%RH(compocn,compice,:),mapfcopy, rc=rc)) then
+ if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compocn,compice))) then
+ call FB_init(is_local%wrap%FBImp(compocn,compice), is_local%wrap%flds_scalar_name, &
+ STgeom=is_local%wrap%NStateImp(compice), &
+ STflds=is_local%wrap%NStateImp(compocn), &
+ name='FBImp'//trim(compname(compocn))//'_'//trim(compname(compice)), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ call med_map_routehandles_init( compocn, compice, &
+ FBSrc=is_local%wrap%FBImp(compocn,compocn), &
+ FBDst=is_local%wrap%FBImp(compocn,compice), &
+ mapindex=mapfcopy, RouteHandle=is_local%wrap%RH, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ end if
+
!---------------------------------------
! Diagnostic output
!---------------------------------------
@@ -592,21 +602,20 @@ subroutine med_fraction_init(gcomp, rc)
end subroutine med_fraction_init
- !-----------------------------------------------------------------------------
-
+ !================================================================================================
subroutine med_fraction_set(gcomp, rc)
! Update time varying fractions
use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
- use ESMF , only : ESMF_FieldBundleIsCreated
+ use ESMF , only : ESMF_Field, ESMF_FieldGet
+ use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldBundleIsCreated
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only : ESMF_REGION_TOTAL, ESMF_REGION_SELECT
use esmFlds , only : compatm, compocn, compice, compname
- use esmFlds , only : mapconsf, mapnstod, mapfcopy, mapnstod_consf
+ use esmFlds , only : mapfcopy, mapconsd, mapnstod_consd
use esmFlds , only : coupling_mode
use med_internalstate_mod , only : InternalState
- use med_map_mod , only : med_map_Fractions_init, med_map_RH_is_created
+ use med_map_mod , only : med_map_RH_is_created
use perf_mod , only : t_startf, t_stopf
! input/output variables
@@ -615,21 +624,26 @@ subroutine med_fraction_set(gcomp, rc)
! local variables
type(InternalState) :: is_local
- real(r8), pointer :: lfrac(:)
- real(r8), pointer :: ifrac(:)
- real(r8), pointer :: ofrac(:)
- real(r8), pointer :: Si_ifrac(:)
- real(r8), pointer :: Si_imask(:)
+ real(r8), pointer :: lfrac(:) => null()
+ real(r8), pointer :: ifrac(:) => null()
+ real(r8), pointer :: ofrac(:) => null()
+ real(r8), pointer :: Si_ifrac(:) => null()
+ real(r8), pointer :: Si_imask(:) => null()
+ type(ESMF_Field) :: lfield
+ type(ESMF_Field) :: field_src
+ type(ESMF_Field) :: field_dst
integer :: n
integer :: maptype
- character(len=*),parameter :: subname='(med_fraction_set)'
+ character(len=*),parameter :: subname=' (med_fraction_set)'
!---------------------------------------
+
+ rc = ESMF_SUCCESS
+
call t_startf('MED:'//subname)
if (dbug_flag > 20) then
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
end if
- rc = ESMF_SUCCESS
! Get the internal state from Component.
nullify(is_local%wrap)
@@ -640,37 +654,6 @@ subroutine med_fraction_set(gcomp, rc)
! Update FBFrac(compice), FBFrac(compocn) and FBFrac(compatm) field bundles
!---------------------------------------
- if (is_local%wrap%comp_present(compice) .and. is_local%wrap%comp_present(compocn)) then
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compice,compocn,:),mapfcopy, rc=rc)) then
- if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compice,compocn))) then
- call FB_init(is_local%wrap%FBImp(compice,compocn), is_local%wrap%flds_scalar_name, &
- STgeom=is_local%wrap%NStateImp(compocn), &
- STflds=is_local%wrap%NStateImp(compice), &
- name='FBImp'//trim(compname(compice))//'_'//trim(compname(compocn)), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- call med_map_Fractions_init( gcomp, compice, compocn, &
- FBSrc=is_local%wrap%FBImp(compice,compice), &
- FBDst=is_local%wrap%FBImp(compice,compocn), &
- RouteHandle=is_local%wrap%RH(compice,compocn,mapfcopy), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compocn,compice,:),mapfcopy, rc=rc)) then
- if (.not. ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compocn,compice))) then
- call FB_init(is_local%wrap%FBImp(compocn,compice), is_local%wrap%flds_scalar_name, &
- STgeom=is_local%wrap%NStateImp(compice), &
- STflds=is_local%wrap%NStateImp(compocn), &
- name='FBImp'//trim(compname(compocn))//'_'//trim(compname(compice)), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- call med_map_Fractions_init( gcomp, compocn, compice, &
- FBSrc=is_local%wrap%FBImp(compocn,compocn), &
- FBDst=is_local%wrap%FBImp(compocn,compice), &
- RouteHandle=is_local%wrap%RH(compocn,compice,mapfcopy), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- end if
-
if (is_local%wrap%comp_present(compice)) then
! -------------------------------------------
@@ -680,14 +663,23 @@ subroutine med_fraction_set(gcomp, rc)
! Si_imask is the ice domain mask which is constant over time
! Si_ifrac is the time evolving ice fraction on the ice grid
- call FB_getFldPtr(is_local%wrap%FBImp(compice,compice) , 'Si_ifrac', Si_ifrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compice,compice), fieldName='Si_ifrac', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=Si_ifrac, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compice,compice), fieldName='Si_imask', field=lfield, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=Si_imask, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compice), fieldName='ifrac', field=lfield, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBImp(compice,compice) , 'Si_imask' , Si_imask, rc=rc)
+ call ESMF_FieldGet(lfield, farrayPtr=ifrac, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ifrac', ifrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compice), fieldName='ofrac', field=lfield, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compice), 'ofrac', ofrac, rc=rc)
+ call ESMF_FieldGet(lfield, farrayPtr=ofrac, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! set ifrac = Si_ifrac * Si_imask
@@ -702,21 +694,25 @@ subroutine med_fraction_set(gcomp, rc)
! The following is just a redistribution from FBFrac(compice)
+ call t_startf('MED:'//trim(subname)//' fbfrac(compocn)')
if (is_local%wrap%comp_present(compocn)) then
! Map 'ifrac' from FBfrac(compice) to FBfrac(compocn)
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compice), 'ifrac', &
- is_local%wrap%FBfrac(compocn), 'ifrac', &
- is_local%wrap%RH(compice,compocn,:),mapfcopy, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compice), 'ifrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compocn), 'ifrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compice,compocn,:), mapfcopy, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! Map 'ofrac' from FBfrac(compice) to FBfrac(compocn)
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compice), 'ofrac', &
- is_local%wrap%FBfrac(compocn), 'ofrac', &
- is_local%wrap%RH(compice,compocn,:),mapfcopy, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compice), 'ofrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compocn), 'ofrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compice,compocn,:), mapfcopy, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
+ call t_stopf('MED:'//trim(subname)//' fbfrac(compocn)')
! -------------------------------------------
! Set FBfrac(compatm)
@@ -724,36 +720,41 @@ subroutine med_fraction_set(gcomp, rc)
if (is_local%wrap%comp_present(compatm)) then
+ call t_startf('MED:'//trim(subname)//' fbfrac(compatm)')
+ ! Determine maptype
if (trim(coupling_mode) == 'nems_orig' ) then
- maptype = mapnstod_consf
+ maptype = mapnstod_consd
else
if (med_map_RH_is_created(is_local%wrap%RH(compice,compatm,:),mapfcopy, rc=rc)) then
maptype = mapfcopy
else
- maptype = mapconsf
+ maptype = mapconsd
end if
end if
! Map 'ifrac' from FBfrac(compice) to FBfrac(compatm)
if (is_local%wrap%med_coupling_active(compice,compatm)) then
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compice), 'ifrac', &
- is_local%wrap%FBfrac(compatm), 'ifrac', &
- is_local%wrap%RH(compice,compatm,:),maptype, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compice), 'ifrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'ifrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compice,compatm,:), maptype, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
! Map 'ofrac' from FBfrac(compice) to FBfrac(compatm)
if (is_local%wrap%med_coupling_active(compocn,compatm)) then
- call FB_FieldRegrid(&
- is_local%wrap%FBfrac(compice), 'ofrac', &
- is_local%wrap%FBfrac(compatm), 'ofrac', &
- is_local%wrap%RH(compice,compatm,:),maptype, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compice), 'ofrac', field=field_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBfrac(compatm), 'ofrac', field=field_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field(field_src, field_dst, is_local%wrap%RH(compice,compatm,:), maptype, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- end if
+ end if ! end of if present compatm
+ call t_stopf('MED:'//trim(subname)//' fbfrac(compatm)')
- end if ! end of if present compice
+ end if ! end of if present compatm
!---------------------------------------
! Diagnostic output
@@ -762,8 +763,7 @@ subroutine med_fraction_set(gcomp, rc)
if (dbug_flag > 1) then
do n = 1,ncomps
if (ESMF_FieldBundleIsCreated(is_local%wrap%FBfrac(n),rc=rc)) then
- call FB_diagnose(is_local%wrap%FBfrac(n), &
- trim(subname) // trim(compname(n))//' frac', rc=rc)
+ call FB_diagnose(is_local%wrap%FBfrac(n), trim(subname) // trim(compname(n))//' frac', rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
enddo
diff --git a/mediator/med_internalstate_mod.F90 b/mediator/med_internalstate_mod.F90
index 8deadfa1a..149d10374 100644
--- a/mediator/med_internalstate_mod.F90
+++ b/mediator/med_internalstate_mod.F90
@@ -4,7 +4,7 @@ module med_internalstate_mod
! Mediator Internal State Datatype.
!-----------------------------------------------------------------------------
- use ESMF , only : ESMF_RouteHandle, ESMF_FieldBundle, ESMF_State
+ use ESMF , only : ESMF_RouteHandle, ESMF_FieldBundle, ESMF_State, ESMF_Field
use ESMF , only : ESMF_VM
use esmFlds , only : ncomps, nmappers
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
@@ -39,9 +39,24 @@ module med_internalstate_mod
.false., .false., .true. , .false., .false., .false., .false., .false., & ! rof
.false., .true. , .false., .true. , .true. , .false., .false., .false., & ! wav
.false., .false., .true. , .false., .false., .false., .false., .false. ], & ! glc
- shape(med_coupling_allowed))
+ shape(med_coupling_allowed))
! med atm lnd ocn ice rof wav glc
+ type, public :: mesh_info_type
+ real(r8), pointer :: areas(:) => null()
+ real(r8), pointer :: lats(:) => null()
+ real(r8), pointer :: lons(:) => null()
+ end type mesh_info_type
+
+ type, public :: packed_data_type
+ integer, allocatable :: fldindex(:) ! size of number of packed fields
+ character(len=CS) :: mapnorm ! normalization for packed field
+ type(ESMF_Field) :: field_src ! packed sourced field
+ type(ESMF_Field) :: field_dst ! packed destination field
+ type(ESMF_Field) :: field_fracsrc
+ type(ESMF_Field) :: field_fracdst
+ end type packed_data_type
+
! private internal state to keep instance data
type InternalStateStruct
@@ -57,18 +72,18 @@ module med_internalstate_mod
logical :: med_coupling_active(ncomps,ncomps) ! computes the active coupling
! Mediator vm
- type(ESMF_VM) :: vm
+ type(ESMF_VM) :: vm
! Global nx,ny dimensions of input arrays (needed for mediator history output)
- integer :: nx(ncomps), ny(ncomps)
+ integer :: nx(ncomps), ny(ncomps)
! Import/Export Scalars
- character(len=CL) :: flds_scalar_name = ''
- integer :: flds_scalar_num = 0
- integer :: flds_scalar_index_nx = 0
- integer :: flds_scalar_index_ny = 0
- integer :: flds_scalar_index_nextsw_cday = 0
- integer :: flds_scalar_index_precip_factor = 0
+ character(len=CL) :: flds_scalar_name = ''
+ integer :: flds_scalar_num = 0
+ integer :: flds_scalar_index_nx = 0
+ integer :: flds_scalar_index_ny = 0
+ integer :: flds_scalar_index_nextsw_cday = 0
+ integer :: flds_scalar_index_precip_factor = 0
! Import/export States and field bundles (the field bundles have the scalar fields removed)
type(ESMF_State) :: NStateImp(ncomps) ! Import data from various component, on their grid
@@ -79,12 +94,15 @@ module med_internalstate_mod
! Mediator field bundles
type(ESMF_FieldBundle) :: FBMed_ocnalb_o ! Ocn albedo on ocn grid
type(ESMF_FieldBundle) :: FBMed_ocnalb_a ! Ocn albedo on atm grid
+ type(packed_data_type) :: packed_data_ocnalb_o2a(nmappers) ! packed data for mapping ocn->atm
type(ESMF_FieldBundle) :: FBMed_aoflux_o ! Ocn/Atm flux fields on ocn grid
type(ESMF_FieldBundle) :: FBMed_aoflux_a ! Ocn/Atm flux fields on atm grid
+ type(packed_data_type) :: packed_data_aoflux_o2a(nmappers) ! packed data for mapping ocn->atm
! Mapping
- type(ESMF_RouteHandle) :: RH(ncomps,ncomps,nmappers) ! Routehandles for pairs of components and different mappers
- type(ESMF_FieldBundle) :: FBNormOne(ncomps,ncomps,nmappers) ! Unity static normalization
+ type(ESMF_RouteHandle) :: RH(ncomps,ncomps,nmappers) ! Routehandles for pairs of components and different mappers
+ type(ESMF_Field) :: field_NormOne(ncomps,ncomps,nmappers) ! Unity static normalization
+ type(packed_data_type) :: packed_data(ncomps,ncomps,nmappers) ! Packed data structure needed to efficiently map field bundles
! Fractions
type(ESMF_FieldBundle) :: FBfrac(ncomps) ! Fraction data for various components, on their grid
@@ -98,6 +116,9 @@ module med_internalstate_mod
type(ESMF_FieldBundle) :: FBImpAccum(ncomps,ncomps) ! Accumulator for various components import
integer :: FBImpAccumCnt(ncomps) ! Accumulator counter for each FBImpAccum
+ ! Component Mesh info
+ type(mesh_info_type) :: mesh_info(ncomps)
+
end type InternalStateStruct
type, public :: InternalState
diff --git a/mediator/med_io_mod.F90 b/mediator/med_io_mod.F90
index 0a4fa7753..770229263 100644
--- a/mediator/med_io_mod.F90
+++ b/mediator/med_io_mod.F90
@@ -1,5 +1,4 @@
module med_io_mod
-
!------------------------------------------
! Create mediator history files
!------------------------------------------
@@ -13,12 +12,9 @@ module med_io_mod
use NUOPC , only : NUOPC_FieldDictionaryGetEntry
use NUOPC , only : NUOPC_FieldDictionaryHasEntry
use pio , only : file_desc_t, iosystem_desc_t
- use med_internalstate_mod , only : logunit, med_id
- use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
- use med_methods_mod , only : FB_getFieldN => med_methods_FB_getFieldN
- use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr
- use med_methods_mod , only : FB_getNameN => med_methods_FB_getNameN
- use med_utils_mod , only : chkerr => med_utils_ChkErr
+ use med_internalstate_mod , only : logunit
+ use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
+ use med_utils_mod , only : chkerr => med_utils_ChkErr
implicit none
private
@@ -125,7 +121,9 @@ subroutine med_io_init()
! initialize pio
!---------------
- use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat
+ use shr_pio_mod , only : shr_pio_getiosys, shr_pio_getiotype, shr_pio_getioformat
+ use med_internalstate_mod , only : med_id
+
#ifdef INTERNAL_PIO_INIT
! if CMEPS is the only component using PIO, then it needs to initialize PIO
use shr_pio_mod , only : shr_pio_init1, shr_pio_init2
@@ -435,11 +433,10 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
integer :: ndims, nelements
integer ,target :: dimid2(2)
integer ,target :: dimid3(3)
- integer ,pointer :: dimid(:)
+ integer ,pointer :: dimid(:) => null()
type(var_desc_t) :: varid
type(io_desc_t) :: iodesc
integer(kind=Pio_Offset_Kind) :: frame
- character(CL) :: itemc ! string converted to char
character(CL) :: name1 ! var name
character(CL) :: cunit ! var units
character(CL) :: lname ! long name
@@ -449,13 +446,13 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
logical :: luse_float
integer :: lnx,lny
real(r8) :: lfillvalue
- integer, pointer :: minIndexPTile(:,:)
- integer, pointer :: maxIndexPTile(:,:)
+ integer, pointer :: minIndexPTile(:,:) => null()
+ integer, pointer :: maxIndexPTile(:,:) => null()
integer :: dimCount, tileCount
- integer, pointer :: Dof(:)
+ integer, pointer :: Dof(:) => null()
integer :: lfile_ind
- real(r8), pointer :: fldptr1(:)
- real(r8), pointer :: fldptr2(:,:)
+ real(r8), pointer :: fldptr1(:) => null()
+ real(r8), pointer :: fldptr2(:,:) => null()
real(r8), allocatable :: ownedElemCoords(:), ownedElemCoords_x(:), ownedElemCoords_y(:)
character(len=number_strlen) :: cnumber
character(CL) :: tmpstr
@@ -464,6 +461,8 @@ subroutine med_io_write_FB(filename, iam, 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
+ character(CL) , pointer :: fieldnamelist(:) => null()
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
character(*),parameter :: subName = '(med_io_write_FB) '
!-------------------------------------------------------------------------------
@@ -506,11 +505,16 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
luse_float = .false.
if (present(use_float)) luse_float = use_float
-
lfile_ind = 0
if (present(file_ind)) lfile_ind=file_ind
call ESMF_FieldBundleGet(FB, fieldCount=nf, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldnamelist(nf))
+ allocate(fieldlist(nf))
+ call ESMF_FieldBundleGet(FB, fieldnamelist=fieldnamelist, fieldlist=fieldlist, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
write(tmpstr,*) subname//' field count = '//trim(lpre),nf
call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO)
if (nf < 1) then
@@ -522,18 +526,12 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
return
endif
- call FB_getFieldN(FB, 1, field, rc=rc)
+ call ESMF_FieldGet(fieldlist(1), mesh=mesh, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_FieldGet(field, mesh=mesh, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
call ESMF_MeshGet(mesh, elementDistgrid=distgrid, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
call ESMF_MeshGet(mesh, spatialDim=ndims, numOwnedElements=nelements, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
write(tmpstr,*) subname, 'ndims, nelements = ', ndims, nelements
call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO)
@@ -541,17 +539,14 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
allocate(ownedElemCoords(ndims*nelements))
allocate(ownedElemCoords_x(ndims*nelements/2))
allocate(ownedElemCoords_y(ndims*nelements/2))
-
call ESMF_MeshGet(mesh, ownedElemCoords=ownedElemCoords, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
ownedElemCoords_x = ownedElemCoords(1::2)
ownedElemCoords_y = ownedElemCoords(2::2)
end if
call ESMF_DistGridGet(distgrid, dimCount=dimCount, tileCount=tileCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
allocate(minIndexPTile(dimCount, tileCount), maxIndexPTile(dimCount, tileCount))
call ESMF_DistGridGet(distgrid, minIndexPTile=minIndexPTile, maxIndexPTile=maxIndexPTile, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -601,72 +596,64 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
write(tmpstr,*) subname,' dimid = ',dimid
call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO)
+ ! TODO (mvertens, 2019-03-13): below is a temporary mod to NOT write hgt
do k = 1,nf
- call FB_getNameN(FB, k, itemc, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (trim(fieldnamelist(k)) == "hgt") then
+ CYCLE
+ end if
- ! Determine rank of field with name itemc
- call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, rank=rank, rc=rc)
+ call ESMF_FieldGet(fieldlist(k), ungriddedUBound=ungriddedUbound, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- ! TODO (mvertens, 2019-03-13): this is a temporary mod to NOT write hgt
- if (trim(itemc) /= "hgt") then
- if (rank == 2) then
- call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- write(cnumber,'(i0)') ungriddedUbound(1)
- call ESMF_LogWrite(trim(subname)//':'//'field '//trim(itemc)// &
- ' has an griddedUBound of '//trim(cnumber), ESMF_LOGMSG_INFO)
-
- ! Create a new output variable for each element of the undistributed dimension
- do n = 1,ungriddedUBound(1)
- if (trim(itemc) /= "hgt") then
- write(cnumber,'(i0)') n
- name1 = trim(lpre)//'_'//trim(itemc)//trim(cnumber)
- call ESMF_LogWrite(trim(subname)//': defining '//trim(name1), ESMF_LOGMSG_INFO)
- if (luse_float) then
- rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_REAL, dimid, varid)
- rcode = pio_put_att(io_file(lfile_ind), varid,"_FillValue",real(lfillvalue,r4))
- else
- rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_DOUBLE, dimid, varid)
- rcode = pio_put_att(io_file(lfile_ind),varid,"_FillValue",lfillvalue)
- end if
- if (NUOPC_FieldDictionaryHasEntry(trim(itemc))) then
- call NUOPC_FieldDictionaryGetEntry(itemc, canonicalUnits=cunit, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- rcode = pio_put_att(io_file(lfile_ind), varid, "units" , trim(cunit))
- end if
- rcode = pio_put_att(io_file(lfile_ind), varid, "standard_name", trim(name1))
- if (present(tavg)) then
- if (tavg) then
- rcode = pio_put_att(io_file(lfile_ind), varid, "cell_methods", "time: mean")
- endif
- endif
+ if (ungriddedUbound(1) > 0) then
+ ! Create a new output variable for each element of the undistributed dimension
+ write(cnumber,'(i0)') ungriddedUbound(1)
+ call ESMF_LogWrite(trim(subname)//':'//'field '//trim(fieldnamelist(k))// &
+ ' has an griddedUBound of '//trim(cnumber), ESMF_LOGMSG_INFO)
+ do n = 1,ungriddedUBound(1)
+ if (trim(fieldnamelist(k)) /= "hgt") then
+ write(cnumber,'(i0)') n
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))//trim(cnumber)
+ call ESMF_LogWrite(trim(subname)//': defining '//trim(name1), ESMF_LOGMSG_INFO)
+ if (luse_float) then
+ rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_REAL, dimid, varid)
+ rcode = pio_put_att(io_file(lfile_ind), varid,"_FillValue",real(lfillvalue,r4))
+ else
+ rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_DOUBLE, dimid, varid)
+ rcode = pio_put_att(io_file(lfile_ind),varid,"_FillValue",lfillvalue)
end if
- end do
- else
- name1 = trim(lpre)//'_'//trim(itemc)
- call ESMF_LogWrite(trim(subname)//':'//trim(itemc)//':'//trim(name1),ESMF_LOGMSG_INFO)
- if (luse_float) then
- rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_REAL, dimid, varid)
- rcode = pio_put_att(io_file(lfile_ind), varid, "_FillValue", real(lfillvalue, r4))
- else
- rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_DOUBLE, dimid, varid)
- rcode = pio_put_att(io_file(lfile_ind), varid, "_FillValue", lfillvalue)
- end if
- if (NUOPC_FieldDictionaryHasEntry(trim(itemc))) then
- call NUOPC_FieldDictionaryGetEntry(itemc, canonicalUnits=cunit, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- rcode = pio_put_att(io_file(lfile_ind), varid, "units", trim(cunit))
- end if
- rcode = pio_put_att(io_file(lfile_ind), varid, "standard_name", trim(name1))
- if (present(tavg)) then
- if (tavg) then
- rcode = pio_put_att(io_file(lfile_ind), varid, "cell_methods", "time: mean")
+ if (NUOPC_FieldDictionaryHasEntry(trim(fieldnamelist(k)))) then
+ call NUOPC_FieldDictionaryGetEntry(fieldnamelist(k), canonicalUnits=cunit, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ rcode = pio_put_att(io_file(lfile_ind), varid, "units" , trim(cunit))
+ end if
+ rcode = pio_put_att(io_file(lfile_ind), varid, "standard_name", trim(name1))
+ if (present(tavg)) then
+ if (tavg) then
+ rcode = pio_put_att(io_file(lfile_ind), varid, "cell_methods", "time: mean")
+ endif
endif
end if
+ end do
+ else
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))
+ call ESMF_LogWrite(trim(subname)//':'//trim(fieldnamelist(k))//':'//trim(name1),ESMF_LOGMSG_INFO)
+ if (luse_float) then
+ rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_REAL, dimid, varid)
+ rcode = pio_put_att(io_file(lfile_ind), varid, "_FillValue", real(lfillvalue, r4))
+ else
+ rcode = pio_def_var(io_file(lfile_ind), trim(name1), PIO_DOUBLE, dimid, varid)
+ rcode = pio_put_att(io_file(lfile_ind), varid, "_FillValue", lfillvalue)
+ end if
+ if (NUOPC_FieldDictionaryHasEntry(trim(fieldnamelist(k)))) then
+ call NUOPC_FieldDictionaryGetEntry(fieldnamelist(k), canonicalUnits=cunit, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ rcode = pio_put_att(io_file(lfile_ind), varid, "units", trim(cunit))
+ end if
+ rcode = pio_put_att(io_file(lfile_ind), varid, "standard_name", trim(name1))
+ if (present(tavg)) then
+ if (tavg) then
+ rcode = pio_put_att(io_file(lfile_ind), varid, "cell_methods", "time: mean")
+ endif
end if
end if
end do
@@ -698,7 +685,6 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
end if
if (lwdata) then
-
! use distgrid extracted from field 1 above
call ESMF_DistGridGet(distgrid, localDE=0, elementCount=ns, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -708,51 +694,36 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
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)
-
deallocate(dof)
+ ! TODO (mvertens, 2019-03-13): below is a temporary mod to NOT write hgt
do k = 1,nf
- call FB_getNameN(FB, k, itemc, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_getFldPtr(FB, itemc, &
- fldptr1=fldptr1, fldptr2=fldptr2, rank=rank, rc=rc)
+ if (trim(fieldnamelist(k)) == "hgt") then
+ CYCLE
+ end if
+ call ESMF_FieldGet(fieldlist(k), ungriddedUBound=ungriddedUbound, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- ! TODO (mvertens, 2019-03-13): this is a temporary mod to NOT write hgt
- if (trim(itemc) /= "hgt") then
- if (rank == 2) then
-
- ! Determine the size of the ungridded dimension and the index where the undistributed dimension is located
- call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, gridToFieldMap=gridToFieldMap, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- ! Output for each ungriddedUbound index
- do n = 1,ungriddedUBound(1)
- write(cnumber,'(i0)') n
- name1 = trim(lpre)//'_'//trim(itemc)//trim(cnumber)
- rcode = pio_inq_varid(io_file(lfile_ind), trim(name1), varid)
- call pio_setframe(io_file(lfile_ind),varid,frame)
-
- if (gridToFieldMap(1) == 1) then
- call pio_write_darray(io_file(lfile_ind), varid, iodesc, fldptr2(:,n), rcode, fillval=lfillvalue)
- else if (gridToFieldMap(1) == 2) then
- call pio_write_darray(io_file(lfile_ind), varid, iodesc, fldptr2(n,:), rcode, fillval=lfillvalue)
- end if
- end do
- else if (rank == 1) then
- name1 = trim(lpre)//'_'//trim(itemc)
+ if (ungriddedUbound(1) > 0) then
+ ! Output for each ungriddedUbound index
+ call ESMF_FieldGet(fieldlist(k), farrayPtr=fldptr2, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,ungriddedUBound(1)
+ write(cnumber,'(i0)') n
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))//trim(cnumber)
rcode = pio_inq_varid(io_file(lfile_ind), trim(name1), varid)
call pio_setframe(io_file(lfile_ind),varid,frame)
- call pio_write_darray(io_file(lfile_ind), varid, iodesc, fldptr1, rcode, fillval=lfillvalue)
- end if ! end if rank is 2 or 1
-
- end if ! end if not "hgt"
- end do ! end loop over fields in FB
+ call pio_write_darray(io_file(lfile_ind), varid, iodesc, fldptr2(n,:), rcode, fillval=lfillvalue)
+ end do
+ else
+ call ESMF_FieldGet(fieldlist(k), farrayPtr=fldptr1, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))
+ rcode = pio_inq_varid(io_file(lfile_ind), trim(name1), varid)
+ call pio_setframe(io_file(lfile_ind),varid,frame)
+ call pio_write_darray(io_file(lfile_ind), varid, iodesc, fldptr1, rcode, fillval=lfillvalue)
+ end if ! end of if over ungriddedUbound
+ end do ! end loop over fields
! Fill coordinate variables
name1 = trim(lpre)//'_lon'
@@ -769,6 +740,9 @@ subroutine med_io_write_FB(filename, iam, FB, whead, wdata, nx, ny, nt, &
call pio_freedecomp(io_file(lfile_ind), iodesc)
endif
+ deallocate(fieldlist)
+ deallocate(fieldnamelist)
+
if (dbug_flag > 5) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
endif
@@ -1227,7 +1201,7 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc)
use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_FAILURE
use ESMF , only : ESMF_FieldBundleIsCreated, ESMF_FieldBundleGet
use ESMF , only : ESMF_FieldGet, ESMF_MeshGet, ESMF_DistGridGet
- use pio , only : file_desc_T, var_desc_t, io_desc_t, pio_nowrite, pio_openfile
+ use pio , only : file_desc_t, var_desc_t, io_desc_t, pio_nowrite, pio_openfile
use pio , only : pio_noerr, PIO_BCAST_ERROR, PIO_INTERNAL_ERROR
use pio , only : pio_inq_varid
use pio , only : pio_double, pio_get_att, pio_seterrorhandling, pio_freedecomp, pio_closefile
@@ -1250,24 +1224,28 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc)
type(file_desc_t) :: pioid
type(var_desc_t) :: varid
type(io_desc_t) :: iodesc
- character(CL) :: itemc ! string converted to char
character(CL) :: name1 ! var name
character(CL) :: lpre ! local prefix
real(r8) :: lfillvalue
integer :: tmp(1)
integer :: rank, lsize
- real(r8), pointer :: fldptr1(:), fldptr1_tmp(:)
- real(r8), pointer :: fldptr2(:,:)
+ real(r8), pointer :: fldptr1(:) => null()
+ real(r8), pointer :: fldptr1_tmp(:) => null()
+ real(r8), pointer :: fldptr2(:,:) => null()
character(CL) :: tmpstr
character(len=16) :: cnumber
integer(kind=Pio_Offset_Kind) :: lframe
- integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fieldds
- integer :: gridToFieldMap(1) ! currently the size must equal 1 for rank 2 fieldds
+ integer :: ungriddedUBound(1)
+ character(CL) , pointer :: fieldnamelist(:) => null()
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
character(*),parameter :: subName = '(med_io_read_FB) '
!-------------------------------------------------------------------------------
rc = ESMF_Success
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ if (dbug_flag > 5) then
+ call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ end if
lpre = ' '
if (present(pre)) then
@@ -1278,31 +1256,34 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc)
else
lframe = 1
endif
+
if (.not. ESMF_FieldBundleIsCreated(FB,rc=rc)) then
call ESMF_LogWrite(trim(subname)//" FB "//trim(lpre)//" not created", ESMF_LOGMSG_INFO)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
+ call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
return
endif
call ESMF_FieldBundleGet(FB, fieldCount=nf, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- write(tmpstr,*) subname//' field count = '//trim(lpre),nf
- call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
if (nf < 1) then
call ESMF_LogWrite(trim(subname)//" FB "//trim(lpre)//" empty", ESMF_LOGMSG_INFO)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
+ call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
return
endif
+ allocate(fieldnamelist(nf))
+ allocate(fieldlist(nf))
+ call ESMF_FieldBundleGet(FB, fieldnamelist=fieldnamelist, fieldlist=fieldlist, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ write(tmpstr,*) subname//' field count = '//trim(lpre),nf
+ call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ ! Check if file exists
if (med_io_file_exists(vm, iam, trim(filename))) then
rcode = pio_openfile(io_subsystem, pioid, pio_iotype, trim(filename),pio_nowrite)
call ESMF_LogWrite(trim(subname)//' open file '//trim(filename), ESMF_LOGMSG_INFO)
@@ -1317,57 +1298,35 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc)
call pio_seterrorhandling(pioid, PIO_BCAST_ERROR)
do k = 1,nf
- ! Get name of field
- call FB_getNameN(FB, k, itemc, rc=rc)
+ call ESMF_FieldGet(fieldlist(k), ungriddedUBound=ungriddedUbound, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Get iodesc for all fields based on iodesc of first field (assumes that all fields have
! the same iodesc)
if (k == 1) then
- call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, rank=rank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (rank == 2) then
- name1 = trim(lpre)//'_'//trim(itemc)//'1'
- else if (rank == 1) then
- name1 = trim(lpre)//'_'//trim(itemc)
+ if (ungriddedUbound(1) > 0) then
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))//'1'
+ else
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))
end if
call med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
-
- call ESMF_LogWrite(trim(subname)//' reading field '//trim(itemc), ESMF_LOGMSG_INFO)
+ call ESMF_LogWrite(trim(subname)//' reading field '//trim(fieldnamelist(k)), ESMF_LOGMSG_INFO)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Get pointer to field bundle field
- ! Field bundle might be 2d or 1d - but field on mediator history or restart file will always be 1d
- call FB_getFldPtr(FB, itemc, &
- fldptr1=fldptr1, fldptr2=fldptr2, rank=rank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (rank == 2) then
-
- ! Determine the size of the ungridded dimension and the
- ! index where the undistributed dimension is located
- call ESMF_FieldBundleGet(FB, itemc, field=lfield, rc=rc)
+ if (ungriddedUbound(1) > 0) then
+ ! Ungridded dimension is present in field
+ call ESMF_FieldGet(fieldlist(k), farrayPtr=fldptr2, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, gridToFieldMap=gridToFieldMap, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (gridToFieldMap(1) == 1) then
- lsize = size(fldptr2, dim=1)
- else if (gridToFieldMap(1) == 2) then
- lsize = size(fldptr2, dim=2)
- end if
+ lsize = size(fldptr2, dim=2)
allocate(fldptr1_tmp(lsize))
-
do n = 1,ungriddedUBound(1)
! Creat a name for the 1d field on the mediator history or restart file based on the
! ungridded dimension index of the field bundle 2d fiedl
write(cnumber,'(i0)') n
- name1 = trim(lpre)//'_'//trim(itemc)//trim(cnumber)
-
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))//trim(cnumber)
rcode = pio_inq_varid(pioid, trim(name1), varid)
if (rcode == pio_noerr) then
call ESMF_LogWrite(trim(subname)//' read field '//trim(name1), ESMF_LOGMSG_INFO)
@@ -1384,18 +1343,14 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc)
else
fldptr1_tmp = 0.0_r8
endif
- if (gridToFieldMap(1) == 1) then
- fldptr2(:,n) = fldptr1_tmp(:)
- else if (gridToFieldMap(1) == 2) then
- fldptr2(n,:) = fldptr1_tmp(:)
- end if
+ fldptr2(n,:) = fldptr1_tmp(:)
end do
-
deallocate(fldptr1_tmp)
-
- else if (rank == 1) then
- name1 = trim(lpre)//'_'//trim(itemc)
-
+ else
+ ! No ungridded dimensions
+ call ESMF_FieldGet(fieldlist(k), farrayPtr=fldptr1, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ name1 = trim(lpre)//'_'//trim(fieldnamelist(k))
rcode = pio_inq_varid(pioid, trim(name1), varid)
if (rcode == pio_noerr) then
call ESMF_LogWrite(trim(subname)//' read field '//trim(name1), ESMF_LOGMSG_INFO)
@@ -1410,13 +1365,12 @@ subroutine med_io_read_FB(filename, vm, iam, FB, pre, frame, rc)
if (fldptr1(n) == lfillvalue) fldptr1(n) = 0.0_r8
enddo
else
- fldptr1 = 0.0_r8
+ fldptr1(:) = 0.0_r8
endif
end if
enddo ! end of loop over fields
call pio_seterrorhandling(pioid,PIO_INTERNAL_ERROR)
-
call pio_freedecomp(pioid, iodesc)
call pio_closefile(pioid)
@@ -1452,16 +1406,17 @@ subroutine med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc)
integer :: rcode
integer :: ns,ng
integer :: n,ndims
- integer, pointer :: dimid(:)
+ integer, pointer :: dimid(:) => null()
type(var_desc_t) :: varid
integer :: lnx,lny
integer :: tmp(1)
- integer, pointer :: minIndexPTile(:,:)
- integer, pointer :: maxIndexPTile(:,:)
+ integer, pointer :: minIndexPTile(:,:) => null()
+ integer, pointer :: maxIndexPTile(:,:) => null()
integer :: dimCount, tileCount
- integer, pointer :: Dof(:)
+ integer, pointer :: Dof(:) => null()
character(CL) :: tmpstr
- integer :: rank
+ integer :: fieldcount
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
character(*),parameter :: subName = '(med_io_read_init_iodesc) '
!-------------------------------------------------------------------------------
@@ -1490,18 +1445,17 @@ subroutine med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc)
call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO)
ng = lnx * lny
- call FB_getFieldN(FB, 1, field, rc=rc)
+ call ESMF_FieldBundleGet(FB, fieldCount=fieldcount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_FieldGet(field, mesh=mesh, rc=rc)
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(FB, fieldlist=fieldlist, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=mesh, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
call ESMF_MeshGet(mesh, elementDistgrid=distgrid, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
call ESMF_DistGridGet(distgrid, dimCount=dimCount, tileCount=tileCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
allocate(minIndexPTile(dimCount, tileCount), maxIndexPTile(dimCount, tileCount))
call ESMF_DistGridGet(distgrid, minIndexPTile=minIndexPTile, &
maxIndexPTile=maxIndexPTile, rc=rc)
@@ -1524,11 +1478,11 @@ subroutine med_io_read_init_iodesc(FB, name1, pioid, iodesc, rc)
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)
deallocate(dof)
deallocate(minIndexPTile, maxIndexPTile)
+ deallocate(fieldlist)
end if ! end if rcode check
diff --git a/mediator/med_map_mod.F90 b/mediator/med_map_mod.F90
index e0aafb600..85e9a720d 100644
--- a/mediator/med_map_mod.F90
+++ b/mediator/med_map_mod.F90
@@ -1,49 +1,30 @@
module med_map_mod
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
- use shr_const_mod , only : shr_const_pi
use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE
use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_LOGMSG_INFO, ESMF_LogWrite
- use esmFlds , only : mapbilnr, mapconsf, mapconsd, mappatch, mapfcopy
- use esmFlds , only : mapunset, mapnames, nmappers
- use esmFlds , only : mapnstod, mapnstod_consd, mapnstod_consf
- use esmFlds , only : ncomps, compatm, compice, compocn, compname
- use esmFlds , only : mapfcopy, mapconsd, mapconsf, mapnstod
- use esmFlds , only : mapuv_with_cart3d
- use esmFlds , only : med_fldList_entry_type
- use esmFlds , only : fldListFr, fldListTo
- use esmFlds , only : coupling_mode
- use med_internalstate_mod , only : InternalState
- use med_constants_mod , only : ispval_mask => med_constants_ispval_mask
- use med_constants_mod , only : czero => med_constants_czero
- use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
- use med_utils_mod , only : chkerr => med_utils_ChkErr
- use med_utils_mod , only : memcheck => med_memcheck
- use med_methods_mod , only : FB_getFieldN => med_methods_FB_getFieldN
- use med_methods_mod , only : FB_init => med_methods_FB_Init
- use med_methods_mod , only : FB_reset => med_methods_FB_Reset
- use med_methods_mod , only : FB_Clean => med_methods_FB_Clean
- use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
- use med_methods_mod , only : FB_Field_diagnose => med_methods_FB_Field_diagnose
- use med_methods_mod , only : FB_FldChk => med_methods_FB_FldChk
- use med_methods_mod , only : FB_GetFieldByName => med_methods_FB_GetFieldByName
- use med_methods_mod , only : Field_diagnose => med_methods_Field_diagnose
+ use ESMF , only : ESMF_Field
+ use med_internalstate_mod , only : InternalState, logunit, mastertask
+ use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
+ use med_utils_mod , only : chkerr => med_utils_ChkErr
use perf_mod , only : t_startf, t_stopf
implicit none
private
! public routines
- public :: med_map_RouteHandles_init
- public :: med_map_RH_is_created
- public :: med_map_Fractions_init
- public :: med_map_MapNorm_init
- public :: med_map_FB_Regrid_Norm
- public :: med_map_FB_Field_Regrid
- public :: med_map_Field_Regrid
-
- interface med_map_FB_Regrid_norm
- module procedure med_map_FB_Regrid_Norm_All
+ public :: med_map_routehandles_init
+ public :: med_map_rh_is_created
+ public :: med_map_mapnorm_init
+ public :: med_map_packed_field_create
+ public :: med_map_field_packed
+ public :: med_map_field_normalized
+ public :: med_map_field
+
+ interface med_map_routehandles_init
+ module procedure med_map_routehandles_initfrom_esmflds
+ module procedure med_map_routehandles_initfrom_fieldbundle
+ module procedure med_map_routehandles_initfrom_field
end interface
interface med_map_RH_is_created
@@ -51,11 +32,10 @@ module med_map_mod
module procedure med_map_RH_is_created_RH1d
end interface
+ type(ESMF_Field) :: uv3d_src, uv3d_dst ! needed for 3d mapping of u,v vector pairs
+
! private module variables
- character(len=CS) :: flds_scalar_name
- integer :: srcTermProcessing_Value = 0 ! should this be a module variable?
- logical :: mastertask
character(*), parameter :: u_FILE_u = &
__FILE__
@@ -63,7 +43,7 @@ module med_map_mod
contains
!================================================================================
- subroutine med_map_RouteHandles_init(gcomp, llogunit, rc)
+ subroutine med_map_RouteHandles_initfrom_esmflds(gcomp, llogunit, rc)
!---------------------------------------------
! Initialize route handles in the mediator
@@ -93,14 +73,10 @@ subroutine med_map_RouteHandles_init(gcomp, llogunit, rc)
! for the field
!---------------------------------------------
- use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush, ESMF_KIND_I4
- use ESMF , only : ESMF_GridComp, ESMF_VM, ESMF_Field, ESMF_PoleMethod_Flag, ESMF_POLEMETHOD_ALLAVG
- use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_FieldSMMStore
- use ESMF , only : ESMF_FieldRedistStore, ESMF_FieldRegridStore, ESMF_REGRIDMETHOD_BILINEAR
- use ESMF , only : ESMF_UNMAPPEDACTION_IGNORE, ESMF_REGRIDMETHOD_CONSERVE, ESMF_NORMTYPE_FRACAREA
- use ESMF , only : ESMF_REGRIDMETHOD_NEAREST_STOD
- use ESMF , only : ESMF_NORMTYPE_DSTAREA, ESMF_REGRIDMETHOD_PATCH, ESMF_RouteHandlePrint
- use NUOPC , only : NUOPC_Write
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Field
+ use esmFlds , only : fldListFr, ncomps, mapunset, compname
+ use med_methods_mod , only : med_methods_FB_getFieldN
! input/output variables
type(ESMF_GridComp) :: gcomp
@@ -108,97 +84,39 @@ subroutine med_map_RouteHandles_init(gcomp, llogunit, rc)
integer, intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- type(ESMF_VM) :: vm
- type(ESMF_Field) :: fldsrc
- type(ESMF_Field) :: flddst
- integer :: localPet
- integer :: n,n1,n2,m,nf,nflds,ncomp
- integer :: SrcMaskValue
- integer :: DstMaskValue
- character(len=128) :: value
- character(len=128) :: rhname
- character(len=128) :: rhname_file
- character(len=CS) :: mapname
- character(len=CX) :: mapfile
- character(len=CS) :: string
- integer :: mapindex
- logical :: rhprint_flag = .false.
- logical :: mapexists = .false.
- real(R8) , pointer :: factorList(:)
- character(CL) , pointer :: fldnames(:)
- !integer(ESMF_KIND_I4), pointer :: unmappedDstList(:)
- character(len=128) :: logMsg
- type(ESMF_PoleMethod_Flag), parameter :: polemethod=ESMF_POLEMETHOD_ALLAVG
+ type(InternalState) :: is_local
+ type(ESMF_Field) :: fldsrc
+ type(ESMF_Field) :: flddst
+ integer :: n,n1,n2,m,nf
+ character(len=CX) :: mapfile
+ integer :: mapindex
+ logical :: mapexists = .false.
character(len=*), parameter :: subname=' (module_med_map: RouteHandles_init) '
!-----------------------------------------------------------
+
call t_startf('MED:'//subname)
+ rc = ESMF_SUCCESS
if (dbug_flag > 1) then
- call ESMF_LogWrite("Starting to initialize RHs", ESMF_LOGMSG_INFO)
- call ESMF_LogFlush()
+ call ESMF_LogWrite(trim(subname)//": start", ESMF_LOGMSG_INFO)
endif
- rc = ESMF_SUCCESS
-
- ! Determine mastertask
- call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
- call ESMF_VMGet(vm, localPet=localPet, rc=rc)
- mastertask = .false.
- if (localPet == 0) mastertask=.true.
! Get the internal state from Component.
nullify(is_local%wrap)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Create the necessary route handles
- if (mastertask) write(llogunit,*) ' '
+ ! First loop over source and destination components components
+ if (mastertask) write(logunit,*) ' '
do n1 = 1, ncomps
do n2 = 1, ncomps
-
- 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
- else if (coupling_mode(1:4) == 'nems') then
- if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then
- srcMaskValue = 1
- dstMaskValue = 0
- else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice)) then
- srcMaskValue = 0
- dstMaskValue = 1
- else if ((n1 == compocn .and. n2 == compice) .or. (n1 == compice .and. n2 == compocn)) then
- srcMaskValue = 0
- dstMaskValue = 0
- else
- ! TODO: what should the condition be here?
- dstMaskValue = ispval_mask
- srcMaskValue = ispval_mask
- end if
- else if (trim(coupling_mode) == 'hafs') then
- dstMaskValue = ispval_mask
- srcMaskValue = ispval_mask
- if (n1 == compocn .or. n1 == compice) srcMaskValue = 0
- if (n2 == compocn .or. n2 == compice) dstMaskValue = 0
- end if
-
- !--- get single fields from bundles
- !--- 1) ASSUMES all fields in the bundle are on identical grids
- !--- 2) MULTIPLE route handles are going to be generated for
- !--- given field bundle source and destination grids
-
if (n1 /= n2) then
-
- ! Determine route handle names
- rhname = trim(compname(n1))//"2"//trim(compname(n2))
-
if (is_local%wrap%med_coupling_active(n1,n2)) then ! If coupling is active between n1 and n2
-
- call FB_GetFieldN(is_local%wrap%FBImp(n1,n1), 1, fldsrc, rc)
+ ! Get source and destination fields
+ call med_methods_FB_getFieldN(is_local%wrap%FBImp(n1,n1), 1, fldsrc, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_GetFieldN(is_local%wrap%FBImp(n1,n2), 1, flddst, rc)
+ call med_methods_FB_getFieldN(is_local%wrap%FBImp(n1,n2), 1, flddst, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Loop over fields
@@ -206,137 +124,22 @@ subroutine med_map_RouteHandles_init(gcomp, llogunit, rc)
! Determine the mapping type for mapping field nf from n1 to n2
mapindex = fldListFr(n1)%flds(nf)%mapindex(n2)
+ if (mapindex /= mapunset) then
- ! separate check first since Fortran does not have short-circuit evaluation
- if (mapindex == mapunset) cycle
-
- ! Create route handle for target mapindex if route handle is required
- ! (i.e. mapindex /= mapunset) and route handle has not already been created
- mapexists = med_map_RH_is_created(is_local%wrap%RH,n1,n2,mapindex,rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (.not. mapexists) then
-
- mapname = trim(mapnames(mapindex))
- mapfile = trim(fldListFr(n1)%flds(nf)%mapfile(n2))
- string = trim(rhname)//'_weights'
+ ! determine if route handle has already been created
+ mapexists = med_map_RH_is_created(is_local%wrap%RH,n1,n2,mapindex,rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (mapindex == mapfcopy) then
- if (mastertask) then
- write(llogunit,'(3A)') subname,trim(string),' RH redist '
- end if
- call ESMF_LogWrite(subname // trim(string) // ' RH redist ', ESMF_LOGMSG_INFO)
- call ESMF_FieldRedistStore(fldsrc, flddst, &
- routehandle=is_local%wrap%RH(n1,n2,mapindex), &
- ignoreUnmatchedIndices = .true., rc=rc)
+ ! Create route handle for target mapindex if route handle is required
+ ! (i.e. mapindex /= mapunset) and route handle has not already been created
+ if (.not. mapexists) then
+ mapfile = trim(fldListFr(n1)%flds(nf)%mapfile(n2))
+ call med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, &
+ mapindex, is_local%wrap%rh(n1,n2,:), mapfile=trim(mapfile), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- else if (mapfile /= 'unset') then
- if (mastertask) then
- write(llogunit,'(4A)') subname,trim(string),' RH '//trim(mapname)//' via input file ',&
- trim(mapfile)
- end if
- call ESMF_LogWrite(subname // trim(string) //&
- ' RH '//trim(mapname)//' via input file '//trim(mapfile), ESMF_LOGMSG_INFO)
- call ESMF_FieldSMMStore(fldsrc, flddst, mapfile, &
- routehandle=is_local%wrap%RH(n1,n2,mapindex), &
- ignoreUnmatchedIndices=.true., &
- srcTermProcessing=srcTermProcessing_Value, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else
- ! Create route handle on the fly
- if (mastertask) write(llogunit,'(3A)') subname,trim(string),&
- ' RH regrid for '//trim(mapname)//' computed on the fly'
- call ESMF_LogWrite(subname // trim(string) //&
- ' RH regrid for '//trim(mapname)//' computed on the fly', ESMF_LOGMSG_INFO)
- if (mapindex == mapbilnr) then
- srcTermProcessing_Value = 0
- call ESMF_FieldRegridStore(fldsrc, flddst, &
- routehandle=is_local%wrap%RH(n1,n2,mapindex), &
- srcMaskValues=(/srcMaskValue/), &
- dstMaskValues=(/dstMaskValue/), &
- regridmethod=ESMF_REGRIDMETHOD_BILINEAR, &
- polemethod=polemethod, &
- srcTermProcessing=srcTermProcessing_Value, &
- factorList=factorList, &
- ignoreDegenerate=.true., &
- unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc)
- else if ((mapindex == mapconsf .or. mapindex == mapnstod_consf) .and. &
- .not. med_map_RH_is_created(is_local%wrap%RH(n1,n2,:),mapconsf,rc)) then
- call ESMF_FieldRegridStore(fldsrc, flddst, &
- routehandle=is_local%wrap%RH(n1,n2,mapconsf), &
- srcMaskValues=(/srcMaskValue/), &
- dstMaskValues=(/dstMaskValue/), &
- regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
- normType=ESMF_NORMTYPE_FRACAREA, &
- srcTermProcessing=srcTermProcessing_Value, &
- factorList=factorList, &
- ignoreDegenerate=.true., &
- unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
- !unmappedDstList=unmappedDstList, &
- rc=rc)
- else if ((mapindex == mapconsd .or. mapindex == mapnstod_consd) .and. &
- .not. med_map_RH_is_created(is_local%wrap%RH(n1,n2,:),mapconsd,rc)) then
- call ESMF_FieldRegridStore(fldsrc, flddst, &
- routehandle=is_local%wrap%RH(n1,n2,mapconsd), &
- srcMaskValues=(/srcMaskValue/), &
- dstMaskValues=(/dstMaskValue/), &
- regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
- normType=ESMF_NORMTYPE_DSTAREA, &
- srcTermProcessing=srcTermProcessing_Value, &
- factorList=factorList, &
- ignoreDegenerate=.true., &
- unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
- !unmappedDstList=unmappedDstList, &
- rc=rc)
- else if (mapindex == mappatch) then
- call ESMF_FieldRegridStore(fldsrc, flddst, &
- routehandle=is_local%wrap%RH(n1,n2,mapindex), &
- srcMaskValues=(/srcMaskValue/), &
- dstMaskValues=(/dstMaskValue/), &
- regridmethod=ESMF_REGRIDMETHOD_PATCH, &
- polemethod=polemethod, &
- srcTermProcessing=srcTermProcessing_Value, &
- factorList=factorList, &
- ignoreDegenerate=.true., &
- unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc)
- end if
- ! consd_nstod method requires a second routehandle
- if ((mapindex == mapnstod .or. mapindex == mapnstod_consd .or. mapindex == mapnstod_consf) .and. &
- .not. med_map_RH_is_created(is_local%wrap%RH(n1,n2,:),mapnstod,rc)) then
- call ESMF_FieldRegridStore(fldsrc, flddst, &
- routehandle=is_local%wrap%RH(n1,n2,mapnstod), &
- srcMaskValues=(/srcMaskValue/), &
- dstMaskValues=(/dstMaskValue/), &
- regridmethod=ESMF_REGRIDMETHOD_NEAREST_STOD, &
- srcTermProcessing=srcTermProcessing_Value, &
- factorList=factorList, &
- ignoreDegenerate=.true., &
- unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
- rc=rc)
- end if
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (rhprint_flag .and. mapindex /= mapnstod_consd .and. mapindex /= mapnstod_consf) then
- call NUOPC_Write(factorList, "array_med_"//trim(string)//"_consf.nc", rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
- !if (associated(unmappedDstList)) then
- ! write(logMsg,*) trim(subname),trim(string),' number of unmapped dest points = ', size(unmappedDstList)
- ! call ESMF_LogWrite(trim(logMsg), ESMF_LOGMSG_INFO)
- !end if
end if
- if (rhprint_flag .and. mapindex /= mapnstod_consd .and. mapindex /= mapnstod_consf) then
- call ESMF_LogWrite(trim(subname)//trim(string)//": printing RH for "//trim(mapname), &
- ESMF_LOGMSG_INFO)
- call ESMF_RouteHandlePrint(is_local%wrap%RH(n1,n2,mapindex), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! Check that a valid route handle has been created
- if (.not.med_map_RH_is_created(is_local%wrap%RH,n1,n2,mapindex,rc=rc)) then
- call ESMF_LogWrite(trim(subname)//trim(string)//": failed RH "//trim(mapname), &
- ESMF_LOGMSG_INFO)
- endif
- end if
+
+ end if ! end if mapindex is mapunset
end do ! loop over fields
end if ! if coupling is active between n1 and n2
end if ! if n1 not equal to n2
@@ -348,14 +151,253 @@ subroutine med_map_RouteHandles_init(gcomp, llogunit, rc)
endif
call t_stopf('MED:'//subname)
- end subroutine med_map_RouteHandles_init
+ end subroutine med_map_RouteHandles_initfrom_esmflds
+
+ !================================================================================
+ subroutine med_map_routehandles_initfrom_fieldbundle(n1, n2, FBsrc, FBdst, mapindex, RouteHandle, rc)
+
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush
+ use ESMF , only : ESMf_Field, ESMF_FieldBundle, ESMF_RouteHandle
+ use med_methods_mod , only : med_methods_FB_getFieldN
+
+ !---------------------------------------------
+ ! Initialize initialize additional route handles for mapping fractions
+ !---------------------------------------------
+
+ ! input/output variables
+ integer , intent(in) :: n1
+ integer , intent(in) :: n2
+ type(ESMF_FieldBundle) , intent(in) :: FBsrc
+ type(ESMF_FieldBundle) , intent(in) :: fBdst
+ integer , intent(in) :: mapindex
+ type(ESMF_RouteHandle) , intent(inout) :: RouteHandle(:,:,:)
+ integer , intent(out) :: rc
+
+ ! local variables
+ type(ESMF_Field) :: fldsrc
+ type(ESMF_Field) :: flddst
+ character(len=*), parameter :: subname=' (module_MED_map:med_map_routehandles_init_fields) '
+ !---------------------------------------------
+
+ call t_startf('MED:'//subname)
+ rc = ESMF_SUCCESS
+
+ if (dbug_flag > 1) then
+ call ESMF_LogWrite(trim(subname)//": start", ESMF_LOGMSG_INFO)
+ endif
+
+ call med_methods_FB_getFieldN(FBsrc, 1, fldsrc, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_FB_getFieldN(FBDst, 1, flddst, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ call med_map_routehandles_initfrom_field(n1, n2, fldsrc, flddst, mapindex, routehandle(n1,n2,:), rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ if (dbug_flag > 1) then
+ call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
+ endif
+ call t_stopf('MED:'//subname)
+
+ 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_FieldSMMStore, ESMF_FieldRedistStore, ESMF_FieldRegridStore
+ use ESMF , only : ESMF_REGRIDMETHOD_BILINEAR, ESMF_REGRIDMETHOD_PATCH
+ use ESMF , only : ESMF_REGRIDMETHOD_CONSERVE, ESMF_NORMTYPE_DSTAREA, ESMF_NORMTYPE_FRACAREA
+ use ESMF , only : ESMF_UNMAPPEDACTION_IGNORE, ESMF_REGRIDMETHOD_NEAREST_STOD
+ use esmFlds , only : mapbilnr, mapconsf, mapconsd, mappatch, mappatch_uv3d, mapfcopy
+ use esmFlds , only : mapunset, mapnames, nmappers
+ use esmFlds , only : mapnstod, mapnstod_consd, mapnstod_consf, mapnstod_consd
+ use esmFlds , only : ncomps, compatm, compice, compocn, compname
+ use esmFlds , only : mapfcopy, mapconsd, mapconsf, mapnstod
+ use esmFlds , only : coupling_mode, compname
+ use med_constants_mod , only : ispval_mask => med_constants_ispval_mask
+
+ ! input/output variables
+ integer , intent(in) :: n1
+ integer , intent(in) :: n2
+ type(ESMF_Field) , intent(inout) :: fldsrc
+ type(ESMF_Field) , intent(inout) :: flddst
+ integer , intent(in) :: mapindex
+ type(ESMF_RouteHandle) , intent(inout) :: routehandles(:)
+ character(len=*), optional , intent(in) :: mapfile
+ integer , intent(out) :: rc
+
+ ! local variables
+ character(len=CS) :: string
+ character(len=CS) :: mapname
+ integer :: srcMaskValue
+ integer :: dstMaskValue
+ character(len=ESMF_MAXSTR) :: lmapfile
+ logical :: rhprint = .false.
+ integer :: srcTermProcessing_Value = 0
+ type(ESMF_PoleMethod_Flag), parameter :: polemethod=ESMF_POLEMETHOD_ALLAVG
+ character(len=*), parameter :: subname=' (module_med_map: med_map_routehandles_initfrom_field) '
+ !---------------------------------------------
+
+ lmapfile = 'unset'
+ if (present(mapfile)) then
+ lmapfile = trim(mapfile)
+ end if
+
+ mapname = trim(mapnames(mapindex))
+ if (mastertask) then
+ write(6,*)'DEBUG: mapindex, mapname= ',mapindex,trim(mapname)
+ end if
+
+ 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
+ else if (coupling_mode(1:4) == 'nems') then
+ if (n1 == compatm .and. (n2 == compocn .or. n2 == compice)) then
+ srcMaskValue = 1
+ dstMaskValue = 0
+ else if (n2 == compatm .and. (n1 == compocn .or. n1 == compice)) then
+ srcMaskValue = 0
+ dstMaskValue = 1
+ else if ((n1 == compocn .and. n2 == compice) .or. (n1 == compice .and. n2 == compocn)) then
+ srcMaskValue = 0
+ dstMaskValue = 0
+ else
+ ! TODO: what should the condition be here?
+ dstMaskValue = ispval_mask
+ srcMaskValue = ispval_mask
+ end if
+ else if (trim(coupling_mode) == 'hafs') then
+ dstMaskValue = ispval_mask
+ srcMaskValue = ispval_mask
+ if (n1 == compocn .or. n1 == compice) srcMaskValue = 0
+ if (n2 == compocn .or. n2 == compice) dstMaskValue = 0
+ end if
+
+ write(string,'(a)') trim(compname(n1))//' to '//trim(compname(n2))
+
+ ! Create route handle
+ if (mapindex == mapfcopy) then
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' creating RH redist for '//trim(string)
+ end if
+ call ESMF_FieldRedistStore(fldsrc, flddst, routehandle=routehandles(mapfcopy), &
+ ignoreUnmatchedIndices = .true., rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else if (lmapfile /= 'unset') then
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//&
+ ' via input file '//trim(mapfile)//' for '//trim(string)
+ end if
+ call ESMF_FieldSMMStore(fldsrc, flddst, mapfile, routehandle=routehandles(mapindex), &
+ ignoreUnmatchedIndices=.true., &
+ srcTermProcessing=srcTermProcessing_Value, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else if (mapindex == mapbilnr) then
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string)
+ end if
+ call ESMF_FieldRegridStore(fldsrc, flddst, routehandle=routehandles(mapbilnr), &
+ srcMaskValues=(/srcMaskValue/), &
+ dstMaskValues=(/dstMaskValue/), &
+ regridmethod=ESMF_REGRIDMETHOD_BILINEAR, &
+ polemethod=polemethod, &
+ srcTermProcessing=srcTermProcessing_Value, &
+ ignoreDegenerate=.true., &
+ unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else if (mapindex == mapconsf .or. mapindex == mapnstod_consf) then
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string)
+ end if
+ call ESMF_FieldRegridStore(fldsrc, flddst, routehandle=routehandles(mapconsf), &
+ srcMaskValues=(/srcMaskValue/), &
+ dstMaskValues=(/dstMaskValue/), &
+ regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
+ normType=ESMF_NORMTYPE_FRACAREA, &
+ srcTermProcessing=srcTermProcessing_Value, &
+ ignoreDegenerate=.true., &
+ unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
+ rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else if (mapindex == mapconsd .or. mapindex == mapnstod_consd) then
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string)
+ end if
+ call ESMF_FieldRegridStore(fldsrc, flddst, routehandle=routehandles(mapconsd), &
+ srcMaskValues=(/srcMaskValue/), &
+ dstMaskValues=(/dstMaskValue/), &
+ regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
+ normType=ESMF_NORMTYPE_DSTAREA, &
+ srcTermProcessing=srcTermProcessing_Value, &
+ ignoreDegenerate=.true., &
+ unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
+ rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else if (mapindex == mappatch .or. mapindex == mappatch_uv3d) then
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' creating RH '//trim(mapname)//' for '//trim(string)
+ end if
+ call ESMF_FieldRegridStore(fldsrc, flddst, routehandle=routehandles(mappatch), &
+ srcMaskValues=(/srcMaskValue/), &
+ dstMaskValues=(/dstMaskValue/), &
+ regridmethod=ESMF_REGRIDMETHOD_PATCH, &
+ polemethod=polemethod, &
+ srcTermProcessing=srcTermProcessing_Value, &
+ ignoreDegenerate=.true., &
+ unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else
+ if (mastertask) then
+ write(logunit,'(A)') trim(subname)//' mapindex '//trim(mapname)//' not supported for '//trim(string)
+ end if
+ call ESMF_LogWrite(trim(subname)//' mapindex '//trim(mapname)//' not supported ', &
+ ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
+ rc = ESMF_FAILURE
+ return
+ end if
+
+ ! consd_nstod method requires a second routehandle
+ if (mapindex == mapnstod .or. mapindex == mapnstod_consd .or. mapindex == mapnstod_consf) then
+ call ESMF_FieldRegridStore(fldsrc, flddst, routehandle=routehandles(mapnstod), &
+ srcMaskValues=(/srcMaskValue/), &
+ dstMaskValues=(/dstMaskValue/), &
+ regridmethod=ESMF_REGRIDMETHOD_NEAREST_STOD, &
+ srcTermProcessing=srcTermProcessing_Value, &
+ ignoreDegenerate=.true., &
+ unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
+ rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ end if
+
+ ! Check that a valid route handle has been created
+ ! TODO: should this be implemented as an error check or ignored?
+ ! if (.not. med_map_RH_is_created(routehandle ,rc=rc)) then
+ ! string = trim(compname(n1))//"2"//trim(compname(n2))//'_weights'
+ ! call ESMF_LogWrite(trim(subname)//trim(string)//": failed RH "//trim(mapnames(mapindex)), &
+ ! ESMF_LOGMSG_INFO)
+ ! endif
+
+ ! Output route handle to file if requested
+ if (rhprint) then
+ if (mastertask) then
+ write(logunit,'(a)') trim(subname)//trim(string)//": printing RH for "//trim(mapname)
+ end if
+ call ESMF_RouteHandlePrint(routehandles(mapindex), rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ endif
-!================================================================================
+ end subroutine med_map_routehandles_initfrom_field
+ !================================================================================
logical function med_map_RH_is_created_RH3d(RHs,n1,n2,mapindex,rc)
- use ESMF , only : ESMF_RouteHandle
+ use ESMF, only : ESMF_RouteHandle
+ ! input/output variables
type(ESMF_RouteHandle) , intent(in) :: RHs(:,:,:)
integer , intent(in) :: n1
integer , intent(in) :: n2
@@ -364,22 +406,24 @@ logical function med_map_RH_is_created_RH3d(RHs,n1,n2,mapindex,rc)
! local variables
integer :: rc1, rc2
- logical :: mapexists
- character(len=*), parameter :: subname=' (med_map_RH_is_created: ) '
+ character(len=*), parameter :: subname=' (module_MED_map:med_map_RH_is_created) '
+ !-----------------------------------------------------------
rc = ESMF_SUCCESS
-
med_map_RH_is_created_RH3d = med_map_RH_is_created_RH1d(RHs(n1,n2,:),mapindex,rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end function med_map_RH_is_created_RH3d
-!================================================================================
+!================================================================================
logical function med_map_RH_is_created_RH1d(RHs,mapindex,rc)
- use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated
+ use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated
+ use esmFlds , only : mapconsd, mapconsf, mapnstod
+ use esmFlds , only : mapnstod_consd, mapnstod_consf
+ ! input/output varaibes
type(ESMF_RouteHandle) , intent(in) :: RHs(:)
integer , intent(in) :: mapindex
integer , intent(out) :: rc
@@ -387,7 +431,8 @@ logical function med_map_RH_is_created_RH1d(RHs,mapindex,rc)
! local variables
integer :: rc1, rc2
logical :: mapexists
- character(len=*), parameter :: subname=' (med_map_RH_is_created_RH1d: ) '
+ character(len=*), parameter :: subname=' (module_MED_map:med_map_RH_is_created_RH1d) '
+ !-----------------------------------------------------------
rc = ESMF_SUCCESS
rc1 = ESMF_SUCCESS
@@ -397,650 +442,672 @@ logical function med_map_RH_is_created_RH1d(RHs,mapindex,rc)
if (mapindex == mapnstod_consd .and. &
ESMF_RouteHandleIsCreated(RHs(mapnstod), rc=rc1) .and. &
ESMF_RouteHandleIsCreated(RHs(mapconsd), rc=rc2)) then
+ rc = rc1
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ rc = rc2
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
mapexists = .true.
else if (mapindex == mapnstod_consf .and. &
ESMF_RouteHandleIsCreated(RHs(mapnstod), rc=rc1) .and. &
ESMF_RouteHandleIsCreated(RHs(mapconsf), rc=rc2)) then
+ rc = rc1
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ rc = rc2
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
mapexists = .true.
else if (ESMF_RouteHandleIsCreated(RHs(mapindex), rc=rc1)) then
+ rc = rc1
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
mapexists = .true.
end if
-
med_map_RH_is_created_RH1d = mapexists
- rc = rc1
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- rc = rc2
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
end function med_map_RH_is_created_RH1d
-!================================================================================
-
- subroutine med_map_Fractions_init(gcomp, n1, n2, FBSrc, FBDst, RouteHandle, rc)
-
- !---------------------------------------------
- ! Initialize initialize additional route handles
- ! for mapping fractions
- !---------------------------------------------
-
- use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush
- use ESMF , only : ESMF_GridComp, ESMF_FieldBundle, ESMF_RouteHandle, ESMF_Field
- use ESMF , only : ESMF_FieldRedistStore, ESMF_FieldSMMStore, ESMF_FieldRegridStore
- use ESMF , only : ESMF_UNMAPPEDACTION_IGNORE, ESMF_REGRIDMETHOD_CONSERVE, ESMF_NORMTYPE_FRACAREA
- use NUOPC , only : NUOPC_CompAttributeGet
-
- type(ESMF_GridComp) :: gcomp
- integer , intent(in) :: n1
- integer , intent(in) :: n2
- type(ESMF_FieldBundle) , intent(in) :: FBSrc
- type(ESMF_FieldBundle) , intent(in) :: FBDst
- type(ESMF_RouteHandle) , intent(inout) :: RouteHandle
- integer , intent(out) :: rc
-
- ! local variables
- type(ESMF_Field) :: fldsrc
- type(ESMF_Field) :: flddst
- character(len=128) :: rhname
- character(len=CS) :: mapname
- character(len=CX) :: mapfile
- character(len=CS) :: string
- integer :: SrcMaskValue
- integer :: DstMaskValue
- real(R8), pointer :: factorList(:)
- character(len=*), parameter :: subname=' (med_map_fractions_init: ) '
- !---------------------------------------------
- call t_startf('MED:'//subname)
-
- if (dbug_flag > 1) then
- call ESMF_LogWrite("Initializing RHs not yet created and needed for mapping fractions", &
- ESMF_LOGMSG_INFO)
- call ESMF_LogFlush()
- endif
-
- rc = ESMF_SUCCESS
-
- call FB_getFieldN(FBsrc, 1, fldsrc, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_getFieldN(FBDst, 1, flddst, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- dstMaskValue = ispval_mask
- srcMaskValue = ispval_mask
- if (n1 == compocn .or. n1 == compice) srcMaskValue = 0
- if (n2 == compocn .or. n2 == compice) dstMaskValue = 0
-
- rhname = trim(compname(n1))//"2"//trim(compname(n2))
- string = trim(rhname)//'_weights'
- if ( (n1 == compocn .and. n2 == compice) .or. (n1 == compice .and. n2 == compocn)) then
- mapfile = 'idmap'
- else
- call ESMF_LogWrite("Querying for attribute "//trim(rhname)//"_fmapname = ", ESMF_LOGMSG_INFO)
- call NUOPC_CompAttributeGet(gcomp, name=trim(rhname)//"_fmapname", value=mapfile, rc=rc)
- mapname = trim(mapnames(mapconsf))
- end if
-
- if (mapfile == 'idmap') then
- call ESMF_LogWrite(trim(subname) // trim(string) //&
- ' RH '//trim(mapname)// ' is redist', ESMF_LOGMSG_INFO)
- call ESMF_FieldRedistStore(fldsrc, flddst, &
- routehandle=RouteHandle, &
- ignoreUnmatchedIndices = .true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else if (mapfile /= 'unset') then
- call ESMF_LogWrite(subname // trim(string) //&
- ' RH '//trim(mapname)//' via input file '//trim(mapfile), ESMF_LOGMSG_INFO)
- call ESMF_FieldSMMStore(fldsrc, flddst, mapfile, &
- routehandle=RouteHandle, &
- ignoreUnmatchedIndices=.true., &
- srcTermProcessing=srcTermProcessing_Value, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else
- call ESMF_LogWrite(subname // trim(string) //&
- ' RH '//trim(mapname)//' computed on the fly '//trim(mapfile), ESMF_LOGMSG_INFO)
- call ESMF_FieldRegridStore(fldsrc, flddst, &
- routehandle=RouteHandle, &
- srcMaskValues=(/srcMaskValue/), &
- dstMaskValues=(/dstMaskValue/), &
- regridmethod=ESMF_REGRIDMETHOD_CONSERVE, &
- normType=ESMF_NORMTYPE_FRACAREA, &
- srcTermProcessing=srcTermProcessing_Value, &
- factorList=factorList, &
- ignoreDegenerate=.true., &
- unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, rc=rc)
- end if
-
- if (dbug_flag > 1) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
- call t_stopf('MED:'//subname)
-
- end subroutine med_map_Fractions_init
-
-!================================================================================
-
- subroutine med_map_MapNorm_init(gcomp, llogunit, rc)
+ !================================================================================
+ subroutine med_map_mapnorm_init(gcomp, rc)
!---------------------------------------
- ! Initialize unity normalization field bundle
- ! and do the mapping for unity normalization up front
+ ! Initialize unity normalization fields and do the mapping for unity normalization up front
!---------------------------------------
- use ESMF , only: ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush
- use ESMF , only: ESMF_GridComp, ESMF_FieldBundle, ESMF_FieldBundleGet
+ use ESMF , only: ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_LogFlush
+ use ESMF , only: ESMF_GridComp
+ use ESMF , only: ESMF_Mesh, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT
+ use ESMF , only: ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_FieldBundleCreate
+ use ESMF , only: ESMF_FieldBundleIsCreated
+ use ESMF , only: ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate, ESMF_FieldDestroy
+ use esmFlds , only: ncomps, nmappers, compname, mapnames
+ use med_constants_mod , only: czero => med_constants_czero
! input/output variables
type(ESMF_GridComp) :: gcomp
- integer, intent(in) :: llogunit
integer, intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- type(ESMF_FieldBundle) :: FBTmp
- integer :: n1, n2, m
- character(len=CS) :: normname
- character(len=1) :: cn1,cn2,cm
- real(R8), pointer :: dataptr(:)
- character(len=*),parameter :: subname='(module_MED_MAP:MapNorm_init)'
+ type(InternalState) :: is_local
+ integer :: n1, n2, m
+ character(len=1) :: cn1,cn2,cm
+ real(R8), pointer :: dataptr(:) => null()
+ integer :: fieldCount
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
+ type(ESMF_Field) :: field_src
+ type(ESMF_Mesh) :: mesh_src
+ type(ESMF_Mesh) :: mesh_dst
+ character(len=*),parameter :: subname=' (module_MED_MAP:MapNorm_init)'
!-----------------------------------------------------------
+
call t_startf('MED:'//subname)
+ rc = ESMF_SUCCESS
if (dbug_flag > 1) then
- call ESMF_LogWrite("Starting to initialize unity map normalizations", ESMF_LOGMSG_INFO)
- call ESMF_LogFlush()
+ call ESMF_LogWrite(trim(subname)//": start", ESMF_LOGMSG_INFO)
+ endif
+ if (mastertask) then
+ write(logunit,*)
+ write(logunit,'(a)') trim(subname)//"Initializing unity map normalizations"
endif
-
- rc = ESMF_SUCCESS
! Get the internal state from Component.
nullify(is_local%wrap)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! Initialize module variables
- flds_scalar_name = is_local%wrap%flds_scalar_name
-
- ! Create the normalization field bundles
- normname = 'one'
+ ! Create the destination normalization field
do n1 = 1,ncomps
- do n2 = 1,ncomps
- if (n1 /= n2) then
- if (is_local%wrap%med_coupling_active(n1,n2)) then
- do m = 1,nmappers
- if (med_map_RH_is_created(is_local%wrap%RH,n1,n2,m,rc=rc)) then
- if (dbug_flag > 1) then
- write(cn1,'(i1)') n1; write(cn2,'(i1)') n2; write(cm ,'(i1)') m
- call ESMF_LogWrite(trim(subname)//":"//'creating FBMapNormOne for '&
- //compname(n1)//'->'//compname(n2)//' with mapping '//mapnames(m), &
- ESMF_LOGMSG_INFO)
- endif
- call FB_init(FBout=is_local%wrap%FBNormOne(n1,n2,m), &
- flds_scalar_name=flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(n1,n2), &
- fieldNameList=(/trim(normname)/), name='FBNormOne', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_reset(is_local%wrap%FBNormOne(n1,n2,m), value=czero, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(n1,n1))) then
+ ! Get source mesh
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n1), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n1), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=mesh_src, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_src = ESMF_FieldCreate(mesh_src, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_src, farrayptr=dataPtr, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr(:) = 1.0_R8
- call FB_init(FBout=FBTmp, &
- flds_scalar_name=flds_scalar_name, &
- STgeom=is_local%wrap%NStateImp(n1), &
- fieldNameList=(/trim(normname)/), name='FBTmp', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n2 = 1,ncomps
+ if ( n1 /= n2 .and. &
+ ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(n1,n2)) .and. &
+ is_local%wrap%med_coupling_active(n1,n2) ) then
- call FB_GetFldPtr(FBTmp, trim(normname), fldptr1=dataPtr, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- dataptr(:) = 1.0_R8
+ ! Get destination mesh
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(n1,n2), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=mesh_dst, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_map_FB_Field_Regrid(FBTmp, trim(normname), is_local%wrap%FBNormOne(n1,n2,m), trim(normname), &
- is_local%wrap%RH(n1,n2,:), m, rc=rc)
+ ! Createis_local%wrap%field_NormOne(n1,n2,m)
+ do m = 1,nmappers
+ if (med_map_RH_is_created(is_local%wrap%RH,n1,n2,m,rc=rc)) then
+ is_local%wrap%field_NormOne(n1,n2,m) = ESMF_FieldCreate(mesh_dst, &
+ ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_clean(FBTmp, rc=rc)
+ call ESMF_FieldGet(is_local%wrap%field_NormOne(n1,n2,m), farrayptr=dataptr, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr(:) = czero
+ call med_map_field( &
+ field_src=field_src, &
+ field_dst=is_local%wrap%field_NormOne(n1,n2,m), &
+ routehandles=is_local%wrap%RH(n1,n2,:), &
+ maptype=m, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (mastertask) then
+ write(cn1,'(i1)') n1; write(cn2,'(i1)') n2; write(cm ,'(i1)') m
+ write(logunit,'(a)') trim(subname)//' created field_NormOne for '&
+ //compname(n1)//'->'//compname(n2)//' with mapping '//mapnames(m)
+ endif
end if
- end do
- end if
- end if
- end do
- end do
+ end do ! end of loop over m mappers
+ end if ! end of if block for creating destination field
+ end do ! end of loop over n2
+
+ ! Deallocate memory
+ deallocate(fieldlist)
+ call ESMF_FieldDestroy(field_src, rc=rc, noGarbage=.true.)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ end if ! end of if-block for existence of field bundle
+ end do ! end of loop over n1
if (dbug_flag > 1) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
endif
call t_stopf('MED:'//subname)
- end subroutine med_map_MapNorm_init
+ end subroutine med_map_mapnorm_init
!================================================================================
+ subroutine med_map_packed_field_create(destcomp, flds_scalar_name, &
+ fldsSrc, FBSrc, FBDst, packed_data, rc)
- subroutine med_map_FB_Regrid_Norm_All(fldsSrc, srccomp, destcomp, &
- FBSrc, FBDst, FBFracSrc, FBNormOne, RouteHandles, string, rc)
-
- ! ----------------------------------------------
- ! Map field bundles with appropriate fraction weighting
- ! ----------------------------------------------
-
- use NUOPC , only: NUOPC_IsConnected
- use ESMF , only: ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only: ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR
- use ESMF , only: ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8
- use ESMF , only: ESMF_FieldBundle, ESMF_FieldBundleIsCreated, ESMF_FieldBundleGet
- use ESMF , only: ESMF_RouteHandle
- use ESMF , only: ESMF_REGION_SELECT, ESMF_REGION_TOTAL
- use ESMF , only: ESMF_Field, ESMF_FieldGet, ESMF_FieldIsCreated
- use ESMF , only: ESMF_FieldDestroy, ESMF_FieldCreate
- use ESMF , only: ESMF_TERMORDER_SRCSEQ, ESMF_Region_Flag, ESMF_REGION_TOTAL
- use ESMF , only: ESMF_REGION_SELECT
+ use ESMF
+ use esmFlds , only : med_fldList_entry_type, nmappers
+ use esmFlds , only : ncomps, compatm, compice, compocn, compname, mapnames
+ use med_internalstate_mod , only : packed_data_type
! input/output variables
- type(med_fldList_entry_type) , pointer :: fldsSrc(:)
- integer , intent(in) :: srccomp
- integer , intent(in) :: destcomp
- type(ESMF_FieldBundle) , intent(inout) :: FBSrc
- type(ESMF_FieldBundle) , intent(inout) :: FBDst
- type(ESMF_FieldBundle) , intent(in) :: FBFracSrc
- type(ESMF_FieldBundle) , intent(in) :: FBNormOne(:)
- type(ESMF_RouteHandle) , intent(inout) :: RouteHandles(:)
- character(len=*), optional , intent(in) :: string
- integer , intent(out) :: rc
+ integer , intent(in) :: destcomp
+ character(len=*) , intent(in) :: flds_scalar_name
+ type(med_fldList_entry_type) , pointer :: fldsSrc(:) ! array over mapping types
+ type(ESMF_FieldBundle) , intent(in) :: FBSrc
+ type(ESMF_FieldBundle) , intent(inout) :: FBDst
+ type(packed_data_type) , intent(inout) :: packed_data(:) ! array over mapping types
+ integer , intent(out) :: rc
! local variables
- integer :: i, n, k
- integer :: lrank
- character(len=CS) :: lstring
- integer :: mapindex
- character(len=CS) :: mapnorm
- character(len=CS) :: fldname
- type(ESMF_Mesh) :: lmesh
- type(ESMF_Field) :: srcField
- type(ESMF_Field) :: dstField
- type(ESMF_Field) :: lfield
- type(ESMF_Field) :: frac_field_src
- type(ESMF_Field) :: frac_field_dst
- real(R8), allocatable :: data_srctmp(:)
- real(R8), allocatable :: data_srctmp_1d(:)
- real(R8), allocatable :: data_srctmp_2d(:,:)
- real(R8), pointer :: data_src_1d(:)
- real(R8), pointer :: data_src_2d(:,:)
- real(R8), pointer :: data_frac(:)
- real(R8), pointer :: data_norm(:)
- logical :: used_cart3d_for_uvmapping
- logical :: frac_field_created
- type(ESMF_Field) :: usrc,vsrc
- type(ESMF_Field) :: udst,vdst
- 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 :: checkflag = .false.
- character(len=*), parameter :: subname='(module_MED_Map:med_map_Regrid_Norm)'
- !-------------------------------------------------------------------------------
-
- call t_startf('MED:'//subname)
- call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO)
- call memcheck(subname, 1, mastertask)
-
-#ifdef DEBUG
- checkflag = .true.
-#endif
-
- !---------------------------------------
-
- if (present(string)) then
- lstring = trim(string)
- else
- lstring = " "
- endif
+ integer :: nf, nu, ns
+ integer, allocatable :: npacked(:)
+ integer :: fieldcount
+ type(ESMF_Field) :: lfield
+ integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields
+ real(r8), pointer :: ptrsrc_packed(:,:) => null()
+ real(r8), pointer :: ptrdst_packed(:,:) => null()
+ integer :: lsize_src
+ integer :: lsize_dst
+ type(ESMF_Mesh) :: lmesh_src
+ type(ESMF_Mesh) :: lmesh_dst
+ integer :: mapindex
+ type(ESMF_Field), pointer :: fieldlist_src(:) => null()
+ type(ESMF_Field), pointer :: fieldlist_dst(:) => null()
+ character(CL), allocatable :: fieldNameList(:)
+ character(len=*), parameter :: subname=' (module_MED_map:med_packed_fieldbundles_create) '
+ !-----------------------------------------------------------
rc = ESMF_SUCCESS
- !---------------------------------------
- ! First - reset the field bundle on the destination grid to zero
- !---------------------------------------
+ ! Get field count for both FBsrc and FBdst
+ call ESMF_FieldBundleGet(FBsrc, fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! get fields in source and destination field bundles
+ allocate(fieldlist_src(fieldcount))
+ call ESMF_FieldBundleGet(FBsrc, fieldlist=fieldlist_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist_dst(fieldcount))
+ call ESMF_FieldBundleGet(FBdst, fieldlist=fieldlist_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! field names are the same for the source and destination field bundles
+ allocate(fieldnamelist(fieldcount))
+ call ESMF_FieldBundleGet(FBsrc, fieldnamelist=fieldnamelist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! Determine local size and mesh of source fields
+ ! Allocate a source fortran pointer for the new packed field bundle
+ call ESMF_FieldGet(fieldlist_src(1), mesh=lmesh_src, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_MeshGet(lmesh_src, numOwnedElements=lsize_src, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_reset(FBDst, value=czero, rc=rc)
+ ! Determine local size of destination fields
+ ! Allocate a destination fortran pointer for the new packed field bundle
+ call ESMF_FieldGet(fieldlist_dst(1), mesh=lmesh_dst, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_MeshGet(lmesh_dst, numOwnedElements=lsize_dst, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- !---------------------------------------
- ! Loop over all fields in the source field bundle and map them to
- ! the destination field bundle accordingly
- !---------------------------------------
+ ! Gather all fields that will be mapped with a target map index into a packed field
+ ! Calculated size of packed field based on the fact that some fields have
+ ! ungridded dimensions and need to unwrap them into separate fields for the
+ ! purposes of packing
+
+ if (mastertask) write(logunit,*)
+
+ ! Determine the normalization type for each packed_data mapping element
+ ! Loop over mapping types
+ do mapindex = 1,nmappers
+ ! Loop over source field bundle
+ do nf = 1, fieldCount
+ ! Loop over the fldsSrc types
+ do ns = 1,size(fldsSrc)
+ ! Note that fieldnamelist is an array of names for the source fields
+ ! The assumption is that there is only one mapping normalization
+ ! for any given mapping type
+ if ( fldsSrc(ns)%mapindex(destcomp) == mapindex .and. &
+ trim(fldsSrc(ns)%shortname) == trim(fieldnamelist(nf))) then
+ ! Set the normalization to the input
+ packed_data(mapindex)%mapnorm = fldsSrc(ns)%mapnorm(destcomp)
+ end if
+ end do
+ end do
+ end do
- call ESMF_LogWrite(trim(subname)//" *** mapping from "//trim(compname(srccomp))//" to "//&
- trim(compname(destcomp))//" ***", ESMF_LOGMSG_INFO)
-
- frac_field_created = .false.
- used_cart3d_for_uvmapping = .false.
- do n = 1,size(fldsSrc)
- ! Determine if field is a scalar - and if so go to next iternation
- fldname = fldsSrc(n)%shortname
- if (fldname == flds_scalar_name) CYCLE
-
- ! Determine if there is a map index and if its zero go to next iteration
- mapindex = fldsSrc(n)%mapindex(destcomp)
- if (mapindex == 0) CYCLE
- mapnorm = fldsSrc(n)%mapnorm(destcomp)
-
- ! Determine if field is FBSrc or FBDst or connected - and if not go to next iteration
- if (.not. FB_FldChk(FBSrc, trim(fldname), rc=rc)) then
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//" field not found in FBSrc: "//trim(fldname), ESMF_LOGMSG_INFO)
- end if
- CYCLE
- else if (.not. FB_FldChk(FBDst, trim(fldname), rc=rc)) then
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//" field not found in FBDst: "//trim(fldname), ESMF_LOGMSG_INFO)
- end if
- CYCLE
- end if
+ ! Allocate memory to keep tracked of packing index for each mapping type
+ allocate(npacked(nmappers))
+ npacked(:) = 0
+
+ ! Loop over mapping types
+ do mapindex = 1,nmappers
- ! -------------------
- ! Error checks
- ! -------------------
-
- if (.not. FB_FldChk(FBSrc, fldname, rc=rc)) then
- call ESMF_LogWrite(trim(subname)//" field not found in FBSrc: "//trim(fldname), ESMF_LOGMSG_INFO)
- else if (.not. FB_FldChk(FBDst, fldname, rc=rc)) then
- call ESMF_LogWrite(trim(subname)//" field not found in FBDst: "//trim(fldname), ESMF_LOGMSG_INFO)
- else if (.not. med_map_RH_is_created(RouteHandles,mapindex,rc=rc)) then
- call ESMF_LogWrite(trim(subname)//trim(lstring)//&
- ": ERROR RH not available for "//mapnames(mapindex)//": fld="//trim(fldname), &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
- rc = ESMF_FAILURE
- return
+ ! Allocate the fldindex attribute of packed_indices if needed
+ if (.not. allocated(packed_data(mapindex)%fldindex)) then
+ allocate(packed_data(mapindex)%fldindex(fieldcount))
+ packed_data(mapindex)%fldindex(:) = -999
end if
- ! -------------------
- ! Do cart3d mapping for u and v fields from atm if appropriate
- ! -------------------
+ ! Loop over the fields in FBSrc
+ do nf = 1, fieldCount
- if (mapuv_with_cart3d) then
- if ((trim(fldname) == 'Sa_u' .or. trim(fldname) == 'Sa_v')) then
- if (.not. used_cart3d_for_uvmapping) then
- mapindex = fldsSrc(n)%mapindex(destcomp)
- mapnorm = fldsSrc(n)%mapnorm(destcomp)
- call ESMF_FieldBundleGet(FBSrc, fieldName='Sa_u', field=usrc, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleGet(FBSrc, fieldName='Sa_v', field=vsrc, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleGet(FBDst, fieldName='Sa_u', field=udst, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleGet(FBDst, fieldName='Sa_v', field=vdst, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! Loop over the fldsSrc types
+ do ns = 1,size(fldsSrc)
- call ESMF_LogWrite(trim(subname)//" --> remapping "//trim(fldname)//" with "//trim(mapnames(mapindex)), &
- ESMF_LOGMSG_INFO)
+ if ( fldsSrc(ns)%mapindex(destcomp) == mapindex .and. &
+ trim(fldsSrc(ns)%shortname) == trim(fieldnamelist(nf))) then
- call med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc=rc)
+ ! Determine mapping of indices into packed field bundle
+ ! Get source field
+ call ESMF_FieldGet(fieldlist_src(nf), ungriddedUBound=ungriddedUBound, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUBound(1) > 0) then
+ do nu = 1,ungriddedUBound(1)
+ npacked(mapindex) = npacked(mapindex) + 1
+ if (nu == 1) then
+ packed_data(mapindex)%fldindex(nf) = npacked(mapindex)
+ end if
+ end do
+ else
+ npacked(mapindex) = npacked(mapindex) + 1
+ packed_data(mapindex)%fldindex(nf) = npacked(mapindex)
+ end if
- used_cart3d_for_uvmapping = .true.
- end if
- CYCLE
- end if
- end if
+ if (mastertask) then
+ write(logunit,'(5(a,2x),2x,i4)') trim(subname)//&
+ 'Packed field: destcomp,mapping,mapnorm,fldname,index: ', &
+ trim(compname(destcomp)), &
+ trim(mapnames(mapindex)), &
+ trim(packed_data(mapindex)%mapnorm), &
+ trim(fieldnamelist(nf)), &
+ packed_data(mapindex)%fldindex(nf)
+ end if
- ! -------------------
- ! Get the source and destination fields
- ! -------------------
+ end if! end if source field is mapped to destination field with mapindex
+ end do ! end loop over FBSrc fields
+ end do ! end loop over fldsSrc elements
- call ESMF_LogWrite(trim(subname)//" --> remapping "//trim(fldname)//" with "//trim(mapnames(mapindex)), &
- ESMF_LOGMSG_INFO)
+ if (npacked(mapindex) > 0) then
+ ! Create the packed source field bundle for mapindex
+ allocate(ptrsrc_packed(npacked(mapindex), lsize_src))
+ packed_data(mapindex)%field_src = ESMF_FieldCreate(lmesh_src, &
+ ptrsrc_packed, gridToFieldMap=(/2/), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleGet(FBSrc, fieldName=trim(fldname), field=srcfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleGet(FBDst, fieldName=trim(fldname), field=dstfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! Create the packed destination field bundle for mapindex
+ allocate(ptrdst_packed(npacked(mapindex), lsize_dst))
+ packed_data(mapindex)%field_dst = ESMF_FieldCreate(lmesh_dst, &
+ ptrdst_packed, gridToFieldMap=(/2/), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! -------------------
- ! Do the mapping
- ! -------------------
+ packed_data(mapindex)%field_fracsrc = ESMF_FieldCreate(lmesh_src, ESMF_TYPEKIND_R8, &
+ meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ packed_data(mapindex)%field_fracdst = ESMF_FieldCreate(lmesh_dst, ESMF_TYPEKIND_R8, &
+ meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ end if
+ end do ! end loop over mapindex
- if (mapindex == mapfcopy) then
- call med_map_FB_Field_Regrid(FBSrc, fldname, FBDst, fldname, RouteHandles, mapindex, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(npacked)
+ deallocate(fieldlist_src)
+ deallocate(fieldlist_dst)
- else
- ! Determine the normalization for the map
- mapnorm = fldsSrc(n)%mapnorm(destcomp)
+ end subroutine med_map_packed_field_create
- if ( trim(mapnorm) /= 'unset' .and. trim(mapnorm) /= 'one' .and. trim(mapnorm) /= 'none') then
+ !================================================================================
+ subroutine med_map_field_packed(FBSrc, FBDst, FBFracSrc, field_normOne, packed_data, routehandles, rc)
- call FB_getFieldByName(FBSrc, fldname, lfield, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, rank=lrank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! -----------------------------------------------
+ ! Do regridding via packed field bundles
+ ! -----------------------------------------------
- ! get a pointer to source field data in FBSrc
- if (lrank == 1) then
- call ESMF_FieldGet(srcfield, farrayPtr=data_src_1d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else if (lrank == 2) then
- call ESMF_FieldGet(srcfield, ungriddedUBound=ungriddedUBound, gridToFieldMap=gridToFieldMap, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (gridToFieldMap(1) /= 2) then
- call ESMF_LogWrite(trim(subname)//" fldname= "//trim(fldname)//&
- "has gridTofieldMap not equal to 2", ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
- rc = ESMF_FAILURE
- return
- end if
- call ESMF_FieldGet(srcfield, farrayPtr=data_src_2d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
+ use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldIsCreated
+ use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_FieldRedist, ESMF_RouteHandle
+ use esmFlds , only : nmappers, mapfcopy, mappatch_uv3d, mappatch
+ use med_internalstate_mod , only : packed_data_type
- ! allocate memory for a save array if not already allocated
- if (lrank == 1) then
- if (.not. allocated(data_srctmp_1d) .or. size(data_srctmp_1d) /= size(data_src_1d)) then
- if (allocated(data_srctmp_1d)) then
- deallocate(data_srctmp_1d)
- endif
- allocate(data_srctmp_1d(size(data_src_1d)))
- endif
- elseif (lrank == 2) then
- if (.not. allocated(data_srctmp_2d) .or. size(data_srctmp_2d) /= size(data_src_2d)) then
- if (allocated(data_srctmp_2d)) then
- deallocate(data_srctmp_2d)
- endif
- allocate(data_srctmp_2d(size(data_src_2d,dim=1), size(data_src_2d,dim=2)))
- endif
- end if
+ ! input/output variables
+ type(ESMF_FieldBundle) , intent(in) :: FBSrc
+ type(ESMF_FieldBundle) , intent(inout) :: FBDst
+ type(ESMF_Field) , intent(in) :: field_normOne(:) ! array over mapping types
+ type(ESMF_FieldBundle) , intent(in) :: FBFracSrc ! fraction field bundle for source
+ type(packed_data_type) , intent(inout) :: packed_data(:) ! array over mapping types
+ type(ESMF_RouteHandle) , intent(inout) :: routehandles(:)
+ integer , intent(out) :: rc
- ! get a pointer to the array of the normalization on the source grid - this must
- ! be the same size is as fraction on the source grid
- call FB_GetFldPtr(FBFracSrc, trim(mapnorm), data_frac, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! local variables
+ integer :: nf, nu, np, n
+ integer :: fieldcount
+ integer :: mapindex
+ integer :: ungriddedUBound(1)
+ real(r8), pointer :: dataptr1d(:) => null()
+ real(r8), pointer :: dataptr2d(:,:) => null()
+ real(r8), pointer :: dataptr2d_packed(:,:) => null()
+ type(ESMF_Field) :: lfield
+ type(ESMF_Field) :: field_fracsrc
+ type(ESMF_Field), pointer :: fieldlist_src(:) => null()
+ type(ESMF_Field), pointer :: fieldlist_dst(:) => null()
+ type(ESMF_Field) :: usrc, vsrc ! only used for 3d mapping of u,v
+ type(ESMF_Field) :: udst, vdst ! only used for 3d mapping of u,v
+ real(r8), pointer :: data_norm(:) => null()
+ real(r8), pointer :: data_dst(:,:) => null()
+ character(len=*), parameter :: subname=' (module_MED_map:med_map_field_packed) '
+ !-----------------------------------------------------------
- ! copy data_src to data_srctmp then multiply data_src by fraction
- if (lrank == 1) then
- data_srctmp_1d(:) = data_src_1d(:)
- data_src_1d(:) = data_src_1d(:) * data_frac(:)
- elseif (lrank == 2) then
- if (size(data_frac) /= size(data_src_2d,dim=2)) then
- write(6,*)'ERROR: size(frac) = ',size(data_frac)
- write(6,*)'ERROR: size(data_src_2d,dim=1),size(data_src_2d,dim=2) = ',&
- size(data_src_2d,dim=1),size(data_src_2d,dim=2)
- call ESMF_LogWrite(trim(subname)//" fldname= "//trim(fldname)//&
- "size of frac not equal to size of distributed data", &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
- rc = ESMF_FAILURE
- return
- end if
- data_srctmp_2d(:,:) = data_src_2d(:,:)
- do i = 1,size(data_frac)
- data_src_2d(:,i) = data_src_2d(:,i) * data_frac(i)
- end do
- end if
+ call t_startf('MED:'//subname)
+ rc = ESMF_SUCCESS
- ! regrid field with name fldname from FBsrc to FBDst
- call med_map_Field_Regrid (srcfield, dstfield, RouteHandles, mapindex, subname//trim(fldname), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! Get field count for both FBsrc and FBdst
+ call ESMF_FieldBundleGet(FBsrc, fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
- ! restore original value
- if (lrank == 1) then
- data_src_1d(:) = data_srctmp_1d(:)
- elseif (lrank == 2) then
- data_src_2d(:,:) = data_srctmp_2d(:,:)
- end if
+ allocate(fieldlist_src(fieldcount))
+ call ESMF_FieldBundleGet(FBsrc, fieldlist=fieldlist_src, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
- ! regrid fraction from source to dest
- if (.not. ESMF_FieldIsCreated(frac_field_dst)) then
- ! get fraction field on source mesh
- call ESMF_FieldBundleGet(FBFracSrc, mapnorm, field=frac_field_src, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist_dst(fieldcount))
+ call ESMF_FieldBundleGet(FBdst, fieldlist=fieldlist_dst, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
- ! create fraction field on destination mesh
- call ESMF_FieldBundleGet(FBDst, fldname, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, mesh=lmesh, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- frac_field_dst = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, name=mapnorm, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! Loop over mapping types
+ do mapindex = 1,nmappers
- ! regrid fraction field from source to destination
- call med_map_Field_Regrid(frac_field_src, frac_field_dst, RouteHandles, mapindex, subname//trim(fldname), rc=rc)
+ ! If packed field is created
+ if (ESMF_FieldIsCreated(packed_data(mapindex)%field_src)) then
- ! get pointer to mapped fraction
- call ESMF_FieldGet(frac_field_dst, farrayPtr=data_norm, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
+ ! -----------------------------------
+ ! Copy the src fields into the packed field bundle
+ ! -----------------------------------
- ! normalize destination mapped values by the reciprocal of the mapped fraction
- call norm_field_dest(trim(fldname), dstfield, data_norm, rc)
+ call t_startf('MED:'//trim(subname)//' copy from src')
- if (dbug_flag > 1) then
- call FB_Field_diagnose(FBDst, fldname, " --> after frac: ", rc=rc)
+ ! First get the pointer for the packed source data
+ call ESMF_FieldGet(packed_data(mapindex)%field_src, farrayptr=dataptr2d_packed, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ ! Now do the copy
+ do nf = 1,fieldcount
+ ! Get the indices into the packed data structure
+ np = packed_data(mapindex)%fldindex(nf)
+ if (np > 0) then
+ call ESMF_FieldGet(fieldlist_src(nf), ungriddedUBound=ungriddedUBound, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUBound(1) > 0) then
+ call ESMF_FieldGet(fieldlist_src(nf), farrayptr=dataptr2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do nu = 1,ungriddedUBound(1)
+ dataptr2d_packed(np+nu-1,:) = dataptr2d(nu,:)
+ end do
+ else
+ call ESMF_FieldGet(fieldlist_src(nf), farrayptr=dataptr1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr2d_packed(np,:) = dataptr1d(:)
+ end if
end if
+ end do
+ call t_stopf('MED:'//trim(subname)//' copy from src')
- else if (trim(mapnorm) == 'one' .or. trim(mapnorm) == 'none') then
+ ! -----------------------------------
+ ! Do the mapping
+ ! -----------------------------------
- !-------------------------------------------------
- ! unity or no normalization
- !-------------------------------------------------
+ call t_startf('MED:'//trim(subname)//' map')
- ! map source field to destination grid
- call med_map_Field_Regrid (srcfield, dstfield, RouteHandles, mapindex, subname//trim(fldname), rc=rc)
+ if (mapindex == mappatch_uv3d) then
+
+ ! for mappatch_uv3d do not use packed field bundles
+ call ESMF_FieldBundleGet(FBSrc, fieldName='Sa_u', field=usrc, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(FBSrc, fieldName='Sa_v', field=vsrc, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(FBDst, fieldName='Sa_u', field=udst, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(FBDst, fieldName='Sa_v', field=vdst, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_map_uv_cart3d(usrc, vsrc, udst, vdst, routehandles, mappatch, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! obtain unity normalization factor and multiply interpolated field by reciprocal of normalization factor
- if (trim(mapnorm) == 'one') then
- call ESMF_FieldBundleGet(FBNormOne(mapindex), fieldName='one', field=lfield, rc=rc)
+ else if (mapindex == mapfcopy) then
+
+ ! Mapping is redistribution
+ call ESMF_FieldRedist(&
+ packed_data(mapindex)%field_src, &
+ packed_data(mapindex)%field_dst, &
+ routehandles(mapindex), rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ else if ( trim(packed_data(mapindex)%mapnorm) /= 'unset' .and. &
+ trim(packed_data(mapindex)%mapnorm) /= 'one' .and. &
+ trim(packed_data(mapindex)%mapnorm) /= 'none') then
+
+ ! Normalized mapping - assume that each packed field has only one normalization type
+ call ESMF_FieldBundleGet(FBFracSrc, packed_data(mapindex)%mapnorm, field=field_fracsrc, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_map_field_normalized(&
+ field_src=packed_data(mapindex)%field_src, &
+ field_dst=packed_data(mapindex)%field_dst, &
+ routehandles=routehandles, &
+ maptype=mapindex, &
+ field_normsrc=field_fracsrc, &
+ field_normdst=packed_data(mapindex)%field_fracdst, rc=rc)
+
+ else if ( trim(packed_data(mapindex)%mapnorm) == 'one' .or. trim(packed_data(mapindex)%mapnorm) == 'none') then
+
+ ! Mapping with no normalization that is not redistribution
+ call med_map_field (&
+ field_src=packed_data(mapindex)%field_src, &
+ field_dst=packed_data(mapindex)%field_dst, &
+ routehandles=routehandles, &
+ maptype=mapindex, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ ! Obtain unity normalization factor and multiply
+ ! interpolated field by reciprocal of normalization factor
+ if (trim(packed_data(mapindex)%mapnorm) == 'one') then
+ call ESMF_FieldGet(field_normOne(mapindex), farrayPtr=data_norm, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, farrayPtr=data_norm, rc=rc)
+ call ESMF_FieldGet(packed_data(mapindex)%field_dst, farrayPtr=data_dst, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,size(data_dst,dim=2)
+ if (data_norm(n) == 0.0_r8) then
+ data_dst(:,n) = 0.0_r8
+ else
+ data_dst(:,n) = data_dst(:,n)/data_norm(n)
+ end if
+ end do
+ end if
+
+ end if
+ call t_stopf('MED:'//trim(subname)//' map')
- call norm_field_dest(trim(fldname), dstfield, data_norm, rc)
- end if ! mapnorm is 'one'
+ ! -----------------------------------
+ ! Copy the destination packed field bundle into the destination unpacked field bundle
+ ! -----------------------------------
- end if ! mapnorm is 'one' or 'nne'
- end if ! mapindex is not mapfcopy and field exists
+ call t_startf('MED:'//trim(subname)//' copy to dest')
- if (dbug_flag > 1) then
- call FB_Field_diagnose(FBDst, fldname, &
- string=trim(subname) //' FBImp('//trim(compname(srccomp))//','//trim(compname(destcomp))//') ', rc=rc)
+ ! First get the pointer for the packed destination data
+ call ESMF_FieldGet(packed_data(mapindex)%field_dst, farrayptr=dataptr2d_packed, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
- end do ! loop over fields
+ ! Now do the copy back to FBDst
+ do nf = 1,fieldcount
+ ! Get the indices into the packed data structure
+ np = packed_data(mapindex)%fldindex(nf)
+ if (np > 0) then
+ call ESMF_FieldGet(fieldlist_dst(nf), ungriddedUBound=ungriddedUBound, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUBound(1) > 0) then
+ call ESMF_FieldGet(fieldlist_dst(nf), farrayptr=dataptr2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do nu = 1,ungriddedUBound(1)
+ dataptr2d(nu,:) = dataptr2d_packed(np+nu-1,:)
+ end do
+ else
+ call ESMF_FieldGet(fieldlist_dst(nf), farrayptr=dataptr1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr1d(:) = dataptr2d_packed(np,:)
+ end if
+ end if
+ end do
+ call t_stopf('MED:'//trim(subname)//' copy to dest')
- if (ESMF_FieldIsCreated(frac_field_dst)) then
- call ESMF_FieldDestroy(frac_field_dst, noGarbage=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
- if (allocated(data_srctmp)) deallocate(data_srctmp)
+ end if
+ end do ! end of loop over mapindex
+
+ deallocate(fieldlist_src)
+ deallocate(fieldlist_dst)
call t_stopf('MED:'//subname)
- end subroutine med_map_FB_Regrid_Norm_All
+ end subroutine med_map_field_packed
!================================================================================
+ subroutine med_map_field_normalized(field_src, field_dst, routehandles, maptype, &
+ field_normsrc, field_normdst, rc)
- subroutine med_map_FB_Field_Regrid(FBin,fldin,FBout,fldout,RouteHandles,mapindex,rc)
+ ! -----------------------------------------------
+ ! Map a normalized field
+ ! -----------------------------------------------
- ! ----------------------------------------------
- ! Regrid a field in a field bundle to another field in a field bundle
- ! ----------------------------------------------
+ use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_RouteHandle
+ use ESMF , only : ESMF_SUCCESS
- use ESMF , only : ESMF_FieldBundle, ESMF_RouteHandle, ESMF_Field
- use perf_mod , only : t_startf, t_stopf
-
- type(ESMF_FieldBundle), intent(in) :: FBin
- character(len=*) , intent(in) :: fldin
- type(ESMF_FieldBundle), intent(inout) :: FBout
- character(len=*) , intent(in) :: fldout
- type(ESMF_RouteHandle), intent(inout) :: RouteHandles(:)
- integer , intent(in) :: mapindex
- integer , intent(out) :: rc
- ! ----------------------------------------------
-
- ! local
- type(ESMF_Field) :: field1, field2
- character(CS) :: lfldname
- character(len=*),parameter :: subname='(med_map_FB_Field_Regrid)'
- ! ----------------------------------------------
+ ! input/output variables
+ type(ESMF_Field) , intent(in) :: field_src
+ type(ESMF_Field) , intent(inout) :: field_dst
+ type(ESMF_Field) , intent(in) :: field_normsrc
+ type(ESMF_Field) , intent(inout) :: field_normdst
+ type(ESMF_RouteHandle) , intent(inout) :: routehandles(:)
+ integer , intent(in) :: maptype
+ integer , intent(out) :: rc
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": start", ESMF_LOGMSG_INFO)
- endif
+ ! local variables
+ integer :: n
+ real(r8), pointer :: data_src2d(:,:) => null()
+ real(r8), pointer :: data_dst2d(:,:) => null()
+ real(r8), pointer :: data_srctmp2d(:,:) => null()
+ real(r8), pointer :: data_src1d(:) => null()
+ real(r8), pointer :: data_dst1d(:) => null()
+ real(r8), pointer :: data_srctmp1d(:) => null()
+ real(r8), pointer :: data_normsrc(:) => null()
+ real(r8), pointer :: data_normdst(:) => null()
+ integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields
+ integer :: lsize_src
+ integer :: lsize_dst
+ character(len=*), parameter :: subname=' (module_MED_map:med_map_field_normalized) '
+ !-----------------------------------------------------------
- call t_startf(subname)
rc = ESMF_SUCCESS
- lfldname=trim(fldin)//'->'//trim(fldout)
+ ! get a pointer (data_fracsrc) to the normalization array
+ ! get a pointer (data_src) to source field data in FBSrc
+ ! copy data_src to data_srctmp
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
+ ! normalize data_src by data_fracsrc
- if (FB_FldChk(FBin , trim(fldin) , rc=rc) .and. &
- FB_FldChk(FBout, trim(fldout), rc=rc)) then
+ call ESMF_FieldGet(field_normsrc, farrayPtr=data_normsrc, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ lsize_src = size(data_normsrc)
- call FB_GetFieldByName(FBin, trim(fldin), field1, rc=rc)
+ call ESMF_FieldGet(field_src, ungriddedUBound=ungriddedUBound, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUbound(1) > 0) then
+ call ESMF_FieldGet(field_src, farrayPtr=data_src2d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_GetFieldByName(FBout, trim(fldout), field2, rc=rc)
+ allocate(data_srctmp2d(size(data_src2d,dim=1), lsize_src))
+ data_srctmp2d(:,:) = data_src2d(:,:)
+ do n = 1,lsize_src
+ data_src2d(:,n) = data_src2d(:,n) * data_normsrc(n)
+ end do
+ else
+ call ESMF_FieldGet(field_src, farrayPtr=data_src1d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ allocate(data_srctmp1d(lsize_src))
+ data_srctmp1d(:) = data_src1d(:)
+ do n = 1,lsize_src
+ data_src1d(n) = data_src1d(n) * data_normsrc(n)
+ end do
+ end if
- call med_map_Field_Regrid(field1, field2, RouteHandles, mapindex, subname//trim(lfldname), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! regrid normalized packed source field
+ call med_map_field (field_src=field_src, field_dst=field_dst, routehandles=routehandles, maptype=maptype, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ ! restore original value to packed source field
+ if (ungriddedUbound(1) > 0) then
+ data_src2d(:,:) = data_srctmp2d(:,:)
+ deallocate(data_srctmp2d)
else
- call ESMF_LogWrite(trim(subname)//" field not found: "//&
- trim(fldin)//","//trim(fldout), ESMF_LOGMSG_INFO)
- endif
+ data_src1d(:) = data_srctmp1d(:)
+ deallocate(data_srctmp1d)
+ end if
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
- call t_stopf(subname)
+ ! regrid normalization field from source to destination
+ call med_map_field(field_src=field_normsrc, field_dst=field_normdst, routehandles=routehandles, maptype=maptype, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
- end subroutine med_map_FB_Field_Regrid
+ ! get pointer to mapped fraction and normalize
+ ! destination mapped values by the reciprocal of the mapped fraction
+ call ESMF_FieldGet(field_normdst, farrayPtr=data_normdst, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ lsize_dst = size(data_normdst)
- !================================================================================
+ if (ungriddedUbound(1) > 0) then
+ call ESMF_FieldGet(field_dst, farrayPtr=data_dst2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,lsize_dst
+ if (data_normdst(n) == 0.0_r8) then
+ data_dst2d(:,n) = 0.0_r8
+ else
+ data_dst2d(:,n) = data_dst2d(:,n)/data_normdst(n)
+ end if
+ end do
+ else
+ call ESMF_FieldGet(field_dst, farrayPtr=data_dst1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,lsize_dst
+ if (data_normdst(n) == 0.0_r8) then
+ data_dst1d(n) = 0.0_r8
+ else
+ data_dst1d(n) = data_dst1d(n)/data_normdst(n)
+ end if
+ end do
+ end if
+ end subroutine med_map_field_normalized
- subroutine med_map_Field_Regrid (srcfield, dstfield, RouteHandles, mapindex, fldname, rc)
+ !================================================================================
+ subroutine med_map_field(field_src, field_dst, routehandles, maptype, fldname, rc)
!---------------------------------------------------
! map the source field to the destination field
!---------------------------------------------------
- use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR
- use ESMF , only : ESMF_Field, ESMF_FieldRegrid
- use ESMF , only : ESMF_TERMORDER_SRCSEQ, ESMF_Region_Flag, ESMF_REGION_TOTAL
- use ESMF , only : ESMF_REGION_SELECT
- use ESMF , only : ESMF_RouteHandle
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
+ use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_FAILURE, ESMF_MAXSTR
+ use ESMF , only : ESMF_Field, ESMF_FieldRegrid
+ use ESMF , only : ESMF_TERMORDER_SRCSEQ, ESMF_Region_Flag, ESMF_REGION_TOTAL
+ use ESMF , only : ESMF_REGION_SELECT
+ use ESMF , only : ESMF_RouteHandle
+ use esmFlds , only : mapnstod_consd, mapnstod_consf, mapnstod_consd, mapnstod
+ use esmFlds , only : mapconsd, mapconsf
+ use med_methods_mod , only : Field_diagnose => med_methods_Field_diagnose
! input/output variables
- type(ESMF_Field) , intent(in) :: srcfield
- type(ESMF_Field) , intent(inout) :: dstfield
- type(ESMF_RouteHandle) , intent(inout) :: RouteHandles(:)
- integer , intent(in) :: mapindex
+ type(ESMF_Field) , intent(in) :: field_src
+ type(ESMF_Field) , intent(inout) :: field_dst
+ type(ESMF_RouteHandle) , intent(inout) :: routehandles(:)
+ integer , intent(in) :: maptype
character(len=*) , intent(in), optional :: fldname
- integer , intent(out) :: rc
+ integer , intent(out) :: rc
! local variables
logical :: checkflag = .false.
character(len=CS) :: lfldname
- character(len=*), parameter :: subname='(module_MED_Map:med_map_Field_Regrid)'
+ character(len=*), parameter :: subname='(module_MED_map:med_map_field) '
!---------------------------------------------------
rc = ESMF_SUCCESS
@@ -1049,136 +1116,61 @@ subroutine med_map_Field_Regrid (srcfield, dstfield, RouteHandles, mapindex, fld
checkflag = .true.
#endif
lfldname = 'unknown'
- if (present(fldname)) then
- lfldname = trim(fldname)
- endif
+ if (present(fldname)) lfldname = trim(fldname)
- if (mapindex == mapnstod_consd) then
- call ESMF_FieldRegrid(srcfield, dstfield, routehandle=RouteHandles(mapnstod), &
+ if (maptype == mapnstod_consd) then
+ call ESMF_FieldRegrid(field_src, field_dst, routehandle=RouteHandles(mapnstod), &
termorderflag=ESMF_TERMORDER_SRCSEQ, checkflag=checkflag, zeroregion=ESMF_REGION_TOTAL, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 1) then
- call Field_diagnose(dstfield, lfldname, " --> after nstod: ", rc=rc)
+ call Field_diagnose(field_dst, lfldname, " --> after nstod: ", rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- call ESMF_FieldRegrid(srcfield, dstfield, routehandle=RouteHandles(mapconsd), &
+ call ESMF_FieldRegrid(field_src, field_dst, routehandle=RouteHandles(mapconsd), &
termorderflag=ESMF_TERMORDER_SRCSEQ, checkflag=checkflag, zeroregion=ESMF_REGION_SELECT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 1) then
- call Field_diagnose(dstfield, lfldname, " --> after consd: ", rc=rc)
+ call Field_diagnose(field_dst, lfldname, " --> after consd: ", rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- else if (mapindex == mapnstod_consf) then
- call ESMF_FieldRegrid(srcfield, dstfield, routehandle=RouteHandles(mapnstod), &
+ else if (maptype == mapnstod_consf) then
+ call ESMF_FieldRegrid(field_src, field_dst, routehandle=RouteHandles(mapnstod), &
termorderflag=ESMF_TERMORDER_SRCSEQ, checkflag=checkflag, zeroregion=ESMF_REGION_TOTAL, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 1) then
- call Field_diagnose(dstfield, lfldname, " --> after nstod: ", rc=rc)
+ call Field_diagnose(field_dst, lfldname, " --> after nstod: ", rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- call ESMF_FieldRegrid(srcfield, dstfield, routehandle=RouteHandles(mapconsf), &
+ call ESMF_FieldRegrid(field_src, field_dst, routehandle=RouteHandles(mapconsf), &
termorderflag=ESMF_TERMORDER_SRCSEQ, checkflag=checkflag, zeroregion=ESMF_REGION_SELECT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 1) then
- call Field_diagnose(dstfield, lfldname, " --> after consf: ", rc=rc)
+ call Field_diagnose(field_dst, lfldname, " --> after consf: ", rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
else
- call ESMF_FieldRegrid(srcfield, dstfield, routehandle=RouteHandles(mapindex), &
+ call ESMF_FieldRegrid(field_src, field_dst, routehandle=RouteHandles(maptype), &
termorderflag=ESMF_TERMORDER_SRCSEQ, checkflag=checkflag, zeroregion=ESMF_REGION_TOTAL, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- end subroutine med_map_Field_Regrid
-
- !================================================================================
-
- subroutine norm_field_dest (fldname, dstfield, frac, rc)
-
- use ESMF , only : ESMF_Field, ESMF_FieldGet
-
- !------------------------------------------------
- ! normalize destination mapped values by the reciprocal of the
- ! mapped fraction or 'one'
- ! ------------------------------------------------
-
- ! input/output variables
- character(len=*) , intent(in) :: fldname
- type(ESMF_Field) , intent(inout) :: dstfield
- real(r8) , intent(in) :: frac(:)
- integer , intent(out) :: rc
-
- ! local variables
- integer :: i,n
- integer :: lrank
- real(R8), pointer :: data1d(:)
- real(R8), pointer :: data2d(:,:)
- 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
-
- ! ------------------------------------------------
-
- rc = ESMF_SUCCESS
-
- call ESMF_FieldGet(dstfield, rank=lrank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (lrank == 1) then
- call ESMF_FieldGet(dstfield, farrayPtr=data1d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- do i= 1,size(data1d)
- if (frac(i) == 0.0_R8) then
- data1d(i) = 0.0_R8
- else
- data1d(i) = data1d(i)/frac(i)
- endif
- enddo
- else if (lrank == 2) then
- call ESMF_FieldGet(dstfield, ungriddedUBound=ungriddedUBound, gridToFieldMap=gridToFieldMap, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(dstfield, farrayPtr=data2d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- do n = 1,ungriddedUbound(1)
- if (gridToFieldMap(1) == 1) then
- do i = 1,size(data2d,dim=1)
- if (frac(i) == 0.0_r8) then
- data2d(i,n) = 0.0_r8
- else
- data2d(i,n) = data2d(i,n)/frac(i)
- end if
- end do
- else if (gridToFieldMap(1) == 2) then
- do i = 1,size(data2d,dim=2)
- if (frac(i) == 0.0_r8) then
- data2d(n,i) = 0.0_r8
- else
- data2d(n,i) = data2d(n,i)/frac(i)
- end if
- end do
- end if
- end do
- end if
-
- call Field_diagnose(dstfield, fldname, " --> after frac: ", rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- end subroutine norm_field_dest
+ end subroutine med_map_field
!================================================================================
+ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, routehandles, mapindex, rc)
- subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
-
- use ESMF, only : ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8
- use ESMF, only : ESMF_Field, ESMF_FieldGet
- use ESMF, only : ESMF_FieldCreate, ESMF_FieldDestroy, ESMF_FieldRegrid
- use ESMF, only : ESMF_RouteHandle, ESMF_TERMORDER_SRCSEQ, ESMF_REGION_TOTAL
+ use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8
+ use ESMF , only : ESMF_Field, ESMF_FieldGet
+ use ESMF , only : ESMF_FieldCreate, ESMF_FieldDestroy, ESMF_FieldRegrid
+ use ESMF , only : ESMF_RouteHandle, ESMF_TERMORDER_SRCSEQ, ESMF_REGION_TOTAL
+ use shr_const_mod , only : shr_const_pi
! input/output variables
type(ESMF_Field) , intent(in) :: usrc
type(ESMF_Field) , intent(in) :: vsrc
type(ESMF_Field) , intent(inout) :: udst
type(ESMF_Field) , intent(inout) :: vdst
- type(ESMF_RouteHandle) , intent(inout) :: RouteHandles(:)
+ type(ESMF_RouteHandle) , intent(inout) :: routehandles(:)
integer , intent(in) :: mapindex
integer , intent(out) :: rc
@@ -1190,28 +1182,23 @@ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
real(r8) :: ux,uy,uz
type(ESMF_Mesh) :: lmesh_src
type(ESMF_Mesh) :: lmesh_dst
- type(ESMF_Field) :: field3d_src
- type(ESMF_Field) :: field3d_dst
- real(r8), pointer :: data_u_src(:)
- real(r8), pointer :: data_u_dst(:)
- real(r8), pointer :: data_v_src(:)
- real(r8), pointer :: data_v_dst(:)
- real(r8), pointer :: data2d_src(:,:)
- real(r8), pointer :: data2d_dst(:,:)
- real(r8), pointer :: ownedElemCoords_src(:)
- real(r8), pointer :: ownedElemCoords_dst(:)
+ real(r8), pointer :: data_u_src(:) => null()
+ real(r8), pointer :: data_u_dst(:) => null()
+ real(r8), pointer :: data_v_src(:) => null()
+ real(r8), pointer :: data_v_dst(:) => null()
+ real(r8), pointer :: data2d_src(:,:) => null()
+ real(r8), pointer :: data2d_dst(:,:) => null()
+ real(r8), pointer :: ownedElemCoords_src(:) => null()
+ real(r8), pointer :: ownedElemCoords_dst(:) => null()
integer :: numOwnedElements
integer :: spatialDim
- logical :: checkflag = .false.
real(r8), parameter :: deg2rad = shr_const_pi/180.0_R8 ! deg to rads
- character(len=*), parameter :: subname='(module_MED_Map:med_map_uv_cart3d)'
+ logical :: first_time = .true.
+ character(len=*), parameter :: subname=' (module_MED_map:med_map_uv_cart3d) '
!-------------------------------------------------------------------------------
rc = ESMF_SUCCESS
- ! Create two field bundles vec_src3d and vec_dst3d that contain
- ! all three fields with undistributed dimensions for each
-
! Get pointer to input u and v data source field data
call ESMF_FieldGet(usrc, farrayPtr=data_u_src, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -1225,7 +1212,7 @@ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
call ESMF_FieldGet(vdst, farrayPtr=data_v_dst, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! get source mesh and coordinates
+ ! Get source mesh and coordinates
call ESMF_FieldGet(usrc, mesh=lmesh_src, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
call ESMF_MeshGet(lmesh_src, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc)
@@ -1234,7 +1221,7 @@ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
call ESMF_MeshGet(lmesh_src, ownedElemCoords=ownedElemCoords_src)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! get destination mesh and coordinates
+ ! Get destination mesh and coordinates
call ESMF_FieldGet(udst, mesh=lmesh_dst, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
call ESMF_MeshGet(lmesh_dst, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc)
@@ -1243,20 +1230,24 @@ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
call ESMF_MeshGet(lmesh_dst, ownedElemCoords=ownedElemCoords_dst)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! create source field and destination fields
- field3d_src = ESMF_FieldCreate(lmesh_src, ESMF_TYPEKIND_R8, name='src3d', &
- ungriddedLbound=(/1/), ungriddedUbound=(/3/), gridToFieldMap=(/2/), &
- meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- field3d_dst = ESMF_FieldCreate(lmesh_dst, ESMF_TYPEKIND_R8, name='dst3d', &
- ungriddedLbound=(/1/), ungriddedUbound=(/3/), gridToFieldMap=(/2/), &
- meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (first_time) then
+ ! Create two module fields - vec_src3d and vec_dst3d - that contain
+ ! all three fields with undistributed dimensions for each
+ uv3d_src = ESMF_FieldCreate(lmesh_src, ESMF_TYPEKIND_R8, name='src3d', &
+ ungriddedLbound=(/1/), ungriddedUbound=(/3/), gridToFieldMap=(/2/), &
+ meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ uv3d_dst = ESMF_FieldCreate(lmesh_dst, ESMF_TYPEKIND_R8, name='dst3d', &
+ ungriddedLbound=(/1/), ungriddedUbound=(/3/), gridToFieldMap=(/2/), &
+ meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ first_time = .false.
+ end if
! get pointers to source and destination data that will be filled in with rotation to cart3d
- call ESMF_FieldGet(field3d_src, farrayPtr=data2d_src, rc=rc)
+ call ESMF_FieldGet(uv3d_src, farrayPtr=data2d_src, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(field3d_dst, farrayPtr=data2d_dst, rc=rc)
+ call ESMF_FieldGet(uv3d_dst, farrayPtr=data2d_dst, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Rotate Source data to cart3d
@@ -1273,7 +1264,8 @@ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
enddo
! Map all thee vector fields at once from source to destination grid
- call med_map_Field_Regrid(field3d_src, field3d_dst, RouteHandles, mapindex, subname, rc=rc)
+ call med_map_field(field_src=uv3d_src, field_dst=uv3d_dst, &
+ routehandles=routehandles, maptype=mapindex, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Rotate destination data back from cart3d to original
@@ -1294,10 +1286,6 @@ subroutine med_map_uv_cart3d(usrc, vsrc, udst, vdst, RouteHandles, mapindex, rc)
! Deallocate data
deallocate(ownedElemCoords_src)
deallocate(ownedElemCoords_dst)
- call ESMF_FieldDestroy(field3d_src, noGarbage=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldDestroy(field3d_dst, noGarbage=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
end subroutine med_map_uv_cart3d
diff --git a/mediator/med_merge_mod.F90 b/mediator/med_merge_mod.F90
index 9b32f4ff0..8b85a4a86 100644
--- a/mediator/med_merge_mod.F90
+++ b/mediator/med_merge_mod.F90
@@ -12,10 +12,7 @@ module med_merge_mod
use med_constants_mod , only : czero => med_constants_czero
use med_utils_mod , only : ChkErr => med_utils_ChkErr
use med_methods_mod , only : FB_FldChk => med_methods_FB_FldChk
- use med_methods_mod , only : FB_GetNameN => med_methods_FB_GetNameN
- use med_methods_mod , only : FB_Reset => med_methods_FB_reset
use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
- use med_methods_mod , only : FieldPtr_Compare => med_methods_FieldPtr_Compare
use esmFlds , only : compmed, compname
use esmFlds , only : med_fldList_type
use esmFlds , only : med_fldList_GetNumFlds
@@ -29,8 +26,7 @@ module med_merge_mod
public :: med_merge_field
interface med_merge_field ; module procedure &
- med_merge_field_1D, &
- med_merge_field_2D
+ med_merge_field_1D
end interface
private :: med_merge_auto_field
@@ -42,7 +38,8 @@ module med_merge_mod
contains
!===============================================================================
- subroutine med_merge_auto(compout_name, FBOut, FBfrac, FBImp, fldListTo, FBMed1, FBMed2, rc)
+ subroutine med_merge_auto(compout, coupling_active, FBOut, FBfrac, FBImp, fldListTo, &
+ FBMed1, FBMed2, rc)
use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleIsCreated, ESMF_FieldBundleGet
use ESMF , only : ESMF_Field, ESMF_FieldGet
@@ -55,162 +52,170 @@ subroutine med_merge_auto(compout_name, FBOut, FBfrac, FBImp, fldListTo, FBMed1,
! ----------------------------------------------
! input/output variables
- character(len=*) , intent(in) :: compout_name ! component name for FBOut
- type(ESMF_FieldBundle) , intent(inout) :: FBOut ! Merged output field bundle
- type(ESMF_FieldBundle) , intent(inout) :: FBfrac ! Fraction data for FBOut
- type(ESMF_FieldBundle) , intent(in) :: FBImp(:) ! Array of field bundles each mapping to the FBOut mesh
- type(med_fldList_type) , intent(in) :: fldListTo ! Information for merging
- type(ESMF_FieldBundle) , intent(in) , optional :: FBMed1 ! mediator field bundle
- type(ESMF_FieldBundle) , intent(in) , optional :: FBMed2 ! mediator field bundle
- integer , intent(out) :: rc
+ integer , intent(in) :: compout ! component index for FBOut
+ logical , intent(in) :: coupling_active(:) ! true => coupling is active
+ type(ESMF_FieldBundle) , intent(inout) :: FBOut ! Merged output field bundle
+ type(ESMF_FieldBundle) , intent(inout) :: FBfrac ! Fraction data for FBOut
+ type(ESMF_FieldBundle) , intent(in) :: FBImp(:) ! Array of field bundles each mapping to the FBOut mesh
+ type(med_fldList_type) , intent(in) :: fldListTo ! Information for merging
+ type(ESMF_FieldBundle) , intent(in) , optional :: FBMed1 ! mediator field bundle
+ type(ESMF_FieldBundle) , intent(in) , optional :: FBMed2 ! mediator field bundle
+ integer , intent(out) :: rc
! local variables
- integer :: cnt
- integer :: n,nf,nm,compsrc
- character(CX) :: fldname, stdname
- character(CX) :: merge_fields
- character(CX) :: merge_field
- character(CS) :: merge_type
- character(CS) :: merge_fracname
+ integer :: nfld_out,nfld_in,nm
+ integer :: compsrc
+ integer :: num_merge_fields
+ integer :: num_merge_colon_fields
+ character(CL) :: merge_fields
+ character(CL) :: merge_field
+ character(CS) :: merge_type
+ character(CS) :: merge_fracname
+ character(CS), allocatable :: merge_field_names(:)
+ logical :: error_check = .false. ! TODO: make this an input argument
+ integer :: ungriddedUBound_out(1) ! size of ungridded dimension
+ integer :: fieldcount
+ character(CL) , pointer :: fieldnamelist(:) => null()
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
+ real(r8), pointer :: dataptr1d(:) => null()
+ real(r8), pointer :: dataptr2d(:,:) => null()
+ character(CL) :: msg
character(len=*),parameter :: subname=' (module_med_merge_mod: med_merge_auto)'
!---------------------------------------
+
call t_startf('MED:'//subname)
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
rc = ESMF_SUCCESS
- call FB_reset(FBOut, value=czero, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ if (dbug_flag > 1) then
+ call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
+ rc = ESMF_SUCCESS
+ end if
+
+ call ESMF_FieldBundleGet(FBOut, fieldCount=fieldcount, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldnamelist(fieldcount))
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(FBOut, fieldnamelist=fieldnamelist, fieldlist=fieldlist, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ num_merge_fields = med_fldList_GetNumFlds(fldListTo)
+ allocate(merge_field_names(num_merge_fields))
+ do nfld_in = 1,num_merge_fields
+ call med_fldList_GetFldInfo(fldListTo, nfld_in, merge_field_names(nfld_in))
+ end do
! Want to loop over all of the fields in FBout here - and find the corresponding index in fldListTo(compxxx)
! for that field name - then call the corresponding merge routine below appropriately
- call ESMF_FieldBundleGet(FBOut, fieldCount=cnt, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
! Loop over all fields in field bundle FBOut
- do n = 1,cnt
+ do nfld_out = 1,fieldcount
- ! Get the nth field name in FBexp
- call FB_getNameN(FBOut, n, fldname, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ ! Initialize initial output field data to zero
+ call ESMF_FieldGet(fieldlist(nfld_out), ungriddedUBound=ungriddedUbound_out, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUBound_out(1) > 0) then
+ call ESMF_FieldGet(fieldlist(nfld_out), farrayPtr=dataptr2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr2d(:,:) = czero
+ else
+ call ESMF_FieldGet(fieldlist(nfld_out), farrayPtr=dataptr1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr1d(:) = czero
+ end if
! Loop over the field in fldListTo
- do nf = 1,med_fldList_GetNumFlds(fldListTo)
+ do nfld_in = 1,med_fldList_GetNumFlds(fldListTo)
- ! Determine if if there is a match of the fldList field name with the FBOut field name
- call med_fldList_GetFldInfo(fldListTo, nf, stdname)
-
- if (trim(stdname) == trim(fldname)) then
+ if (trim(merge_field_names(nfld_in)) == trim(fieldnamelist(nfld_out))) then
! Loop over all possible source components in the merging arrays returned from the above call
! If the merge field name from the source components is not set, then simply go to the next component
do compsrc = 1,size(FBImp)
- ! Determine the merge information for the import field
- call med_fldList_GetFldInfo(fldListTo, nf, compsrc, merge_fields, merge_type, merge_fracname)
+ ! Cycle if coupling is not active or mediator input is not present and compsrc is mediator
+ if (compsrc == compmed) then
+ if (.not. present(FBMed1) .and. .not. present(FBMed2)) then
+ CYCLE
+ end if
+ else if (.not. coupling_active(compsrc)) then
+ CYCLE
+ end if
- ! If merge_field is a colon delimited string then cycle through every field - otherwise by default nm
- ! will only equal 1
- do nm = 1,merge_listGetNum(merge_fields)
-
- call merge_listGetName(merge_fields, nm, merge_field, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
- if (merge_type /= 'unset' .and. merge_field /= 'unset') then
+ ! Determine the merge information for the import field
+ call med_fldList_GetFldInfo(fldListTo, nfld_in, compsrc, merge_fields, merge_type, merge_fracname)
+
+ if (merge_type /= 'unset' .and. merge_field /= 'unset') then
+
+ ! If merge_field is a colon delimited string then cycle through every field - otherwise by default nm
+ ! will only equal 1
+ num_merge_colon_fields = merge_listGetNum(merge_fields)
+ do nm = 1,num_merge_colon_fields
+
+ ! Determine merge field name from source field
+ if (num_merge_fields == 1) then
+ merge_field = trim(merge_fields)
+ else
+ call merge_listGetName(merge_fields, nm, merge_field, rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+
+ ! Perform error checks
+ if (error_check) then
+ call med_merge_auto_errcheck(compsrc, fieldnamelist(nfld_out), fieldlist(nfld_out), &
+ ungriddedUBound_out, trim(merge_field), FBImp(compsrc), &
+ FBMed1=FBMed1, FBMed2=FBMed2, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if ! end of error check
! Perform merge
- if (compsrc == compmed) then
-
- if (present(FBMed1) .and. present(FBMed2)) then
- if (.not. ESMF_FieldBundleIsCreated(FBMed1)) then
- call ESMF_LogSetError(ESMF_RC_OBJ_NOT_CREATED, &
- msg="Field bundle FBMed1 not created.", &
- line=__LINE__, file=u_FILE_u, rcToReturn=rc)
- return
- endif
- if (.not. ESMF_FieldBundleIsCreated(FBMed2)) then
- call ESMF_LogSetError(ESMF_RC_OBJ_NOT_CREATED, &
- msg="Field bundle FBMed2 not created.", &
- line=__LINE__, file=u_FILE_u, rcToReturn=rc)
- return
- endif
- if (FB_FldChk(FBMed1, trim(merge_field), rc=rc)) then
- call med_merge_auto_field(trim(merge_type), &
- FBOut, fldname, FB=FBMed1, FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
- else if (FB_FldChk(FBMed2, trim(merge_field), rc=rc)) then
- call med_merge_auto_field(trim(merge_type), &
- FBOut, fldname, FB=FBMed2, FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
- else
- call ESMF_LogWrite(trim(subname)//": ERROR merge_field = "//trim(merge_field)//" not found", &
- ESMF_LOGMSG_ERROR, rc=rc)
- rc = ESMF_FAILURE
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
-
- elseif (present(FBMed1)) then
- if (.not. ESMF_FieldBundleIsCreated(FBMed1)) then
- call ESMF_LogSetError(ESMF_RC_OBJ_NOT_CREATED, &
- msg="Field bundle FBMed1 not created.", &
- line=__LINE__, file=u_FILE_u, rcToReturn=rc)
- return
- endif
- if (FB_FldChk(FBMed1, trim(merge_field), rc=rc)) then
- call med_merge_auto_field(trim(merge_type), &
- FBOut, fldname, FB=FBMed1, FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
- else
- call ESMF_LogWrite(trim(subname)//": ERROR merge_field = "//trim(merge_field)//"not found", &
- ESMF_LOGMSG_ERROR, rc=rc)
- rc = ESMF_FAILURE
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- end if
-
- else if (ESMF_FieldBundleIsCreated(FBImp(compsrc), rc=rc)) then
- if (FB_FldChk(FBImp(compsrc), trim(merge_field), rc=rc)) then
- call med_merge_auto_field(trim(merge_type), &
- FBOut, fldname, FB=FBImp(compsrc), FBFld=merge_field, &
- FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
+ if ((present(FBMed1) .or. present(FBMed2)) .and. compsrc == compmed) then
+ if (FB_FldChk(FBMed1, trim(merge_field), rc=rc)) then
+ call med_merge_auto_field(trim(merge_type), fieldlist(nfld_out), ungriddedUBound_out, &
+ FB=FBMed1, FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ else if (FB_FldChk(FBMed2, trim(merge_field), rc=rc)) then
+ call med_merge_auto_field(trim(merge_type), fieldlist(nfld_out), ungriddedUBound_out, &
+ FB=FBMed2, FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
-
- end if ! end of single merge
-
- end if ! end of check of merge_type and merge_field not unset
- end do ! end of nmerges loop
+ else
+ call med_merge_auto_field(trim(merge_type), fieldlist(nfld_out), ungriddedUBound_out, &
+ FB=FBImp(compsrc), FBFld=merge_field, FBw=FBfrac, fldw=trim(merge_fracname), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+
+ end do ! end of nm loop
+ end if ! end of check of merge_type and merge_field not unset
end do ! end of compsrc loop
end if ! end of check if stdname and fldname are the same
end do ! end of loop over fldsListTo
end do ! end of loop over fields in FBOut
- !---------------------------------------
- !--- clean up
- !---------------------------------------
+ deallocate(fieldnamelist)
+ deallocate(fieldlist)
+
+ if (dbug_flag > 1) then
+ call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
+ end if
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
call t_stopf('MED:'//subname)
end subroutine med_merge_auto
!===============================================================================
-
- subroutine med_merge_auto_field(merge_type, FBout, FBoutfld, FB, FBfld, FBw, fldw, rc)
+ subroutine med_merge_auto_field(merge_type, field_out, ungriddedUBound_out, &
+ FB, FBfld, FBw, fldw, rc)
use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_LogMsg_Error
- use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info
use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info
use ESMF , only : ESMF_FieldGet, ESMF_Field
! input/output variables
character(len=*) ,intent(in) :: merge_type
- type(ESMF_FieldBundle),intent(inout) :: FBout
- character(len=*) ,intent(in) :: FBoutfld
+ type(ESMF_Field) ,intent(inout) :: field_out
+ integer ,intent(in) :: ungriddedUBound_out(1)
type(ESMF_FieldBundle),intent(in) :: FB
character(len=*) ,intent(in) :: FBfld
type(ESMF_FieldBundle),intent(inout) :: FBw ! field bundle with weights
@@ -219,18 +224,11 @@ subroutine med_merge_auto_field(merge_type, FBout, FBoutfld, FB, FBfld, FBw, fld
! local variables
integer :: n
- type(ESMF_Field) :: lfield
- real(R8), pointer :: dp1 (:), dp2(:,:) ! output pointers to 1d and 2d fields
- real(R8), pointer :: dpf1(:), dpf2(:,:) ! intput pointers to 1d and 2d fields
- real(R8), pointer :: dpw1(:) ! weight pointer
- integer :: lrank_input ! rank of input array
- integer :: lrank_output ! rank of output array
- integer :: ungriddedUBound_output(1) ! currently the size must equal 1 for rank 2 fieldds
- integer :: ungriddedUBound_input(1) ! currently the size must equal 1 for rank 2 fieldds
- integer :: gridToFieldMap_output(1) ! currently the size must equal 1 for rank 2 fieldds
- integer :: gridToFieldMap_input(1) ! currently the size must equal 1 for rank 2 fieldds
- character(len=CL) :: errmsg
- character(len=CL) :: msg
+ type(ESMF_Field) :: field_wgt
+ type(ESMF_Field) :: field_in
+ real(R8), pointer :: dp1 (:), dp2(:,:) => null() ! output pointers to 1d and 2d fields
+ real(R8), pointer :: dpf1(:), dpf2(:,:) => null() ! intput pointers to 1d and 2d fields
+ real(R8), pointer :: dpw1(:) => null() ! weight pointer
character(len=*),parameter :: subname=' (med_merge_mod: med_merge)'
!---------------------------------------
@@ -259,115 +257,60 @@ subroutine med_merge_auto_field(merge_type, FBout, FBoutfld, FB, FBfld, FBw, fld
! Get appropriate field pointers
!-------------------------
- ! Get field pointer to output field
- call ESMF_FieldBundleGet(FBout, trim(FBoutfld), field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, rank=lrank_output, rc=rc)
+ ! Get input field
+ call ESMF_FieldBundleGet(FB, FBfld, field=field_in, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (dbug_flag > 1) then
- write(msg,*)trim(subname),'output field ',trim(FBoutfld),' has rank ',lrank_output
- call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO)
- end if
- if (lrank_output == 1) then
- call ESMF_FieldGet(lfield, farrayPtr=dp1, rc=rc)
+ ! Get field pointer to output and input fields
+ ! Assume that input and output ungridded upper bounds are the same - this is checked in error check
+ if (ungriddedUBound_out(1) > 0) then
+ call ESMF_FieldGet(field_in, farrayPtr=dpf2, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- else if (lrank_output == 2) then
- call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound_output, &
- gridToFieldMap=gridToFieldMap_output, rc=rc)
+ call ESMF_FieldGet(field_out, farrayPtr=dp2, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, farrayPtr=dp2, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end if
-
- ! Get field pointer to input field used in the merge
- call ESMF_FieldBundleGet(FB, FBfld, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, rank=lrank_input, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (dbug_flag > 1) then
- write(msg,*)trim(subname),'input field ',trim(FBfld),' has rank ',lrank_input
- call ESMF_LogWrite(msg, ESMF_LOGMSG_INFO)
- end if
-
- if (lrank_input == 1) then
- call ESMF_FieldGet(lfield, farrayPtr=dpf1, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else if (lrank_input == 2) then
- call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound_input, &
- gridToFieldMap=gridToFieldMap_input, rc=rc)
+ else
+ call ESMF_FieldGet(field_in, farrayPtr=dpf1, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, farrayPtr=dpf2, rc=rc)
+ call ESMF_FieldGet(field_out, farrayPtr=dp1, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- ! error checks
- if (lrank_input /= lrank_output) then
- write(errmsg,*) trim(subname),' input field rank ',lrank_input,' for '//trim(FBfld), &
- ' not equal to output field rank ',lrank_output,' for '//trim(FBoutfld)
- call ESMF_LogWrite(errmsg, ESMF_LOGMSG_ERROR)
- rc = ESMF_FAILURE
- return
- else if (lrank_output == 2) then
- if (ungriddedUBound_output(1) /= ungriddedUBound_input(1)) then
- write(errmsg,*) trim(subname),"ungriddedUBound_input (",ungriddedUBound_input(1),&
- ") not equal to ungriddedUBound_output (",ungriddedUBound_output(1),") for "//trim(FBoutfld)
- call ESMF_LogWrite(errmsg, ESMF_LOGMSG_ERROR)
- rc = ESMF_FAILURE
- return
- else if (gridToFieldMap_input(1) /= gridToFieldMap_output(1)) then
- write(errmsg,*) trim(subname),"gridtofieldmap_input (",gridtofieldmap_input(1),&
- ") not equal to gridtofieldmap_output (",gridtofieldmap_output(1),") for "//trim(FBoutfld)
- call ESMF_LogWrite(errmsg, ESMF_LOGMSG_ERROR)
- rc = ESMF_FAILURE
- return
- end if
- endif
-
- ! Get pointer to weights that weights are only rank 1
+ ! Get pointer to weights that weights have no ungridded dimensions
if (merge_type == 'copy_with_weights' .or. merge_type == 'merge' .or. merge_type == 'sum_with_weights') then
- call ESMF_FieldBundleGet(FBw, fieldName=trim(fldw), field=lfield, rc=rc)
+ call ESMF_FieldBundleGet(FBw, fieldName=trim(fldw), field=field_wgt, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, farrayPtr=dpw1, rc=rc)
+ call ESMF_FieldGet(field_wgt, farrayPtr=dpw1, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
endif
! Do supported merges
if (trim(merge_type) == 'copy') then
- if (lrank_output == 1) then
- dp1(:) = dpf1(:)
- else
+ if (ungriddedUBound_out(1) > 0) then
dp2(:,:) = dpf2(:,:)
+ else
+ dp1(:) = dpf1(:)
endif
else if (trim(merge_type) == 'copy_with_weights') then
- if (lrank_output == 1) then
- dp1(:) = dpf1(:)*dpw1(:)
- else
- do n = 1,ungriddedUBound_input(1)
- if (gridToFieldMap_input(1) == 1) then
- dp2(:,n) = dpf2(:,n)*dpw1(:)
- else if (gridToFieldMap_input(1) == 2) then
- dp2(n,:) = dpf2(n,:)*dpw1(:)
- end if
+ if (ungriddedUBound_out(1) > 0) then
+ do n = 1,ungriddedUBound_out(1)
+ dp2(n,:) = dpf2(n,:)*dpw1(:)
end do
+ else
+ dp1(:) = dpf1(:)*dpw1(:)
endif
else if (trim(merge_type) == 'merge' .or. trim(merge_type) == 'sum_with_weights') then
- if (lrank_output == 1) then
- dp1(:) = dp1(:) + dpf1(:)*dpw1(:)
- else
- do n = 1,ungriddedUBound_input(1)
- if (gridToFieldMap_input(1) == 1) then
- dp2(:,n) = dp2(:,n) + dpf2(:,n)*dpw1(:)
- else if (gridToFieldMap_input(1) == 2) then
- dp2(n,:) = dp2(n,:) + dpf2(n,:)*dpw1(:)
- end if
+ if (ungriddedUBound_out(1) > 0) then
+ do n = 1,ungriddedUBound_out(1)
+ dp2(n,:) = dp2(n,:) + dpf2(n,:)*dpw1(:)
end do
+ else
+ dp1(:) = dp1(:) + dpf1(:)*dpw1(:)
endif
else if (trim(merge_type) == 'sum') then
- if (lrank_output == 1) then
- dp1(:) = dp1(:) + dpf1(:)
- else
+ if (ungriddedUBound_out(1) > 0) then
dp2(:,:) = dp2(:,:) + dpf2(:,:)
+ else
+ dp1(:) = dp1(:) + dpf1(:)
endif
else
call ESMF_LogWrite(trim(subname)//": merge type "//trim(merge_type)//" not supported", &
@@ -379,7 +322,79 @@ subroutine med_merge_auto_field(merge_type, FBout, FBoutfld, FB, FBfld, FBw, fld
end subroutine med_merge_auto_field
!===============================================================================
+ subroutine med_merge_auto_errcheck(compsrc, fldname_out, field_out, &
+ ungriddedUBound_out, merge_fldname, FBImp, FBMed1, FBMed2, rc)
+ use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleIsCreated, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_Field, ESMF_FieldGet
+ use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR
+ use ESMF , only : ESMF_LogSetError, ESMF_RC_OBJ_NOT_CREATED
+
+ ! input/output variables
+ integer , intent(in) :: compsrc ! source component index
+ character(len=*) , intent(in) :: fldname_out ! output field name
+ type(ESMF_Field) , intent(in) :: field_out ! output field
+ integer , intent(in) :: ungriddedUBound_out(1) ! ungridded upper bound
+ character(len=*) , intent(in) :: merge_fldname ! source merge fieldname
+ type(ESMF_FieldBundle) , intent(in) :: FBImp ! source field bundle
+ type(ESMF_FieldBundle) , intent(in) , optional :: FBMed1 ! mediator field bundle
+ type(ESMF_FieldBundle) , intent(in) , optional :: FBMed2 ! mediator field bundle
+ integer , intent(out) :: rc
+
+ ! local variables
+ type(ESMF_Field) :: field_in
+ integer :: ungriddedUBound_in(1) ! size of ungridded dimension, if any
+ character(len=CL) :: errmsg
+ character(len=*),parameter :: subname=' (module_med_merge_mod: med_merge_errcheck)'
+ !---------------------------------------
+
+ rc = ESMF_SUCCESS
+
+ if (compsrc == compmed) then
+ if (present(FBMed1) .and. present(FBMed2)) then
+ if (.not. ESMF_FieldBundleIsCreated(FBMed1)) then
+ call ESMF_LogSetError(ESMF_RC_OBJ_NOT_CREATED, msg="Field bundle FBMed1 not created.", &
+ line=__LINE__, file=u_FILE_u, rcToReturn=rc)
+ return
+ endif
+ if (.not. ESMF_FieldBundleIsCreated(FBMed2)) then
+ call ESMF_LogSetError(ESMF_RC_OBJ_NOT_CREATED, msg="Field bundle FBMed2 not created.", &
+ line=__LINE__, file=u_FILE_u, rcToReturn=rc)
+ return
+ endif
+ if (FB_FldChk(FBMed1, trim(merge_fldname), rc=rc)) then
+ call ESMF_FieldBundleGet(FBMed1, trim(merge_fldname), field=field_in, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else if (FB_FldChk(FBMed2, trim(merge_fldname), rc=rc)) then
+ call ESMF_FieldBundleGet(FBMed2, trim(merge_fldname), field=field_in, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ else
+ call ESMF_LogWrite(trim(subname)//": ERROR merge_fldname = "//trim(merge_fldname)//" not found", &
+ ESMF_LOGMSG_ERROR, rc=rc)
+ rc = ESMF_FAILURE
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ end if
+ end if
+ endif
+
+ call ESMF_FieldBundleGet(FBImp, trim(merge_fldname), field=field_in, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_in, ungriddedUBound=ungriddedUBound_in, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ if (ungriddedUbound_in(1) /= UngriddedUbound_out(1)) then
+ write(errmsg,*) trim(subname),' input field ungriddedUbound ',ungriddedUbound_in(1),&
+ ' for '//trim(merge_fldname), &
+ ' not equal to output field ungriddedUbound ',ungriddedUbound_out,' for '//trim(fldname_out)
+ call ESMF_LogWrite(errmsg, ESMF_LOGMSG_ERROR)
+ rc = ESMF_FAILURE
+ return
+ endif
+
+ end subroutine med_merge_auto_errcheck
+
+ !===============================================================================
subroutine med_merge_field_1D(FBout, fnameout, &
FBinA, fnameA, wgtA, &
FBinB, fnameB, wgtB, &
@@ -416,9 +431,9 @@ subroutine med_merge_field_1D(FBout, fnameout, &
integer , intent(out) :: rc
! local variables
- real(R8), pointer :: dataOut(:)
- real(R8), pointer :: dataPtr(:)
- real(R8), pointer :: wgt(:)
+ real(R8), pointer :: dataOut(:) => null()
+ real(R8), pointer :: dataPtr(:) => null()
+ real(R8), pointer :: wgt(:) => null()
integer :: lb1,ub1,i,j,n
logical :: wgtfound, FBinfound
integer :: dbrc
@@ -526,15 +541,14 @@ subroutine med_merge_field_1D(FBout, fnameout, &
endif
if (FBinfound) then
- if (.not.FieldPtr_Compare(dataPtr, dataOut, subname, rc)) then
+ if (lbound(dataPtr,1) /= lbound(dataOut,1) .or. ubound(dataPtr,1) /= ubound(dataOut,1)) then
call ESMF_LogWrite(trim(subname)//": ERROR FBin wrong size", &
ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u, rc=dbrc)
rc = ESMF_FAILURE
return
endif
-
if (wgtfound) then
- if (.not.FieldPtr_Compare(dataPtr, wgt, subname, rc)) then
+ if (lbound(dataPtr,1) /= lbound(wgt,1) .or. ubound(dataPtr,1) /= ubound(wgt,1)) then
call ESMF_LogWrite(trim(subname)//": ERROR wgt wrong size", &
ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u, rc=dbrc)
rc = ESMF_FAILURE
@@ -559,192 +573,6 @@ subroutine med_merge_field_1D(FBout, fnameout, &
end subroutine med_merge_field_1D
!===============================================================================
-
- subroutine med_merge_field_2D(FBout, fnameout, &
- FBinA, fnameA, wgtA, &
- FBinB, fnameB, wgtB, &
- FBinC, fnameC, wgtC, &
- FBinD, fnameD, wgtD, &
- FBinE, fnameE, wgtE, rc)
-
- use ESMF , only : ESMF_FieldBundle, ESMF_LogWrite
- use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_LOGMSG_ERROR
- use ESMF , only : ESMF_LOGMSG_WARNING, ESMF_LOGMSG_INFO
-
- ! ----------------------------------------------
- ! Supports up to a five way merge
- ! ----------------------------------------------
-
- ! input/output arguments
- type(ESMF_FieldBundle) , intent(inout) :: FBout
- character(len=*) , intent(in) :: fnameout
- type(ESMF_FieldBundle) , intent(in) :: FBinA
- character(len=*) , intent(in) :: fnameA
- real(R8) , intent(in), pointer :: wgtA(:,:)
- type(ESMF_FieldBundle) , intent(in), optional :: FBinB
- character(len=*) , intent(in), optional :: fnameB
- real(R8) , intent(in), optional, pointer :: wgtB(:,:)
- type(ESMF_FieldBundle) , intent(in), optional :: FBinC
- character(len=*) , intent(in), optional :: fnameC
- real(R8) , intent(in), optional, pointer :: wgtC(:,:)
- type(ESMF_FieldBundle) , intent(in), optional :: FBinD
- character(len=*) , intent(in), optional :: fnameD
- real(R8) , intent(in), optional, pointer :: wgtD(:,:)
- type(ESMF_FieldBundle) , intent(in), optional :: FBinE
- character(len=*) , intent(in), optional :: fnameE
- real(R8) , intent(in), optional, pointer :: wgtE(:,:)
- integer , intent(out) :: rc
-
- ! local variables
- real(R8), pointer :: dataOut(:,:)
- real(R8), pointer :: dataPtr(:,:)
- real(R8), pointer :: wgt(:,:)
- integer :: lb1,ub1,lb2,ub2,i,j,n
- logical :: wgtfound, FBinfound
- integer :: dbrc
- character(len=*),parameter :: subname='(med_merge_field_2d)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc=ESMF_SUCCESS
-
- if (.not. FB_FldChk(FBout, trim(fnameout), rc=rc)) then
- call ESMF_LogWrite(trim(subname)//": WARNING field not in FBout, skipping merge "//&
- trim(fnameout), ESMF_LOGMSG_WARNING, line=__LINE__, file=u_FILE_u, rc=dbrc)
- return
- endif
-
- call FB_GetFldPtr(FBout, trim(fnameout), fldptr2=dataOut, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- lb1 = lbound(dataOut,1)
- ub1 = ubound(dataOut,1)
- lb2 = lbound(dataOut,2)
- ub2 = ubound(dataOut,2)
-
- dataOut = czero
-
- ! check each field has a fieldname passed in
- if ((present(FBinB) .and. .not.present(fnameB)) .or. &
- (present(FBinC) .and. .not.present(fnameC)) .or. &
- (present(FBinD) .and. .not.present(fnameD)) .or. &
- (present(FBinE) .and. .not.present(fnameE))) then
- call ESMF_LogWrite(trim(subname)//": ERROR fname not present with FBin", &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u, rc=dbrc)
- rc = ESMF_FAILURE
- return
- endif
-
- ! check that each field passed in actually exists, if not DO NOT do any merge
- FBinfound = .true.
- if (present(FBinB)) then
- if (.not. FB_FldChk(FBinB, trim(fnameB), rc=rc)) FBinfound = .false.
- endif
- if (present(FBinC)) then
- if (.not. FB_FldChk(FBinC, trim(fnameC), rc=rc)) FBinfound = .false.
- endif
- if (present(FBinD)) then
- if (.not. FB_FldChk(FBinD, trim(fnameD), rc=rc)) FBinfound = .false.
- endif
- if (present(FBinE)) then
- if (.not. FB_FldChk(FBinE, trim(fnameE), rc=rc)) FBinfound = .false.
- endif
- if (.not. FBinfound) then
- call ESMF_LogWrite(trim(subname)//": WARNING field not found in FBin, skipping merge "//trim(fnameout), &
- ESMF_LOGMSG_WARNING, line=__LINE__, file=u_FILE_u, rc=dbrc)
- return
- endif
-
- ! n=1,5 represents adding A to E inputs if they exist
- do n = 1,5
- FBinfound = .false.
- wgtfound = .false.
-
- if (n == 1) then
- FBinfound = .true.
- call FB_GetFldPtr(FBinA, trim(fnameA), fldptr2=dataPtr, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- wgtfound = .true.
- wgt => wgtA
-
- elseif (n == 2 .and. present(FBinB)) then
- FBinfound = .true.
- call FB_GetFldPtr(FBinB, trim(fnameB), fldptr2=dataPtr, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- if (present(wgtB)) then
- wgtfound = .true.
- wgt => wgtB
- endif
-
- elseif (n == 3 .and. present(FBinC)) then
- FBinfound = .true.
- call FB_GetFldPtr(FBinC, trim(fnameC), fldptr2=dataPtr, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- if (present(wgtC)) then
- wgtfound = .true.
- wgt => wgtC
- endif
-
- elseif (n == 4 .and. present(FBinD)) then
- FBinfound = .true.
- call FB_GetFldPtr(FBinD, trim(fnameD), fldptr2=dataPtr, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- if (present(wgtD)) then
- wgtfound = .true.
- wgt => wgtD
- endif
-
- elseif (n == 5 .and. present(FBinE)) then
- FBinfound = .true.
- call FB_GetFldPtr(FBinE, trim(fnameE), fldptr2=dataPtr, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- if (present(wgtE)) then
- wgtfound = .true.
- wgt => wgtE
- endif
-
- endif
-
- if (FBinfound) then
- if (.not.FieldPtr_Compare(dataPtr, dataOut, subname, rc)) then
- call ESMF_LogWrite(trim(subname)//": ERROR FBin wrong size", &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u, rc=dbrc)
- rc = ESMF_FAILURE
- return
- endif
-
- if (wgtfound) then
- if (.not. FieldPtr_Compare(dataPtr, wgt, subname, rc)) then
- call ESMF_LogWrite(trim(subname)//": ERROR wgt wrong size", &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u, rc=dbrc)
- rc = ESMF_FAILURE
- return
- endif
- do j = lb2,ub2
- do i = lb1,ub1
- dataOut(i,j) = dataOut(i,j) + dataPtr(i,j) * wgt(i,j)
- enddo
- enddo
- else
- do j = lb2,ub2
- do i = lb1,ub1
- dataOut(i,j) = dataOut(i,j) + dataPtr(i,j)
- enddo
- enddo
- endif ! wgtfound
-
- endif ! FBin found
- enddo ! n
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_merge_field_2D
-
- !===============================================================================
-
integer function merge_listGetNum(str)
! return number of fields in a colon delimited string list
@@ -770,7 +598,6 @@ integer function merge_listGetNum(str)
end function merge_listGetNum
!===============================================================================
-
subroutine merge_listGetName(list, k, name, rc)
! Get name of k-th field in colon deliminted list
diff --git a/mediator/med_methods_mod.F90 b/mediator/med_methods_mod.F90
index f63638b46..ed360087f 100644
--- a/mediator/med_methods_mod.F90
+++ b/mediator/med_methods_mod.F90
@@ -7,10 +7,10 @@ module med_methods_mod
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
use ESMF , only : operator(<), operator(/=), operator(+), operator(-), operator(*) , operator(>=)
use ESMF , only : operator(<=), operator(>), operator(==)
- use ESMF , only : ESMF_GeomType_Flag, ESMF_FieldStatus_Flag, ESMF_PoleMethod_Flag
+ use ESMF , only : ESMF_FieldStatus_Flag
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE
use ESMF , only : ESMF_LOGERR_PASSTHRU, ESMF_LogFoundError, ESMF_LOGMSG_ERROR
- use ESMF , only : ESMF_MAXSTR, ESMF_LOGMSG_WARNING, ESMF_POLEMETHOD_ALLAVG
+ use ESMF , only : ESMF_MAXSTR, ESMF_LOGMSG_WARNING
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 : spval_init => med_constants_spval_init
@@ -32,18 +32,12 @@ module med_methods_mod
med_methods_FieldPtr_compare2
end interface
- interface med_methods_UpdateTimestamp; module procedure &
- med_methods_State_UpdateTimestamp, &
- med_methods_Field_UpdateTimestamp
- end interface
-
! used/reused in module
- logical :: isPresent
- character(len=1024) :: msgString
- type(ESMF_GeomType_Flag) :: geomtype
- type(ESMF_FieldStatus_Flag) :: status
- character(*) , parameter :: u_FILE_u = &
+ logical :: isPresent
+ character(len=1024) :: msgString
+ type(ESMF_FieldStatus_Flag) :: status
+ character(*) , parameter :: u_FILE_u = &
__FILE__
public med_methods_FB_copy
@@ -52,132 +46,36 @@ module med_methods_mod
public med_methods_FB_init
public med_methods_FB_init_pointer
public med_methods_FB_reset
- public med_methods_FB_clean
public med_methods_FB_diagnose
public med_methods_FB_FldChk
public med_methods_FB_GetFldPtr
public med_methods_FB_getNameN
public med_methods_FB_getFieldN
- public med_methods_FB_getFieldByName
public med_methods_FB_getNumflds
public med_methods_FB_Field_diagnose
- public med_methods_Field_diagnose
+ public med_methods_FB_GeomPrint
public med_methods_State_reset
public med_methods_State_diagnose
public med_methods_State_GeomPrint
- public med_methods_State_GeomWrite
- public med_methods_State_GetFldPtr
public med_methods_State_SetScalar
public med_methods_State_GetScalar
public med_methods_State_GetNumFields
- public med_methods_State_getFieldN
- public med_methods_State_FldDebug
+ public med_methods_Field_diagnose
public med_methods_Field_GeomPrint
- public med_methods_Clock_TimePrint
- public med_methods_UpdateTimestamp
- public med_methods_Distgrid_Match
public med_methods_FieldPtr_compare
- public med_methods_States_GetSharedFlds
+ public med_methods_Clock_TimePrint
- private med_methods_Grid_Write
- private med_methods_Grid_Print
private med_methods_Mesh_Print
- private med_methods_Mesh_Write
+ private med_methods_Grid_Print
private med_methods_Field_GetFldPtr
- private med_methods_Field_GeomWrite
- private med_methods_Field_UpdateTimestamp
- private med_methods_FB_GeomPrint
- private med_methods_FB_GeomWrite
- private med_methods_FB_RWFields
- private med_methods_FB_SetFldPtr
private med_methods_FB_copyFB2FB
private med_methods_FB_accumFB2FB
- private med_methods_State_UpdateTimestamp
- private med_methods_State_getNameN
- private med_methods_State_getFieldByName
- private med_methods_State_SetFldPtr
private med_methods_Array_diagnose
!-----------------------------------------------------------------------------
contains
!-----------------------------------------------------------------------------
- subroutine med_methods_FB_RWFields(mode,fname,FB,flag,rc)
-
- ! ----------------------------------------------
- ! Read or Write Field Bundles
- ! ----------------------------------------------
- use ESMF, only : ESMF_Field, ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_FieldBundleWrite
- use ESMF, only : ESMF_FieldRead, ESMF_IOFMT_NETCDF, ESMF_FILESTATUS_REPLACE
-
- character(len=*) :: mode
- character(len=*) :: fname
- type(ESMF_FieldBundle) :: FB
- logical,optional :: flag
- integer,optional :: rc
-
- ! local variables
- type(ESMF_Field) :: field
- character(len=ESMF_MAXSTR) :: name
- integer :: fieldcount, n
- logical :: fexists
- character(len=*), parameter :: subname='(med_methods_FB_RWFields)'
- ! ----------------------------------------------
-
- rc = ESMF_SUCCESS
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//trim(fname)//": called", ESMF_LOGMSG_INFO)
- endif
-
- if (mode == 'write') then
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//": write "//trim(fname), ESMF_LOGMSG_INFO)
- end if
- call ESMF_FieldBundleWrite(FB, fname, &
- singleFile=.true., status=ESMF_FILESTATUS_REPLACE, iofmt=ESMF_IOFMT_NETCDF, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_FB_diagnose(FB, 'write '//trim(fname), rc)
-
- elseif (mode == 'read') then
- inquire(file=fname,exist=fexists)
- if (fexists) then
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//": read "//trim(fname), ESMF_LOGMSG_INFO)
- end if
- !-----------------------------------------------------------------------------------------------------
- ! tcraig, ESMF_FieldBundleRead fails if a field is not on the field bundle, but we really want to just
- ! ignore that field and read the rest, so instead read each field one at a time through ESMF_FieldRead
- ! call ESMF_FieldBundleRead (FB, fname, &
- ! singleFile=.true., iofmt=ESMF_IOFMT_NETCDF, rc=rc)
- ! if (chkerr(rc,__LINE__,u_FILE_u)) return
- !-----------------------------------------------------------------------------------------------------
- call ESMF_FieldBundleGet(FB, fieldCount=fieldCount, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- do n = 1,fieldCount
- call med_methods_FB_getFieldByName(FB, name, field, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldRead (field, fname, iofmt=ESMF_IOFMT_NETCDF, rc=rc)
- if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, &
- line=__LINE__, file=u_FILE_u)) call ESMF_LogWrite(trim(subname)//&
- ' WARNING missing field '//trim(name))
- enddo
-
- call med_methods_FB_diagnose(FB, 'read '//trim(fname), rc)
- if (present(flag)) flag = .true.
- endif
-
- else
- call ESMF_LogWrite(trim(subname)//": mode WARNING "//trim(fname)//" mode="//trim(mode), ESMF_LOGMSG_INFO)
- endif
-
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//trim(fname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_FB_RWFields
-
- !-----------------------------------------------------------------------------
-
subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, rc)
! ----------------------------------------------
@@ -185,19 +83,19 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r
! ----------------------------------------------
use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate
- use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleAdd, ESMF_FieldBundleCreate
+ use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleAdd, ESMF_FieldBundleCreate
use ESMF , only : ESMF_State, ESMF_StateGet, ESMF_Mesh, ESMF_MeshLoc
use ESMF , only : ESMF_AttributeGet, ESMF_INDEX_DELOCAL
! input/output variables
type(ESMF_State) , intent(in) :: StateIn ! input state
- type(ESMF_FieldBundle), intent(inout) :: FBout ! output field bundle
+ type(ESMF_FieldBundle), intent(inout) :: FBout ! output field bundle
character(len=*) , intent(in) :: flds_scalar_name ! name of scalar fields
character(len=*) , intent(in) :: name
integer , intent(out) :: rc
! local variables
- logical :: isPresent
+ logical :: isPresent
integer :: n,n1
type(ESMF_Field) :: lfield
type(ESMF_Field) :: newfield
@@ -210,8 +108,8 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r
integer :: ungriddedLBound(1)
integer :: ungriddedUBound(1)
integer :: gridToFieldMap(1)
- real(R8), pointer :: dataptr1d(:)
- real(R8), pointer :: dataptr2d(:,:)
+ real(R8), pointer :: dataptr1d(:) => null()
+ real(R8), pointer :: dataptr2d(:,:) => null()
character(ESMF_MAXSTR), allocatable :: lfieldNameList(:)
character(len=*), parameter :: subname='(med_methods_FB_init_pointer)'
! ----------------------------------------------
@@ -294,7 +192,7 @@ subroutine med_methods_FB_init_pointer(StateIn, FBout, flds_scalar_name, name, r
call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! create new field without an ungridded dimension
+ ! create new field without an ungridded dimension
newfield = ESMF_FieldCreate(lmesh, dataptr1d, ESMF_INDEX_DELOCAL, &
meshloc=meshloc, name=lfieldNameList(n), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -338,7 +236,7 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S
use ESMF , only : ESMF_TYPEKIND_R8, ESMF_FIELDSTATUS_EMPTY, ESMF_AttributeGet
! input/output variables
- type(ESMF_FieldBundle), intent(inout) :: FBout ! output field bundle
+ type(ESMF_FieldBundle), intent(inout) :: FBout ! output field bundle
character(len=*) , intent(in) :: flds_scalar_name ! name of scalar fields
character(len=*) , intent(in), optional :: fieldNameList(:) ! names of fields to use in output field bundle
type(ESMF_FieldBundle), intent(in), optional :: FBgeom ! input field bundle geometry to use
@@ -498,7 +396,9 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S
call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" mesh from FBgeom", ESMF_LOGMSG_INFO)
end if
elseif (present(STgeom)) then
- call med_methods_State_getFieldN(STgeom, 1, lfield, rc=rc)
+ call med_methods_State_getNameN(STgeom, 1, lname, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_StateGet(STgeom, itemName=lname, field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 5) then
call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" mesh from STgeom", ESMF_LOGMSG_INFO)
@@ -541,14 +441,16 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S
do n = 1, fieldCount
! Note that input fields come from ONE of FBFlds, STflds, or fieldNamelist input argument
- if (present(FBFlds) .or. present(STflds)) then
+ if (present(FBFlds) .or. present(STflds)) then
! ungridded dimensions might be present in the input states or field bundles
if (present(FBflds)) then
call med_methods_FB_getFieldN(FBflds, n, lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
elseif (present(STflds)) then
- call med_methods_State_getFieldN(STflds, n, lfield, rc=rc)
+ call med_methods_State_getNameN(STflds, n, lname, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_StateGet(STflds, itemName=lname, field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
@@ -587,14 +489,14 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- else if (present(fieldNameList)) then
-
+ else if (present(fieldNameList)) then
+
! Assume no ungridded dimensions if just the field name list is give
field = ESMF_FieldCreate(lmesh, ESMF_TYPEKIND_R8, meshloc=meshloc, name=lfieldNameList(n), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
+
end if
-
+
! Add the created field bundle FBout
if (dbug_flag > 1) then
call ESMF_LogWrite(trim(subname)//":"//trim(lname)//" adding field "//trim(lfieldNameList(n)), &
@@ -602,7 +504,7 @@ subroutine med_methods_FB_init(FBout, flds_scalar_name, fieldNameList, FBgeom, S
end if
call ESMF_FieldBundleAdd(FBout, (/field/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
+
enddo ! fieldCount
endif ! fieldcountgeom
@@ -635,7 +537,7 @@ subroutine med_methods_FB_getNameN(FB, fieldnum, fieldname, rc)
! local variables
integer :: fieldCount
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
character(len=*),parameter :: subname='(med_methods_FB_getNameN)'
! ----------------------------------------------
@@ -645,22 +547,17 @@ subroutine med_methods_FB_getNameN(FB, fieldnum, fieldname, rc)
rc = ESMF_SUCCESS
fieldname = ' '
-
call ESMF_FieldBundleGet(FB, fieldCount=fieldCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
if (fieldnum > fieldCount) then
call ESMF_LogWrite(trim(subname)//": ERROR fieldnum > fieldCount ", ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
-
allocate(lfieldnamelist(fieldCount))
call ESMF_FieldBundleGet(FB, fieldNameList=lfieldnamelist, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
fieldname = lfieldnamelist(fieldnum)
-
deallocate(lfieldnamelist)
if (dbug_flag > 10) then
@@ -709,40 +606,6 @@ end subroutine med_methods_FB_getFieldN
!-----------------------------------------------------------------------------
- subroutine med_methods_FB_getFieldByName(FB, fieldname, field, rc)
-
- ! ----------------------------------------------
- ! Get field associated with fieldname out of FB
- ! ----------------------------------------------
-
- use ESMF, only : ESMF_Field, ESMF_FieldBundle, ESMF_FieldBundleGet
-
- ! input/output variables
- type(ESMF_FieldBundle), intent(in) :: FB
- character(len=*) , intent(in) :: fieldname
- type(ESMF_Field) , intent(inout) :: field
- integer , intent(out) :: rc
-
- ! local variables
- character(len=*),parameter :: subname='(med_methods_FB_getFieldByName)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call ESMF_FieldBundleGet(FB, fieldName=fieldname, field=field, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_FB_getFieldByName
-
- !-----------------------------------------------------------------------------
-
subroutine med_methods_State_getNameN(State, fieldnum, fieldname, rc)
! ----------------------------------------------
@@ -758,7 +621,7 @@ subroutine med_methods_State_getNameN(State, fieldnum, fieldname, rc)
! local variables
integer :: fieldCount
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
character(len=*),parameter :: subname='(med_methods_State_getNameN)'
! ----------------------------------------------
@@ -768,22 +631,17 @@ subroutine med_methods_State_getNameN(State, fieldnum, fieldname, rc)
rc = ESMF_SUCCESS
fieldname = ' '
-
call ESMF_StateGet(State, itemCount=fieldCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
if (fieldnum > fieldCount) then
call ESMF_LogWrite(trim(subname)//": ERROR fieldnum > fieldCount ", ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
endif
-
allocate(lfieldnamelist(fieldCount))
call ESMF_StateGet(State, itemNameList=lfieldnamelist, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
fieldname = lfieldnamelist(fieldnum)
-
deallocate(lfieldnamelist)
if (dbug_flag > 10) then
@@ -810,9 +668,8 @@ subroutine med_methods_State_getNumFields(State, fieldnum, rc)
! local variables
integer :: n,itemCount
- type(ESMF_Field), pointer :: fieldList(:)
- type(ESMF_StateItem_Flag), pointer :: itemTypeList(:)
- logical, parameter :: use_NUOPC_method = .true.
+ type(ESMF_Field), pointer :: fieldList(:) => null()
+ type(ESMF_StateItem_Flag), pointer :: itemTypeList(:) => null()
character(len=*),parameter :: subname='(med_methods_State_getNumFields)'
! ----------------------------------------------
@@ -821,152 +678,20 @@ subroutine med_methods_State_getNumFields(State, fieldnum, rc)
endif
rc = ESMF_SUCCESS
- if (use_NUOPC_method) then
-
- nullify(fieldList)
- call NUOPC_GetStateMemberLists(state, fieldList=fieldList, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- fieldnum = 0
- if (associated(fieldList)) then
- fieldnum = size(fieldList)
- deallocate(fieldList)
- endif
-
- else
-
- fieldnum = 0
- call ESMF_StateGet(State, itemCount=itemCount, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (itemCount > 0) then
- allocate(itemTypeList(itemCount))
- call ESMF_StateGet(State, itemTypeList=itemTypeList, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- do n = 1,itemCount
- if (itemTypeList(n) == ESMF_STATEITEM_FIELD) fieldnum=fieldnum+1
- enddo
- deallocate(itemTypeList)
- endif
-
- endif
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_State_getNumFields
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_State_getFieldN(State, fieldnum, field, rc)
-
- ! ----------------------------------------------
- ! Get field number fieldnum in State
- ! ----------------------------------------------
-
- use ESMF, only : ESMF_State, ESMF_Field, ESMF_StateGet
-
- type(ESMF_State), intent(in) :: State
- integer , intent(in) :: fieldnum
- type(ESMF_Field), intent(inout) :: field
- integer , intent(out) :: rc
-
- ! local variables
- character(len=ESMF_MAXSTR) :: name
- character(len=*),parameter :: subname='(med_methods_State_getFieldN)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call med_methods_State_getNameN(State, fieldnum, name, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_StateGet(State, itemName=name, field=field, rc=rc)
+ nullify(fieldList)
+ call NUOPC_GetStateMemberLists(state, fieldList=fieldList, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_State_getFieldN
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_State_getFieldByName(State, fieldname, field, rc)
- ! ----------------------------------------------
- ! Get field associated with fieldname from State
- ! ----------------------------------------------
- use ESMF, only : ESMF_State, ESMF_Field, ESMF_StateGet
-
- type(ESMF_State), intent(in) :: State
- character(len=*), intent(in) :: fieldname
- type(ESMF_Field), intent(inout) :: field
- integer , intent(out) :: rc
-
- ! local variables
- character(len=*),parameter :: subname='(med_methods_State_getFieldByName)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
+ fieldnum = 0
+ if (associated(fieldList)) then
+ fieldnum = size(fieldList)
+ deallocate(fieldList)
endif
- rc = ESMF_SUCCESS
-
- call ESMF_StateGet(State, itemName=fieldname, field=field, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 10) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
endif
- end subroutine med_methods_State_getFieldByName
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_FB_clean(FB, rc)
- ! ----------------------------------------------
- ! Destroy fields in FB and FB
- ! ----------------------------------------------
-
- use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_FieldDestroy
- use ESMF, only : ESMF_FieldBundleDestroy, ESMF_Field
-
- type(ESMF_FieldBundle), intent(inout) :: FB
- integer , intent(out) :: rc
-
- ! local variables
- integer :: i,j,n
- integer :: fieldCount
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
- type(ESMF_Field) :: field
- character(len=*),parameter :: subname='(med_methods_FB_clean)'
- ! ----------------------------------------------
-
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- rc = ESMF_SUCCESS
-
- call ESMF_FieldBundleGet(FB, fieldCount=fieldCount, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(lfieldnamelist(fieldCount))
- call ESMF_FieldBundleGet(FB, fieldNameList=lfieldnamelist, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- do n = 1, fieldCount
- call ESMF_FieldBundleGet(FB, fieldName=lfieldnamelist(n), field=field, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldDestroy(field, rc=rc, noGarbage=.true.)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- enddo
-
- call ESMF_FieldBundleDestroy(FB, rc=rc, noGarbage=.true.)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- deallocate(lfieldnamelist)
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
-
- end subroutine med_methods_FB_clean
+ end subroutine med_methods_State_getNumFields
!-----------------------------------------------------------------------------
@@ -976,18 +701,22 @@ subroutine med_methods_FB_reset(FB, value, rc)
! If value is not provided, reset to 0.0
! ----------------------------------------------
- use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet
+ use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field
! intput/output variables
- type(ESMF_FieldBundle), intent(inout) :: FB
- real(R8) , intent(in), optional :: value
- integer , intent(out) :: rc
+ type(ESMF_FieldBundle) , intent(inout) :: FB
+ real(R8) , intent(in), optional :: value
+ integer , intent(out) :: rc
! local variables
integer :: i,j,n
integer :: fieldCount
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
- real(R8) :: lvalue
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
+ real(R8) :: lvalue
+ type(ESMF_Field) :: lfield
+ integer :: lrank
+ real(R8), pointer :: fldptr1(:) => null()
+ real(R8), pointer :: fldptr2(:,:) => null()
character(len=*),parameter :: subname='(med_methods_FB_reset)'
! ----------------------------------------------
@@ -1006,12 +735,25 @@ subroutine med_methods_FB_reset(FB, value, rc)
allocate(lfieldnamelist(fieldCount))
call ESMF_FieldBundleGet(FB, fieldNameList=lfieldnamelist, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
do n = 1, fieldCount
- call med_methods_FB_SetFldPtr(FB, lfieldnamelist(n), lvalue, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- enddo
+ call ESMF_FieldBundleGet(FB, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (lrank == 0) then
+ ! no local data
+ elseif (lrank == 1) then
+ fldptr1 = lvalue
+ elseif (lrank == 2) then
+ fldptr2 = lvalue
+ else
+ call ESMF_LogWrite(trim(subname)//": ERROR in rank "//trim(lfieldnamelist(n)), &
+ ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
+ rc = ESMF_FAILURE
+ return
+ endif
+ enddo
deallocate(lfieldnamelist)
if (dbug_flag > 10) then
@@ -1029,7 +771,7 @@ subroutine med_methods_State_reset(State, value, rc)
! If value is not provided, reset to 0.0
! ----------------------------------------------
- use ESMF, only : ESMF_State, ESMF_StateGet
+ use ESMF, only : ESMF_State, ESMF_StateGet, ESMF_Field
! intput/output variables
type(ESMF_State) , intent(inout) :: State
@@ -1039,8 +781,12 @@ subroutine med_methods_State_reset(State, value, rc)
! local variables
integer :: i,j,n
integer :: fieldCount
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
- real(R8) :: lvalue
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
+ real(R8) :: lvalue
+ type(ESMF_Field) :: lfield
+ integer :: lrank
+ real(R8), pointer :: fldptr1(:) => null()
+ real(R8), pointer :: fldptr2(:,:) => null()
character(len=*),parameter :: subname='(med_methods_State_reset)'
! ----------------------------------------------
@@ -1059,12 +805,24 @@ subroutine med_methods_State_reset(State, value, rc)
allocate(lfieldnamelist(fieldCount))
call ESMF_StateGet(State, itemNameList=lfieldnamelist, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
do n = 1, fieldCount
- call med_methods_State_SetFldPtr(State, lfieldnamelist(n), lvalue, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_StateGet(State, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (lrank == 0) then
+ ! no local data
+ elseif (lrank == 1) then
+ fldptr1 = lvalue
+ elseif (lrank == 2) then
+ fldptr2 = lvalue
+ else
+ call ESMF_LogWrite(trim(subname)//": ERROR in rank "//trim(lfieldnamelist(n)), &
+ ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
+ rc = ESMF_FAILURE
+ return
+ endif
enddo
-
deallocate(lfieldnamelist)
if (dbug_flag > 10) then
@@ -1081,7 +839,7 @@ subroutine med_methods_FB_average(FB, count, rc)
! Set all fields to zero in FB
! ----------------------------------------------
- use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet
+ use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field
! input/output variables
type(ESMF_FieldBundle), intent(inout) :: FB
@@ -1091,9 +849,10 @@ subroutine med_methods_FB_average(FB, count, rc)
! local variables
integer :: i,j,n
integer :: fieldCount, lrank
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
- real(R8), pointer :: dataPtr1(:)
- real(R8), pointer :: dataPtr2(:,:)
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
+ real(R8), pointer :: dataPtr1(:) => null()
+ real(R8), pointer :: dataPtr2(:,:) => null()
+ type(ESMF_Field) :: lfield
character(len=*),parameter :: subname='(med_methods_FB_average)'
! ----------------------------------------------
@@ -1119,8 +878,10 @@ subroutine med_methods_FB_average(FB, count, rc)
call ESMF_FieldBundleGet(FB, fieldNameList=lfieldnamelist, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
do n = 1, fieldCount
- call med_methods_FB_GetFldPtr(FB, lfieldnamelist(n), dataPtr1, dataPtr2, lrank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(FB, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1, fldptr2=dataptr2, rank=lrank, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
if (lrank == 0) then
! no local data
@@ -1157,7 +918,7 @@ subroutine med_methods_FB_diagnose(FB, string, rc)
! Diagnose status of FB
! ----------------------------------------------
- use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet
+ use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field
type(ESMF_FieldBundle) , intent(inout) :: FB
character(len=*) , intent(in), optional :: string
@@ -1166,10 +927,11 @@ subroutine med_methods_FB_diagnose(FB, string, rc)
! local variables
integer :: i,j,n
integer :: fieldCount, lrank
- character(ESMF_MAXSTR), pointer :: lfieldnamelist(:)
+ character(ESMF_MAXSTR), pointer :: lfieldnamelist(:) => null()
character(len=CL) :: lstring
- real(R8), pointer :: dataPtr1d(:)
- real(R8), pointer :: dataPtr2d(:,:)
+ real(R8), pointer :: dataPtr1d(:) => null()
+ real(R8), pointer :: dataPtr2d(:,:) => null()
+ type(ESMF_Field) :: lfield
character(len=*), parameter :: subname='(med_methods_FB_diagnose)'
! ----------------------------------------------
@@ -1192,8 +954,9 @@ subroutine med_methods_FB_diagnose(FB, string, rc)
! For each field in the bundle, get its memory location and print out the field
do n = 1, fieldCount
- call med_methods_FB_GetFldPtr(FB, lfieldnamelist(n), &
- fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc)
+ call ESMF_FieldBundleGet(FB, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1d, fldptr2=dataptr2d, rank=lrank, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (lrank == 0) then
@@ -1248,7 +1011,7 @@ subroutine med_methods_Array_diagnose(array, string, rc)
! local variables
character(len=CS) :: lstring
- real(R8), pointer :: dataPtr3d(:,:,:)
+ real(R8), pointer :: dataPtr3d(:,:,:) => null()
character(len=*),parameter :: subname='(med_methods_Array_diagnose)'
! ----------------------------------------------
@@ -1288,8 +1051,9 @@ subroutine med_methods_State_diagnose(State, string, rc)
! Diagnose status of State
! ----------------------------------------------
- use ESMF, only : ESMF_State, ESMF_StateGet
+ use ESMF, only : ESMF_State, ESMF_StateGet, ESMF_Field
+ ! input/output variables
type(ESMF_State), intent(in) :: State
character(len=*), intent(in), optional :: string
integer , intent(out) :: rc
@@ -1297,10 +1061,11 @@ subroutine med_methods_State_diagnose(State, string, rc)
! local variables
integer :: i,j,n
integer :: fieldCount, lrank
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
character(len=CS) :: lstring
- real(R8), pointer :: dataPtr1d(:)
- real(R8), pointer :: dataPtr2d(:,:)
+ real(R8), pointer :: dataPtr1d(:) => null()
+ real(R8), pointer :: dataPtr2d(:,:) => null()
+ type(ESMF_Field) :: lfield
character(len=*),parameter :: subname='(med_methods_State_diagnose)'
! ----------------------------------------------
@@ -1316,19 +1081,16 @@ subroutine med_methods_State_diagnose(State, string, rc)
call ESMF_StateGet(State, itemCount=fieldCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
allocate(lfieldnamelist(fieldCount))
-
call ESMF_StateGet(State, itemNameList=lfieldnamelist, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
do n = 1, fieldCount
-
- call med_methods_State_GetFldPtr(State, lfieldnamelist(n), &
- fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc)
+ call ESMF_StateGet(State, itemName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptr1d, fldptr2=dataptr2d, rank=lrank, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (lrank == 0) then
! no local data
-
elseif (lrank == 1) then
if (size(dataPtr1d) > 0) then
write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), &
@@ -1337,7 +1099,6 @@ subroutine med_methods_State_diagnose(State, string, rc)
write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), &
" no data"
endif
-
elseif (lrank == 2) then
if (size(dataPtr2d) > 0) then
write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), &
@@ -1346,7 +1107,6 @@ subroutine med_methods_State_diagnose(State, string, rc)
write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(lfieldnamelist(n)), &
" no data"
endif
-
else
call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
@@ -1373,7 +1133,7 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc)
! Diagnose status of State
! ----------------------------------------------
- use ESMF, only : ESMF_FieldBundle
+ use ESMF, only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field, ESMF_FieldGet
! input/output variables
type(ESMF_FieldBundle), intent(inout) :: FB
@@ -1384,9 +1144,11 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc)
! local variables
integer :: lrank
character(len=CS) :: lstring
- real(R8), pointer :: dataPtr1d(:)
- real(R8), pointer :: dataPtr2d(:,:)
- character(len=*),parameter :: subname='(med_methods_FB_FieldDiagnose)'
+ real(R8), pointer :: dataPtr1d(:) => null()
+ real(R8), pointer :: dataPtr2d(:,:) => null()
+ type(ESMF_Field) :: lfield
+ integer :: ungriddedUBound(1) ! currently the size must equal 1 for rank 2 fields
+ character(len=*),parameter :: subname='(med_methods_FB_FieldDiagnose)'
! ----------------------------------------------
if (dbug_flag > 10) then
@@ -1399,30 +1161,29 @@ subroutine med_methods_FB_Field_diagnose(FB, fieldname, string, rc)
lstring = trim(string)
endif
- call med_methods_FB_GetFldPtr(FB, fieldname, dataPtr1d, dataPtr2d, lrank, rc=rc)
+ call ESMF_FieldBundleGet(FB, fieldName=fieldname, field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (lrank == 0) then
- ! no local data
- elseif (lrank == 1) then
- if (size(dataPtr1d) > 0) then
+ call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUBound(1) > 0) then
+ call ESMF_FieldGet(lfield, farrayptr=dataptr2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (size(dataptr2d) > 0) then
write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname), &
- minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d)
+ minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d)
else
write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data"
endif
- elseif (lrank == 2) then
- if (size(dataPtr2d) > 0) then
+ else
+ call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (size(dataPtr1d) > 0) then
write(msgString,'(A,3g14.7,i8)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname), &
- minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d)
+ minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d)
else
write(msgString,'(A,a)') trim(subname)//' '//trim(lstring)//': '//trim(fieldname)," no data"
endif
- else
- call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR)
- rc = ESMF_FAILURE
- return
- endif
+ end if
call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO)
if (dbug_flag > 10) then
@@ -1450,8 +1211,8 @@ subroutine med_methods_Field_diagnose(field, fieldname, string, rc)
! local variables
integer :: lrank
character(len=CS) :: lstring
- real(R8), pointer :: dataPtr1d(:)
- real(R8), pointer :: dataPtr2d(:,:)
+ real(R8), pointer :: dataPtr1d(:) => null()
+ real(R8), pointer :: dataPtr2d(:,:) => null()
character(len=*),parameter :: subname='(med_methods_FB_FieldDiagnose)'
! ----------------------------------------------
@@ -1538,9 +1299,9 @@ subroutine med_methods_FB_accumFB2FB(FBout, FBin, copy, rc)
! If copy is passed in and true, the this is a copy
! ----------------------------------------------
- use ESMF , only : ESMF_FieldBundle
- use ESMF , only : ESMF_FieldBundleGet
+ use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_Field
+ ! input/output variables
type(ESMF_FieldBundle), intent(inout) :: FBout
type(ESMF_FieldBundle), intent(in) :: FBin
logical, optional , intent(in) :: copy
@@ -1549,11 +1310,14 @@ subroutine med_methods_FB_accumFB2FB(FBout, FBin, copy, rc)
! local variables
integer :: i,j,n
integer :: fieldCount, lranki, lranko
- character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:)
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
logical :: exists
logical :: lcopy
- real(R8), pointer :: dataPtri1(:) , dataPtro1(:)
- real(R8), pointer :: dataPtri2(:,:), dataPtro2(:,:)
+ real(R8), pointer :: dataPtri1(:) => null()
+ real(R8), pointer :: dataPtro1(:) => null()
+ real(R8), pointer :: dataPtri2(:,:) => null()
+ real(R8), pointer :: dataPtro2(:,:) => null()
+ type(ESMF_Field) :: lfield
character(len=*), parameter :: subname='(med_methods_FB_accumFB2FB)'
! ----------------------------------------------
@@ -1577,9 +1341,14 @@ subroutine med_methods_FB_accumFB2FB(FBout, FBin, copy, rc)
call ESMF_FieldBundleGet(FBin, fieldName=lfieldnamelist(n), isPresent=exists, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (exists) then
- call med_methods_FB_GetFldPtr(FBin, lfieldnamelist(n), dataPtri1, dataPtri2, lranki, rc=rc)
+ call ESMF_FieldBundleGet(FBin, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptri1, fldptr2=dataptri2, rank=lranki, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_FB_GetFldPtr(FBout, lfieldnamelist(n), dataPtro1, dataPtro2, lranko, rc=rc)
+
+ call ESMF_FieldBundleGet(FBout, fieldName=trim(lfieldnamelist(n)), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=dataptro1, fldptr2=dataptro2, rank=lranko, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (lranki == 1 .and. lranko == 1) then
@@ -1680,7 +1449,7 @@ logical function med_methods_FB_FldChk(FB, fldname, rc)
call ESMF_FieldBundleGet(FB, fieldName=trim(fldname), isPresent=isPresent, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) then
- call ESMF_LogWrite(trim(subname)//" Error checking field: "//trim(fldname), &
+ call ESMF_LogWrite(trim(subname)//" Error checking field: "//trim(fldname), &
ESMF_LOGMSG_ERROR)
return
endif
@@ -1706,6 +1475,7 @@ subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc)
use ESMF , only : ESMF_Field,ESMF_Mesh, ESMF_FieldGet, ESMF_MeshGet
use ESMF , only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_COMPLETE
+ use ESMF , only : ESMF_GeomType_Flag
! input/output variables
type(ESMF_Field) , intent(in) :: field
@@ -1716,9 +1486,10 @@ subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc)
integer , intent(out) , optional :: rc
! local variables
- type(ESMF_Mesh) :: lmesh
- integer :: lrank, nnodes, nelements
- logical :: labort
+ type(ESMF_Mesh) :: lmesh
+ integer :: lrank, nnodes, nelements
+ logical :: labort
+ type(ESMF_GeomType_Flag) :: geomtype
character(len=*), parameter :: subname='(med_methods_Field_GetFldPtr)'
! ----------------------------------------------
@@ -1761,7 +1532,6 @@ subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc)
if (geomtype == ESMF_GEOMTYPE_GRID) then
call ESMF_FieldGet(field, rank=lrank, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
elseif (geomtype == ESMF_GEOMTYPE_MESH) then
call ESMF_FieldGet(field, rank=lrank, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -1770,10 +1540,8 @@ subroutine med_methods_Field_GetFldPtr(field, fldptr1, fldptr2, rank, abort, rc)
call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (nnodes == 0 .and. nelements == 0) lrank = 0
-
- else
- call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", &
- ESMF_LOGMSG_INFO)
+ else
+ call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", ESMF_LOGMSG_INFO)
rc = ESMF_FAILURE
return
endif ! geomtype
@@ -1867,9 +1635,7 @@ subroutine med_methods_FB_GetFldPtr(FB, fldname, fldptr1, fldptr2, rank, field,
call ESMF_FieldBundleGet(FB, fieldName=trim(fldname), field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Field_GetFldPtr(lfield, &
- fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc)
+ call med_methods_Field_GetFldPtr(lfield, fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (present(rank)) then
@@ -1886,156 +1652,13 @@ end subroutine med_methods_FB_GetFldPtr
!-----------------------------------------------------------------------------
- subroutine med_methods_FB_SetFldPtr(FB, fldname, val, rc)
-
- use ESMF, only : ESMF_FieldBundle, ESMF_Field
-
- type(ESMF_FieldBundle), intent(in) :: FB
- character(len=*) , intent(in) :: fldname
- real(R8) , intent(in) :: val
- integer , intent(out) :: rc
-
- ! local variables
- type(ESMF_Field) :: lfield
- integer :: lrank
- real(R8), pointer :: fldptr1(:)
- real(R8), pointer :: fldptr2(:,:)
- character(len=*), parameter :: subname='(med_methods_FB_SetFldPtr)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call med_methods_FB_GetFldPtr(FB, fldname, fldptr1, fldptr2, lrank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (lrank == 0) then
- ! no local data
- elseif (lrank == 1) then
- fldptr1 = val
- elseif (lrank == 2) then
- fldptr2 = val
- else
- call ESMF_LogWrite(trim(subname)//": ERROR in rank "//trim(fldname), &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
- rc = ESMF_FAILURE
- return
- endif
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_FB_SetFldPtr
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_State_GetFldPtr(ST, fldname, fldptr1, fldptr2, rank, rc)
- ! ----------------------------------------------
- ! Get pointer to a state field
- ! ----------------------------------------------
-
- use ESMF, only : ESMF_State, ESMF_Field, ESMF_StateGet
-
- type(ESMF_State), intent(in) :: ST
- character(len=*), intent(in) :: fldname
- real(R8), pointer, intent(inout), optional :: fldptr1(:)
- real(R8), pointer, intent(inout), optional :: fldptr2(:,:)
- integer , intent(out), optional :: rank
- integer , intent(out), optional :: rc
-
- ! local variables
- type(ESMF_Field) :: lfield
- integer :: lrank
- character(len=*), parameter :: subname='(med_methods_State_GetFldPtr)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
-
- if (.not.present(rc)) then
- call ESMF_LogWrite(trim(subname)//": ERROR rc not present "//trim(fldname), &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
- rc = ESMF_FAILURE
- return
- endif
-
- rc = ESMF_SUCCESS
-
- call ESMF_StateGet(ST, itemName=trim(fldname), field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Field_GetFldPtr(lfield, &
- fldptr1=fldptr1, fldptr2=fldptr2, rank=lrank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (present(rank)) then
- rank = lrank
- endif
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_State_GetFldPtr
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_State_SetFldPtr(ST, fldname, val, rc)
-
- use ESMF, only : ESMF_State, ESMF_Field
-
- type(ESMF_State) , intent(in) :: ST
- character(len=*) , intent(in) :: fldname
- real(R8), intent(in) :: val
- integer , intent(out) :: rc
-
- ! local variables
- type(ESMF_Field) :: lfield
- integer :: lrank
- real(R8), pointer :: fldptr1(:)
- real(R8), pointer :: fldptr2(:,:)
- character(len=*), parameter :: subname='(med_methods_State_SetFldPtr)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call med_methods_State_GetFldPtr(ST, fldname, fldptr1, fldptr2, lrank, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (lrank == 0) then
- ! no local data
- elseif (lrank == 1) then
- fldptr1 = val
- elseif (lrank == 2) then
- fldptr2 = val
- else
- call ESMF_LogWrite(trim(subname)//": ERROR in rank "//trim(fldname), &
- ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
- rc = ESMF_FAILURE
- return
- endif
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_State_SetFldPtr
-
- !-----------------------------------------------------------------------------
-
logical function med_methods_FieldPtr_Compare1(fldptr1, fldptr2, cstring, rc)
- real(R8), pointer, intent(in) :: fldptr1(:)
- real(R8), pointer, intent(in) :: fldptr2(:)
- character(len=*) , intent(in) :: cstring
- integer , intent(out) :: rc
+ ! input/output variables
+ real(R8) , pointer, intent(in) :: fldptr1(:)
+ real(R8) , pointer, intent(in) :: fldptr2(:)
+ character(len=*) , intent(in) :: cstring
+ integer , intent(out) :: rc
! local variables
character(len=*), parameter :: subname='(med_methods_FieldPtr_Compare1)'
@@ -2047,8 +1670,7 @@ logical function med_methods_FieldPtr_Compare1(fldptr1, fldptr2, cstring, rc)
rc = ESMF_SUCCESS
med_methods_FieldPtr_Compare1 = .false.
- if (lbound(fldptr2,1) /= lbound(fldptr1,1) .or. &
- ubound(fldptr2,1) /= ubound(fldptr1,1)) then
+ if (lbound(fldptr2,1) /= lbound(fldptr1,1) .or. ubound(fldptr2,1) /= ubound(fldptr1,1)) then
call ESMF_LogWrite(trim(subname)//": ERROR in data size "//trim(cstring), ESMF_LOGMSG_ERROR, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
write(msgString,*) trim(subname)//': fldptr1 ',lbound(fldptr1),ubound(fldptr1)
@@ -2069,10 +1691,11 @@ end function med_methods_FieldPtr_Compare1
logical function med_methods_FieldPtr_Compare2(fldptr1, fldptr2, cstring, rc)
- real(R8), pointer, intent(in) :: fldptr1(:,:)
- real(R8), pointer, intent(in) :: fldptr2(:,:)
- character(len=*) , intent(in) :: cstring
- integer , intent(out) :: rc
+ ! input/otuput variables
+ real(R8), pointer , intent(in) :: fldptr1(:,:)
+ real(R8), pointer , intent(in) :: fldptr2(:,:)
+ character(len=*) , intent(in) :: cstring
+ integer , intent(out) :: rc
! local variables
character(len=*), parameter :: subname='(med_methods_FieldPtr_Compare2)'
@@ -2084,10 +1707,8 @@ logical function med_methods_FieldPtr_Compare2(fldptr1, fldptr2, cstring, rc)
rc = ESMF_SUCCESS
med_methods_FieldPtr_Compare2 = .false.
- if (lbound(fldptr2,2) /= lbound(fldptr1,2) .or. &
- lbound(fldptr2,1) /= lbound(fldptr1,1) .or. &
- ubound(fldptr2,2) /= ubound(fldptr1,2) .or. &
- ubound(fldptr2,1) /= ubound(fldptr1,1)) then
+ if (lbound(fldptr2,2) /= lbound(fldptr1,2) .or. lbound(fldptr2,1) /= lbound(fldptr1,1) .or. &
+ ubound(fldptr2,2) /= ubound(fldptr1,2) .or. ubound(fldptr2,1) /= ubound(fldptr1,1)) then
call ESMF_LogWrite(trim(subname)//": ERROR in data size "//trim(cstring), ESMF_LOGMSG_ERROR, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
write(msgString,*) trim(subname)//': fldptr2 ',lbound(fldptr2),ubound(fldptr2)
@@ -2110,12 +1731,16 @@ subroutine med_methods_State_GeomPrint(state, string, rc)
use ESMF, only : ESMF_State, ESMF_Field, ESMF_StateGet
+ ! input/output variables
type(ESMF_State), intent(in) :: state
character(len=*), intent(in) :: string
integer , intent(out) :: rc
- type(ESMF_Field) :: lfield
- integer :: fieldcount
+ ! local variables
+ type(ESMF_Field) :: lfield
+ integer :: fieldcount
+ character(ESMF_MAXSTR) ,pointer :: lfieldnamelist(:) => null()
+ character(ESMF_MAXSTR) :: name
character(len=*),parameter :: subname='(med_methods_State_GeomPrint)'
! ----------------------------------------------
@@ -2126,12 +1751,17 @@ subroutine med_methods_State_GeomPrint(state, string, rc)
call ESMF_StateGet(state, itemCount=fieldCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
if (fieldCount > 0) then
- call med_methods_State_GetFieldN(state, 1, lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_Field_GeomPrint(lfield, string, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_StateGet(state, itemCount=fieldCount, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ allocate(lfieldnamelist(fieldCount))
+ call ESMF_StateGet(State, itemNameList=lfieldnamelist, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_StateGet(State, itemName=lfieldnamelist(1), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(lfieldnamelist)
+ call med_methods_Field_GeomPrint(lfield, string, rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
else
call ESMF_LogWrite(trim(subname)//":"//trim(string)//": no fields", ESMF_LOGMSG_INFO)
endif ! fieldCount > 0
@@ -2164,9 +1794,7 @@ subroutine med_methods_FB_GeomPrint(FB, string, rc)
call ESMF_FieldBundleGet(FB, fieldCount=fieldCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
if (fieldCount > 0) then
-
call med_methods_Field_GeomPrint(lfield, string, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
else
@@ -2185,6 +1813,7 @@ subroutine med_methods_Field_GeomPrint(field, string, rc)
use ESMF, only : ESMF_Field, ESMF_Grid, ESMF_Mesh
use ESMF, only : ESMF_FieldGet, ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID, ESMF_FIELDSTATUS_EMPTY
+ use ESMF, only : ESMF_GeomType_Flag
! input/output variables
type(ESMF_Field), intent(in) :: field
@@ -2192,11 +1821,12 @@ subroutine med_methods_Field_GeomPrint(field, string, rc)
integer , intent(out) :: rc
! local variables
- type(ESMF_Grid) :: lgrid
- type(ESMF_Mesh) :: lmesh
- integer :: lrank
- real(R8), pointer :: dataPtr1(:)
- real(R8), pointer :: dataPtr2(:,:)
+ type(ESMF_Grid) :: lgrid
+ type(ESMF_Mesh) :: lmesh
+ integer :: lrank
+ real(R8), pointer :: dataPtr1(:) => null()
+ real(R8), pointer :: dataPtr2(:,:) => null()
+ type(ESMF_GeomType_Flag) :: geomtype
character(len=*),parameter :: subname='(med_methods_Field_GeomPrint)'
! ----------------------------------------------
@@ -2216,7 +1846,6 @@ subroutine med_methods_Field_GeomPrint(field, string, rc)
call ESMF_FieldGet(field, geomtype=geomtype, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
if (geomtype == ESMF_GEOMTYPE_GRID) then
call ESMF_FieldGet(field, grid=lgrid, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -2417,29 +2046,30 @@ subroutine med_methods_Mesh_Print(mesh, string, rc)
end subroutine med_methods_Mesh_Print
!-----------------------------------------------------------------------------
-
subroutine med_methods_Grid_Print(grid, string, rc)
use ESMF, only : ESMF_Grid, ESMF_DistGrid, ESMF_StaggerLoc
use ESMF, only : ESMF_GridGet, ESMF_DistGridGet, ESMF_GridGetCoord
use ESMF, only : ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER
+ ! input/output variabes
type(ESMF_Grid) , intent(in) :: grid
character(len=*), intent(in) :: string
integer , intent(out) :: rc
- type(ESMF_Distgrid) :: distgrid
- integer :: localDeCount
- integer :: DeCount
- integer :: dimCount, tileCount
- integer :: staggerlocCount, arbdimCount, rank
- type(ESMF_StaggerLoc) :: staggerloc
- character(len=32) :: staggerstr
- integer, allocatable :: minIndexPTile(:,:), maxIndexPTile(:,:)
- real(R8), pointer :: fldptr1(:)
- real(R8), pointer :: fldptr2(:,:)
- integer :: n1,n2,n3
- character(len=*),parameter :: subname='(med_methods_Grid_Print)'
+ ! local variables
+ type(ESMF_Distgrid) :: distgrid
+ integer :: localDeCount
+ integer :: DeCount
+ integer :: dimCount, tileCount
+ integer :: staggerlocCount, arbdimCount, rank
+ type(ESMF_StaggerLoc) :: staggerloc
+ character(len=32) :: staggerstr
+ integer, allocatable :: minIndexPTile(:,:), maxIndexPTile(:,:)
+ real(R8), pointer :: fldptr1(:) => null()
+ real(R8), pointer :: fldptr2(:,:) => null()
+ integer :: n1,n2,n3
+ character(len=*),parameter :: subname='(med_methods_Grid_Print)'
! ----------------------------------------------
if (dbug_flag > 10) then
@@ -2457,13 +2087,10 @@ subroutine med_methods_Grid_Print(grid, string, rc)
! get dimCount and tileCount
call ESMF_DistGridGet(distgrid, dimCount=dimCount, tileCount=tileCount, deCount=deCount, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
write (msgString,*) trim(subname)//":"//trim(string)//": dimCount=", dimCount
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
-
write (msgString,*) trim(subname)//":"//trim(string)//": tileCount=", tileCount
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
-
write (msgString,*) trim(subname)//":"//trim(string)//": deCount=", deCount
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
@@ -2475,30 +2102,12 @@ subroutine med_methods_Grid_Print(grid, string, rc)
call ESMF_DistGridGet(distgrid, minIndexPTile=minIndexPTile, &
maxIndexPTile=maxIndexPTile, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
write (msgString,*) trim(subname)//":"//trim(string)//": minIndexPTile=", minIndexPTile
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
-
write (msgString,*) trim(subname)//":"//trim(string)//": maxIndexPTile=", maxIndexPTile
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
-
deallocate(minIndexPTile, maxIndexPTile)
- ! get staggerlocCount, arbDimCount
-! call ESMF_GridGet(grid, staggerlocCount=staggerlocCount, rc=rc)
-! if (chkerr(rc,__LINE__,u_FILE_u)) return
-
-! write (msgString,*) trim(subname)//":"//trim(string)//": staggerlocCount=", staggerlocCount
-! call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
-! if (chkerr(rc,__LINE__,u_FILE_u)) return
-
-! call ESMF_GridGet(grid, arbDimCount=arbDimCount, rc=rc)
-! if (chkerr(rc,__LINE__,u_FILE_u)) return
-
-! write (msgString,*) trim(subname)//":"//trim(string)//": arbDimCount=", arbDimCount
-! call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
-! if (chkerr(rc,__LINE__,u_FILE_u)) return
-
! get rank
call ESMF_GridGet(grid, rank=rank, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -2527,12 +2136,14 @@ subroutine med_methods_Grid_Print(grid, string, rc)
if (rank == 1) then
call ESMF_GridGetCoord(grid,coordDim=n2,localDE=n3,staggerloc=staggerloc,farrayPtr=fldptr1,rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- write (msgString,'(a,2i4,2f16.8)') trim(subname)//":"//trim(staggerstr)//" coord=",n2,n3,minval(fldptr1),maxval(fldptr1)
+ write (msgString,'(a,2i4,2f16.8)') trim(subname)//":"//trim(staggerstr)//" coord=",&
+ n2,n3,minval(fldptr1),maxval(fldptr1)
endif
if (rank == 2) then
call ESMF_GridGetCoord(grid,coordDim=n2,localDE=n3,staggerloc=staggerloc,farrayPtr=fldptr2,rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- write (msgString,'(a,2i4,2f16.8)') trim(subname)//":"//trim(staggerstr)//" coord=",n2,n3,minval(fldptr2),maxval(fldptr2)
+ write (msgString,'(a,2i4,2f16.8)') trim(subname)//":"//trim(staggerstr)//" coord=",&
+ n2,n3,minval(fldptr2),maxval(fldptr2)
endif
call ESMF_LogWrite(msgString, ESMF_LOGMSG_INFO)
enddo
@@ -2546,7 +2157,7 @@ subroutine med_methods_Grid_Print(grid, string, rc)
end subroutine med_methods_Grid_Print
-!-----------------------------------------------------------------------------
+ !-----------------------------------------------------------------------------
subroutine med_methods_Clock_TimePrint(clock,string,rc)
use ESMF , only : ESMF_Clock, ESMF_Time, ESMF_TimeInterval
@@ -2607,466 +2218,6 @@ subroutine med_methods_Clock_TimePrint(clock,string,rc)
end subroutine med_methods_Clock_TimePrint
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_Mesh_Write(mesh, string, rc)
-
- use ESMF, only : ESMF_Mesh, ESMF_MeshGet, ESMF_Array, ESMF_ArrayWrite, ESMF_DistGrid
-
- type(ESMF_Mesh) ,intent(in) :: mesh
- character(len=*),intent(in) :: string
- integer ,intent(out) :: rc
-
- ! local
- integer :: n,l,i,lsize,ndims
- character(len=CS) :: name
- type(ESMF_DISTGRID) :: distgrid
- type(ESMF_Array) :: array
- real(R8), pointer :: rawdata(:)
- real(R8), pointer :: coord(:)
- character(len=*),parameter :: subname='(med_methods_Mesh_Write)'
- ! ----------------------------------------------
-
- rc = ESMF_SUCCESS
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
-
-#if (1 == 0)
- !--- elements ---
-
- call ESMF_MeshGet(mesh, spatialDim=ndims, numownedElements=lsize, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(rawdata(ndims*lsize))
- allocate(coord(lsize))
-
- call ESMF_MeshGet(mesh, elementDistgrid=distgrid, ownedElemCoords=rawdata, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- do n = 1,ndims
- name = "unknown"
- if (n == 1) name = "lon_element"
- if (n == 2) name = "lat_element"
- do l = 1,lsize
- i = 2*(l-1) + n
- coord(l) = rawdata(i)
- array = ESMF_ArrayCreate(distgrid, farrayPtr=coord, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- enddo
- enddo
-
- deallocate(rawdata,coord)
-
- !--- nodes ---
-
- call ESMF_MeshGet(mesh, spatialDim=ndims, numownedNodes=lsize, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(rawdata(ndims*lsize))
- allocate(coord(lsize))
-
- call ESMF_MeshGet(mesh, nodalDistgrid=distgrid, ownedNodeCoords=rawdata, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- do n = 1,ndims
- name = "unknown"
- if (n == 1) name = "lon_nodes"
- if (n == 2) name = "lat_nodes"
- do l = 1,lsize
- i = 2*(l-1) + n
- coord(l) = rawdata(i)
- array = ESMF_ArrayCreate(distgrid, farrayPtr=coord, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- enddo
- enddo
-
- deallocate(rawdata,coord)
-#else
- call ESMF_LogWrite(trim(subname)//": turned off right now", ESMF_LOGMSG_INFO)
-#endif
-
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_Mesh_Write
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_State_GeomWrite(state, string, rc)
- use ESMF, only : ESMF_State, ESMF_Field, ESMF_StateGet
- type(ESMF_State), intent(in) :: state
- character(len=*), intent(in) :: string
- integer , intent(out) :: rc
-
- type(ESMF_Field) :: lfield
- integer :: fieldcount
- character(len=*),parameter :: subname='(med_methods_State_GeomWrite)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call ESMF_StateGet(state, itemCount=fieldCount, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (fieldCount > 0) then
- call med_methods_State_getFieldN(state, 1, lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_Field_GeomWrite(lfield, string, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else
- call ESMF_LogWrite(trim(subname)//":"//trim(string)//": no fields", ESMF_LOGMSG_INFO)
- endif ! fieldCount > 0
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_State_GeomWrite
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_FB_GeomWrite(FB, string, rc)
- use ESMF, only : ESMF_Field, ESMF_FieldBundle, ESMF_FieldBundleGet
-
- type(ESMF_FieldBundle), intent(in) :: FB
- character(len=*), intent(in) :: string
- integer , intent(out) :: rc
-
- type(ESMF_Field) :: lfield
- integer :: fieldcount
- character(len=*),parameter :: subname='(med_methods_FB_GeomWrite)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call ESMF_FieldBundleGet(FB, fieldCount=fieldCount, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (fieldCount > 0) then
- call med_methods_FB_getFieldN(FB, 1, lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_Field_GeomWrite(lfield, string, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- else
- call ESMF_LogWrite(trim(subname)//":"//trim(string)//": no fields", ESMF_LOGMSG_INFO)
- endif ! fieldCount > 0
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_FB_GeomWrite
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_Field_GeomWrite(field, string, rc)
-
- use ESMF, only : ESMF_Field, ESMF_Grid, ESMF_Mesh, ESMF_FIeldGet, ESMF_FIELDSTATUS_EMPTY
- use ESMF, only : ESMF_GEOMTYPE_MESH, ESMF_GEOMTYPE_GRID
-
- ! input/output variables
- type(ESMF_Field), intent(in) :: field
- character(len=*), intent(in) :: string
- integer , intent(out) :: rc
-
- ! local variables
- type(ESMF_Grid) :: lgrid
- type(ESMF_Mesh) :: lmesh
- character(len=*),parameter :: subname='(med_methods_Field_GeomWrite)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- call ESMF_FieldGet(field, status=status, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (status == ESMF_FIELDSTATUS_EMPTY) then
- call ESMF_LogWrite(trim(subname)//":"//trim(string)//": ERROR field does not have a geom yet ")
- rc = ESMF_FAILURE
- return
- endif
-
- call ESMF_FieldGet(field, geomtype=geomtype, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (geomtype == ESMF_GEOMTYPE_GRID) then
- call ESMF_FieldGet(field, grid=lgrid, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_Grid_Write(lgrid, string, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- elseif (geomtype == ESMF_GEOMTYPE_MESH) then
- call ESMF_FieldGet(field, mesh=lmesh, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_methods_Mesh_Write(lmesh, string, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_Field_GeomWrite
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_Grid_Write(grid, string, rc)
-
- use ESMF , only : ESMF_Grid, ESMF_Array, ESMF_GridGetCoord, ESMF_ArraySet
- use ESMF , only : ESMF_ArrayWrite, ESMF_GridGetItem, ESMF_GridGetCoord
- use ESMF , only : ESMF_GRIDITEM_AREA, ESMF_GRIDITEM_MASK
- use ESMF , only : ESMF_STAGGERLOC_CENTER, ESMF_STAGGERLOC_CORNER
-
- ! input/output variables
- type(ESMF_Grid) ,intent(in) :: grid
- character(len=*),intent(in) :: string
- integer ,intent(out) :: rc
-
- ! local
- type(ESMF_Array) :: array
- character(len=CS) :: name
- character(len=*),parameter :: subname='(med_methods_Grid_Write)'
- ! ----------------------------------------------
-
- rc = ESMF_SUCCESS
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
-
- ! -- centers --
-
- call ESMF_GridGetCoord(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- name = "lon_center"
- call ESMF_GridGetCoord(grid, coordDim=1, staggerLoc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArraySet(array, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- name = "lat_center"
- call ESMF_GridGetCoord(grid, coordDim=2, staggerLoc=ESMF_STAGGERLOC_CENTER, array=array, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArraySet(array, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
-
- ! -- corners --
-
- call ESMF_GridGetCoord(grid, staggerLoc=ESMF_STAGGERLOC_CORNER, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- name = "lon_corner"
- call ESMF_GridGetCoord(grid, coordDim=1, staggerLoc=ESMF_STAGGERLOC_CORNER, array=array, rc=rc)
- if (.not. ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) then
- call ESMF_ArraySet(array, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
-
- name = "lat_corner"
- call ESMF_GridGetCoord(grid, coordDim=2, staggerLoc=ESMF_STAGGERLOC_CORNER, array=array, rc=rc)
- if (.not. ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=u_FILE_u)) then
- call ESMF_ArraySet(array, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
- endif
-
- ! -- mask --
-
- name = "mask"
- call ESMF_GridGetItem(grid, itemflag=ESMF_GRIDITEM_MASK, staggerLoc=ESMF_STAGGERLOC_CENTER, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_MASK, array=array, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArraySet(array, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//"_"//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
-
- ! -- area --
-
- name = "area"
- call ESMF_GridGetItem(grid, itemflag=ESMF_GRIDITEM_AREA, staggerLoc=ESMF_STAGGERLOC_CENTER, isPresent=isPresent, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent) then
- call ESMF_GridGetItem(grid, staggerLoc=ESMF_STAGGERLOC_CENTER, itemflag=ESMF_GRIDITEM_AREA, array=array, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArraySet(array, name=name, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call med_methods_Array_diagnose(array, string=trim(string)//trim(name), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_ArrayWrite(array, trim(string)//"_"//trim(name)//".nc", overwrite=.true., rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- endif
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
- endif
-
- end subroutine med_methods_Grid_Write
-
- !-----------------------------------------------------------------------------
-
- logical function med_methods_Distgrid_Match(distGrid1, distGrid2, rc)
- use ESMF, only : ESMF_DistGrid, ESMF_DistGridGet
- ! Arguments
- type(ESMF_DistGrid), intent(in) :: distGrid1
- type(ESMF_DistGrid), intent(in) :: distGrid2
- integer, intent(out), optional :: rc
-
- ! Local Variables
- integer :: dimCount1, dimCount2
- integer :: tileCount1, tileCount2
- integer, allocatable :: minIndexPTile1(:,:), minIndexPTile2(:,:)
- integer, allocatable :: maxIndexPTile1(:,:), maxIndexPTile2(:,:)
- integer, allocatable :: elementCountPTile1(:), elementCountPTile2(:)
- character(len=*), parameter :: subname='(med_methods_Distgrid_Match)'
- ! ----------------------------------------------
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(subname//": called", ESMF_LOGMSG_INFO)
- endif
-
- if(present(rc)) rc = ESMF_SUCCESS
- med_methods_Distgrid_Match = .true.
-
- call ESMF_DistGridGet(distGrid1, &
- dimCount=dimCount1, tileCount=tileCount1, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_DistGridGet(distGrid2, &
- dimCount=dimCount2, tileCount=tileCount2, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if ( dimCount1 /= dimCount2) then
- med_methods_Distgrid_Match = .false.
- if (dbug_flag > 1) then
- call ESMF_LogWrite(trim(subname)//": Grid dimCount MISMATCH ", &
- ESMF_LOGMSG_INFO)
- endif
- endif
-
- if ( tileCount1 /= tileCount2) then
- med_methods_Distgrid_Match = .false.
- if (dbug_flag > 1) then
- call ESMF_LogWrite(trim(subname)//": Grid tileCount MISMATCH ", &
- ESMF_LOGMSG_INFO)
- endif
- endif
-
- allocate(elementCountPTile1(tileCount1))
- allocate(elementCountPTile2(tileCount2))
- allocate(minIndexPTile1(dimCount1,tileCount1))
- allocate(minIndexPTile2(dimCount2,tileCount2))
- allocate(maxIndexPTile1(dimCount1,tileCount1))
- allocate(maxIndexPTile2(dimCount2,tileCount2))
-
- call ESMF_DistGridGet(distGrid1, &
- elementCountPTile=elementCountPTile1, &
- minIndexPTile=minIndexPTile1, &
- maxIndexPTile=maxIndexPTile1, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_DistGridGet(distGrid2, &
- elementCountPTile=elementCountPTile2, &
- minIndexPTile=minIndexPTile2, &
- maxIndexPTile=maxIndexPTile2, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if ( ANY((elementCountPTile1 - elementCountPTile2) .NE. 0) ) then
- med_methods_Distgrid_Match = .false.
- if (dbug_flag > 1) then
- call ESMF_LogWrite(trim(subname)//": Grid elementCountPTile MISMATCH ", &
- ESMF_LOGMSG_INFO)
- endif
- endif
-
- if ( ANY((minIndexPTile1 - minIndexPTile2) .NE. 0) ) then
- med_methods_Distgrid_Match = .false.
- if (dbug_flag > 1) then
- call ESMF_LogWrite(trim(subname)//": Grid minIndexPTile MISMATCH ", &
- ESMF_LOGMSG_INFO)
- endif
- endif
-
- if ( ANY((maxIndexPTile1 - maxIndexPTile2) .NE. 0) ) then
- med_methods_Distgrid_Match = .false.
- if (dbug_flag > 1) then
- call ESMF_LogWrite(trim(subname)//": Grid maxIndexPTile MISMATCH ", &
- ESMF_LOGMSG_INFO)
- endif
- endif
-
- deallocate(elementCountPTile1)
- deallocate(elementCountPTile2)
- deallocate(minIndexPTile1)
- deallocate(minIndexPTile2)
- deallocate(maxIndexPTile1)
- deallocate(maxIndexPTile2)
-
- ! TODO: Optionally Check Coordinates
-
- if (dbug_flag > 10) then
- call ESMF_LogWrite(subname//": done", ESMF_LOGMSG_INFO)
- endif
-
- end function med_methods_Distgrid_Match
-
!================================================================================
subroutine med_methods_State_GetScalar(state, scalar_id, scalar_value, flds_scalar_name, flds_scalar_num, rc)
@@ -3092,7 +2243,7 @@ subroutine med_methods_State_GetScalar(state, scalar_id, scalar_value, flds_scal
integer :: mytask, ierr, len, icount
type(ESMF_VM) :: vm
type(ESMF_Field) :: field
- real(R8), pointer :: farrayptr(:,:)
+ real(R8), pointer :: farrayptr(:,:) => null()
real(r8) :: tmp(1)
character(len=*), parameter :: subname='(med_methods_State_GetScalar)'
! ----------------------------------------------
@@ -3129,7 +2280,7 @@ subroutine med_methods_State_GetScalar(state, scalar_id, scalar_value, flds_scal
else
scalar_value = 0.0_R8
call ESMF_LogWrite(trim(subname)//": no ESMF_Field found named: "//trim(flds_scalar_name), ESMF_LOGMSG_INFO)
- end if
+ end if
end subroutine med_methods_State_GetScalar
@@ -3156,7 +2307,7 @@ subroutine med_methods_State_SetScalar(scalar_value, scalar_id, State, flds_scal
integer :: mytask
type(ESMF_Field) :: field
type(ESMF_VM) :: vm
- real(R8), pointer :: farrayptr(:,:)
+ real(R8), pointer :: farrayptr(:,:) => null()
character(len=*), parameter :: subname='(med_methods_State_SetScalar)'
! ----------------------------------------------
@@ -3186,166 +2337,9 @@ end subroutine med_methods_State_SetScalar
!-----------------------------------------------------------------------------
- subroutine med_methods_State_UpdateTimestamp(state, time, rc)
-
- use NUOPC , only : NUOPC_GetStateMemberLists
- use ESMF , only : ESMF_State, ESMF_Time, ESMF_Field, ESMF_SUCCESS
-
- ! input/output variables
- type(ESMF_State) , intent(inout) :: state
- type(ESMF_Time) , intent(in) :: time
- integer , intent(out) :: rc
-
- ! local variables
- integer :: i
- type(ESMF_Field),pointer :: fieldList(:)
- character(len=*), parameter :: subname='(med_methods_State_UpdateTimestamp)'
- ! ----------------------------------------------
-
- rc = ESMF_SUCCESS
-
- call NUOPC_GetStateMemberLists(state, fieldList=fieldList, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- do i=1, size(fieldList)
- call med_methods_Field_UpdateTimestamp(fieldList(i), time, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- enddo
-
- end subroutine med_methods_State_UpdateTimestamp
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_Field_UpdateTimestamp(field, time, rc)
-
- use ESMF, only : ESMF_Field, ESMF_Time, ESMF_TimeGet, ESMF_AttributeSet, ESMF_ATTNEST_ON, ESMF_SUCCESS
-
- ! input/output variables
- type(ESMF_Field) , intent(inout) :: field
- type(ESMF_Time) , intent(in) :: time
- integer , intent(out) :: rc
-
- ! local variables
- integer :: yy, mm, dd, h, m, s, ms, us, ns
- character(len=*), parameter :: subname='(med_methods_Field_UpdateTimestamp)'
- ! ----------------------------------------------
-
- rc = ESMF_SUCCESS
-
- call ESMF_TimeGet(time, yy=yy, mm=mm, dd=dd, h=h, m=m, s=s, ms=ms, us=us, &
- ns=ns, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_AttributeSet(field, &
- name="TimeStamp", valueList=(/yy,mm,dd,h,m,s,ms,us,ns/), &
- convention="NUOPC", purpose="Instance", &
- attnestflag=ESMF_ATTNEST_ON, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- end subroutine med_methods_Field_UpdateTimestamp
-
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_State_FldDebug(state, flds_scalar_name, prefix, ymd, tod, logunit, rc)
-
- use ESMF, only : ESMF_State, ESMF_StateGet, ESMF_Field, ESMF_FieldGet
-
- ! input/output variables
- type(ESMF_State) :: state
- character(len=*) , intent(in) :: flds_scalar_name
- character(len=*) , intent(in) :: prefix
- integer , intent(in) :: ymd
- integer , intent(in) :: tod
- integer , intent(in) :: logunit
- integer , intent(out) :: rc
-
- ! local variables
- integer :: n, nfld, ungridded_index
- integer :: lsize
- real(R8), pointer :: dataPtr1d(:)
- real(R8), pointer :: dataPtr2d(:,:)
- integer :: fieldCount
- integer :: ungriddedUBound(1)
- integer :: gridToFieldMap(1)
- character(len=ESMF_MAXSTR) :: string
- type(ESMF_Field) , allocatable :: lfields(:)
- integer , allocatable :: dimCounts(:)
- character(len=ESMF_MAXSTR) , allocatable :: fieldNameList(:)
- !-----------------------------------------------------
-
- ! Determine the list of fields and the dimension count for each field
- call ESMF_StateGet(state, itemCount=fieldCount, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- allocate(fieldNameList(fieldCount))
- allocate(lfields(fieldCount))
- allocate(dimCounts(fieldCount))
-
- call ESMF_StateGet(state, itemNameList=fieldNameList, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- do nfld=1, fieldCount
- call ESMF_StateGet(state, itemName=trim(fieldNameList(nfld)), field=lfields(nfld), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfields(nfld), dimCount=dimCounts(nfld), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- end do
-
- ! Determine local size of field
- do nfld=1, fieldCount
- if (dimCounts(nfld) == 1) then
- call ESMF_FieldGet(lfields(nfld), farrayPtr=dataPtr1d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lsize = size(dataPtr1d)
- exit
- end if
- end do
-
- ! Write out debug output
- do n = 1,lsize
- do nfld=1, fieldCount
- if (dimCounts(nfld) == 1) then
- call ESMF_FieldGet(lfields(nfld), farrayPtr=dataPtr1d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (trim(fieldNameList(nfld)) /= flds_scalar_name .and. dataPtr1d(n) /= 0.) then
- string = trim(prefix) // ' ymd, tod, index, '// trim(fieldNameList(nfld)) //' = '
- write(logunit,100) trim(string), ymd, tod, n, dataPtr1d(n)
- end if
- else if (dimCounts(nfld) == 2) then
- call ESMF_FieldGet(lfields(nfld), ungriddedUBound=ungriddedUBound, gridtoFieldMap=gridToFieldMap, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfields(nfld), farrayPtr=dataPtr2d, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- do ungridded_index = 1,ungriddedUBound(1)
- if (trim(fieldNameList(nfld)) /= flds_scalar_name) then
- string = trim(prefix) // ' ymd, tod, lev, index, '// trim(fieldNameList(nfld)) //' = '
- if (gridToFieldMap(1) == 1) then
- if (dataPtr2d(n,ungridded_index) /= 0.) then
- write(logunit,101) trim(string), ymd, tod, ungridded_index, n, dataPtr2d(n,ungridded_index)
- end if
- else if (gridToFieldMap(1) == 2) then
- if (dataPtr2d(ungridded_index,n) /= 0.) then
- write(logunit,101) trim(string), ymd, tod, ungridded_index, n, dataPtr2d(ungridded_index,n)
- end if
- end if
- end if
- end do
- end if
- end do
- end do
-100 format(a60,3(i8,2x),d21.14)
-101 format(a60,4(i8,2x),d21.14)
-
- deallocate(fieldNameList)
- deallocate(lfields)
- deallocate(dimCounts)
-
- end subroutine med_methods_State_FldDebug
-
- !-----------------------------------------------------------------------------
-
subroutine med_methods_FB_getNumFlds(FB, string, nflds, rc)
- ! ----------------------------------------------
+ ! ----------------------------------------------
! Determine if fieldbundle is created and if so, the number of non-scalar
! fields in the field bundle
! ----------------------------------------------
@@ -3363,7 +2357,7 @@ subroutine med_methods_FB_getNumFlds(FB, string, nflds, rc)
if (.not. ESMF_FieldBundleIsCreated(FB)) then
call ESMF_LogWrite(trim(string)//": has not been created, returning", ESMF_LOGMSG_INFO)
- nflds = 0
+ nflds = 0
else
! Note - the scalar field has been removed from all mediator
! field bundles - so this is why we check if the fieldCount is 0 and not 1 here
@@ -3377,74 +2371,4 @@ subroutine med_methods_FB_getNumFlds(FB, string, nflds, rc)
end subroutine med_methods_FB_getNumFlds
- !-----------------------------------------------------------------------------
-
- subroutine med_methods_States_GetSharedFlds(State1, State2, flds_scalar_name, fldnames_shared, rc)
-
- ! ----------------------------------------------
- ! Get shared Fld names between State1 and State2 and
- ! allocate the return array fldnames_shared
- ! ----------------------------------------------
-
- use ESMF, only : ESMF_State, ESMF_StateGet, ESMF_MAXSTR
-
- ! input/output variables
- type(ESMF_State) , intent(in) :: State1
- type(ESMF_State) , intent(in) :: State2
- character(len=*) , intent(in) :: flds_scalar_name
- character(len=ESMF_MAXSTR) , pointer :: fldnames_shared(:)
- integer , intent(inout) :: rc
-
- ! local variables
- integer :: ncnt1, ncnt2
- integer :: n1, n2, nshr
- character(len=ESMF_MAXSTR), allocatable :: fldnames1(:)
- character(len=ESMF_MAXSTR), allocatable :: fldnames2(:)
- character(len=*), parameter :: subname='(med_methods_States_GetSharedFlds)'
- ! ----------------------------------------------
-
- rc = ESMF_SUCCESS
-
- if (associated(fldnames_shared)) then
- call ESMF_LogWrite(trim(subname)//": ERROR fldnames_shared must not be associated ", ESMF_LOGMSG_INFO)
- rc = ESMF_FAILURE
- RETURN
- end if
-
- call ESMF_StateGet(State1, itemCount=ncnt1, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(fldnames1(ncnt1))
- call ESMF_StateGet(State1, itemNameList=fldnames1, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call ESMF_StateGet(State2, itemCount=ncnt2, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(fldnames2(ncnt2))
- call ESMF_StateGet(State2, itemNameList=fldnames2, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- nshr = 0
- do n1 = 1,ncnt1
- do n2 = 1,ncnt2
- if (trim(fldnames1(n1)) == trim(fldnames2(n2)) .and. trim(fldnames1(n1)) /= flds_scalar_name) then
- nshr = nshr + 1
- end if
- end do
- end do
- allocate(fldnames_shared(nshr))
-
- nshr = 0
- do n1 = 1,ncnt1
- do n2 = 1,ncnt2
- if (trim(fldnames1(n1)) == trim(fldnames2(n2)) .and. trim(fldnames1(n1)) /= flds_scalar_name) then
- nshr = nshr + 1
- fldnames_shared(nshr) = trim(fldnames1(n1))
- exit
- end if
- end do
- end do
-
- end subroutine med_methods_States_GetSharedFlds
-
end module med_methods_mod
-
diff --git a/mediator/med_phases_aofluxes_mod.F90 b/mediator/med_phases_aofluxes_mod.F90
index 6a303da80..8ab54e4fd 100644
--- a/mediator/med_phases_aofluxes_mod.F90
+++ b/mediator/med_phases_aofluxes_mod.F90
@@ -9,8 +9,7 @@ module med_phases_aofluxes_mod
use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk
use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_init => med_methods_FB_init
- use med_map_mod , only : med_map_FB_Regrid_Norm
+ use med_map_mod , only : med_map_field_packed
use perf_mod , only : t_startf, t_stopf
implicit none
@@ -34,44 +33,44 @@ module med_phases_aofluxes_mod
!--------------------------------------------------------------------------
type aoflux_type
- integer , pointer :: mask (:) ! ocn domain mask: 0 <=> inactive cell
- real(R8) , pointer :: rmask (:) ! ocn domain mask: 0 <=> inactive cell
- real(R8) , pointer :: lats (:) ! latitudes (degrees)
- real(R8) , pointer :: lons (:) ! longitudes (degrees)
- real(R8) , pointer :: uocn (:) ! ocn velocity, zonal
- real(R8) , pointer :: vocn (:) ! ocn velocity, meridional
- real(R8) , pointer :: tocn (:) ! ocean temperature
- real(R8) , pointer :: zbot (:) ! atm level height
- real(R8) , pointer :: ubot (:) ! atm velocity, zonal
- real(R8) , pointer :: vbot (:) ! atm velocity, meridional
- real(R8) , pointer :: thbot (:) ! atm potential T
- real(R8) , pointer :: shum (:) ! atm specific humidity
- real(R8) , pointer :: shum_16O (:) ! atm H2O tracer
- real(R8) , pointer :: shum_HDO (:) ! atm HDO tracer
- real(R8) , pointer :: shum_18O (:) ! atm H218O tracer
- real(R8) , pointer :: roce_16O (:) ! ocn H2O ratio
- real(R8) , pointer :: roce_HDO (:) ! ocn HDO ratio
- real(R8) , pointer :: roce_18O (:) ! ocn H218O ratio
- real(R8) , pointer :: pbot (:) ! atm bottom pressure
- real(R8) , pointer :: dens (:) ! atm bottom density
- real(R8) , pointer :: tbot (:) ! atm bottom surface T
- real(R8) , pointer :: sen (:) ! heat flux: sensible
- real(R8) , pointer :: lat (:) ! heat flux: latent
- real(R8) , pointer :: lwup (:) ! lwup over ocean
- real(R8) , pointer :: evap (:) ! water flux: evaporation
- real(R8) , pointer :: evap_16O (:) ! H2O flux: evaporation
- real(R8) , pointer :: evap_HDO (:) ! HDO flux: evaporation
- real(R8) , pointer :: evap_18O (:) ! H218O flux: evaporation
- real(R8) , pointer :: taux (:) ! wind stress, zonal
- real(R8) , pointer :: tauy (:) ! wind stress, meridional
- real(R8) , pointer :: tref (:) ! diagnostic: 2m ref T
- real(R8) , pointer :: qref (:) ! diagnostic: 2m ref Q
- real(R8) , pointer :: u10 (:) ! diagnostic: 10m wind speed
- real(R8) , pointer :: duu10n (:) ! diagnostic: 10m wind speed squared
- real(R8) , pointer :: lwdn (:) ! long wave, downward
- real(R8) , pointer :: ustar (:) ! saved ustar
- real(R8) , pointer :: re (:) ! saved re
- real(R8) , pointer :: ssq (:) ! saved sq
+ integer , pointer :: mask (:) => null() ! ocn domain mask: 0 <=> inactive cell
+ real(R8) , pointer :: rmask (:) => null() ! ocn domain mask: 0 <=> inactive cell
+ real(R8) , pointer :: lats (:) => null() ! latitudes (degrees)
+ real(R8) , pointer :: lons (:) => null() ! longitudes (degrees)
+ real(R8) , pointer :: uocn (:) => null() ! ocn velocity, zonal
+ real(R8) , pointer :: vocn (:) => null() ! ocn velocity, meridional
+ real(R8) , pointer :: tocn (:) => null() ! ocean temperature
+ real(R8) , pointer :: zbot (:) => null() ! atm level height
+ real(R8) , pointer :: ubot (:) => null() ! atm velocity, zonal
+ real(R8) , pointer :: vbot (:) => null() ! atm velocity, meridional
+ real(R8) , pointer :: thbot (:) => null() ! atm potential T
+ real(R8) , pointer :: shum (:) => null() ! atm specific humidity
+ real(R8) , pointer :: shum_16O (:) => null() ! atm H2O tracer
+ real(R8) , pointer :: shum_HDO (:) => null() ! atm HDO tracer
+ real(R8) , pointer :: shum_18O (:) => null() ! atm H218O tracer
+ real(R8) , pointer :: roce_16O (:) => null() ! ocn H2O ratio
+ real(R8) , pointer :: roce_HDO (:) => null() ! ocn HDO ratio
+ real(R8) , pointer :: roce_18O (:) => null() ! ocn H218O ratio
+ real(R8) , pointer :: pbot (:) => null() ! atm bottom pressure
+ real(R8) , pointer :: dens (:) => null() ! atm bottom density
+ real(R8) , pointer :: tbot (:) => null() ! atm bottom surface T
+ real(R8) , pointer :: sen (:) => null() ! heat flux: sensible
+ real(R8) , pointer :: lat (:) => null() ! heat flux: latent
+ real(R8) , pointer :: lwup (:) => null() ! lwup over ocean
+ real(R8) , pointer :: evap (:) => null() ! water flux: evaporation
+ real(R8) , pointer :: evap_16O (:) => null() ! H2O flux: evaporation
+ real(R8) , pointer :: evap_HDO (:) => null() ! HDO flux: evaporation
+ real(R8) , pointer :: evap_18O (:) => null() ! H218O flux: evaporation
+ real(R8) , pointer :: taux (:) => null() ! wind stress, zonal
+ real(R8) , pointer :: tauy (:) => null() ! wind stress, meridional
+ real(R8) , pointer :: tref (:) => null() ! diagnostic: 2m ref T
+ real(R8) , pointer :: qref (:) => null() ! diagnostic: 2m ref Q
+ real(R8) , pointer :: u10 (:) => null() ! diagnostic: 10m wind speed
+ real(R8) , pointer :: duu10n (:) => null() ! diagnostic: 10m wind speed squared
+ real(R8) , pointer :: lwdn (:) => null() ! long wave, downward
+ real(R8) , pointer :: ustar (:) => null() ! saved ustar
+ real(R8) , pointer :: re (:) => null() ! saved re
+ real(R8) , pointer :: ssq (:) => null() ! saved sq
logical :: created ! has this data type been created
end type aoflux_type
@@ -94,6 +93,7 @@ subroutine med_phases_aofluxes_run(gcomp, rc)
use NUOPC , only : NUOPC_IsConnected, NUOPC_CompAttributeGet
use esmFlds , only : med_fldList_GetNumFlds, med_fldList_GetFldNames
use esmFlds , only : fldListFr, fldListMed_aoflux, compatm, compocn, compname
+ use NUOPC , only : NUOPC_CompAttributeGet
!-----------------------------------------------------------------------
! Compute atm/ocn fluxes
@@ -153,18 +153,15 @@ subroutine med_phases_aofluxes_run(gcomp, rc)
call memcheck(subname, 5, mastertask)
! TODO(mvertens, 2019-01-12): ONLY regrid atm import fields that are needed for the atm/ocn flux calculation
-
! Regrid atm import field bundle from atm to ocn grid as input for ocn/atm flux calculation
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(compatm)%flds, &
- srccomp=compatm, destcomp=compocn, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImp(compatm,compatm), &
FBDst=is_local%wrap%FBImp(compatm,compocn), &
FBFracSrc=is_local%wrap%FBFrac(compatm), &
- FBNormOne=is_local%wrap%FBNormOne(compatm,compocn,:), &
- RouteHandles=is_local%wrap%RH(compatm,compocn,:), &
- string=trim(compname(compatm))//'2'//trim(compname(compocn)), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_normOne=is_local%wrap%field_normOne(compatm,compocn,:), &
+ packed_data=is_local%wrap%packed_data(compatm,compocn,:), &
+ routehandles=is_local%wrap%RH(compatm,compocn,:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
! Calculate atm/ocn fluxes on the destination grid
call med_aofluxes_run(gcomp, aoflux, rc)
@@ -189,7 +186,7 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux,
use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_VM
use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldBundle, ESMF_VMGet
use NUOPC , only : NUOPC_CompAttributeGet
-
+ use shr_flux_mod , only : shr_flux_adjust_constants
!-----------------------------------------------------------------------
! Initialize pointers to the module variables
!-----------------------------------------------------------------------
@@ -207,11 +204,15 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux,
integer :: iam
integer :: n
integer :: lsize
- real(R8), pointer :: ofrac(:)
- real(R8), pointer :: ifrac(:)
+ real(R8), pointer :: ofrac(:) => null()
+ real(R8), pointer :: ifrac(:) => null()
character(CL) :: cvalue
logical :: flds_wiso ! use case
character(len=CX) :: tmpstr
+ real(R8) :: flux_convergence ! convergence criteria for imlicit flux computation
+ integer :: flux_max_iteration ! maximum number of iterations for convergence
+ logical :: coldair_outbreak_mod ! cold air outbreak adjustment (Mahrt & Sun 1995,MWR)
+ logical :: isPresent, isSet
character(*),parameter :: subName = '(med_aofluxes_init) '
!-----------------------------------------------------------------------
@@ -381,6 +382,40 @@ subroutine med_aofluxes_init(gcomp, aoflux, FBAtm, FBOcn, FBFrac, FBMed_aoflux,
! call FB_getFldPtr(FBFrac , fldname='ifrac' , fldptr1=ifrac, rc=rc)
! if (chkerr(rc,__LINE__,u_FILE_u)) return
! where (ofrac(:) + ifrac(:) <= 0.0_R8) mask(:) = 0
+ !----------------------------------
+ ! Get config variables on first call
+ !----------------------------------
+
+ call NUOPC_CompAttributeGet(gcomp, name='coldair_outbreak_mod', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ read(cvalue,*) coldair_outbreak_mod
+ else
+ coldair_outbreak_mod = .false.
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='flux_max_iteration', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ read(cvalue,*) flux_max_iteration
+ else
+ flux_max_iteration = 1
+ end if
+
+ call NUOPC_CompAttributeGet(gcomp, name='flux_convergence', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (isPresent .and. isSet) then
+ read(cvalue,*) flux_convergence
+ else
+ flux_convergence = 0.0_r8
+ end if
+
+ call shr_flux_adjust_constants(&
+ flux_convergence_tolerance=flux_convergence, &
+ flux_convergence_max_iteration=flux_max_iteration, &
+ coldair_outbreak_mod=coldair_outbreak_mod)
+
+
if (dbug_flag > 5) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
@@ -397,7 +432,7 @@ subroutine med_aofluxes_run(gcomp, aoflux, rc)
use ESMF , only : ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet, ESMF_TimeIntervalGet
use ESMF , only : ESMF_LogWrite, ESMF_LogMsg_Info
use NUOPC , only : NUOPC_CompAttributeGet
- use shr_flux_mod , only : shr_flux_atmocn, shr_flux_adjust_constants
+ use shr_flux_mod , only : shr_flux_atmocn
!-----------------------------------------------------------------------
! Determine atm/ocn fluxes eother on atm or on ocean grid
@@ -414,53 +449,13 @@ subroutine med_aofluxes_run(gcomp, aoflux, rc)
character(CL) :: cvalue
integer :: n,i ! indices
integer :: lsize ! local size
- real(R8) :: flux_convergence ! convergence criteria for imlicit flux computation
- integer :: flux_max_iteration ! maximum number of iterations for convergence
- logical :: coldair_outbreak_mod ! cold air outbreak adjustment (Mahrt & Sun 1995,MWR)
character(len=CX) :: tmpstr
logical :: isPresent, isSet
- logical,save :: first_call = .true.
character(*),parameter :: subName = '(med_aofluxes_run) '
!-----------------------------------------------------------------------
call t_startf('MED:'//subname)
- !----------------------------------
- ! Get config variables on first call
- !----------------------------------
-
- if (first_call) then
- call NUOPC_CompAttributeGet(gcomp, name='coldair_outbreak_mod', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent .and. isSet) then
- read(cvalue,*) coldair_outbreak_mod
- else
- coldair_outbreak_mod = .false.
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='flux_max_iteration', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent .and. isSet) then
- read(cvalue,*) flux_max_iteration
- else
- flux_max_iteration = 1
- end if
-
- call NUOPC_CompAttributeGet(gcomp, name='flux_convergence', value=cvalue, isPresent=isPresent, isSet=isSet, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- if (isPresent .and. isSet) then
- read(cvalue,*) flux_convergence
- else
- flux_convergence = 0.0_r8
- end if
-
- call shr_flux_adjust_constants(&
- flux_convergence_tolerance=flux_convergence, &
- flux_convergence_max_iteration=flux_max_iteration, &
- coldair_outbreak_mod=coldair_outbreak_mod)
-
- first_call = .false.
- end if
!----------------------------------
! Determine the compute mask
diff --git a/mediator/med_phases_history_mod.F90 b/mediator/med_phases_history_mod.F90
index f4f60f09f..743ee75af 100644
--- a/mediator/med_phases_history_mod.F90
+++ b/mediator/med_phases_history_mod.F90
@@ -24,7 +24,6 @@ module med_phases_history_mod
use med_utils_mod , only : chkerr => med_utils_ChkErr
use med_methods_mod , only : FB_reset => med_methods_FB_reset
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
use med_methods_mod , only : FB_accum => med_methods_FB_accum
use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
use med_internalstate_mod , only : InternalState, mastertask, logunit
@@ -256,7 +255,6 @@ subroutine med_phases_history_write(gcomp, rc)
call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
call ESMF_VMGet(vm, localPet=iam, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -267,7 +265,6 @@ subroutine med_phases_history_write(gcomp, rc)
nullify(is_local%wrap)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
call NUOPC_CompAttributeGet(gcomp, name='case_name', value=case_name, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -427,6 +424,15 @@ subroutine med_phases_history_write(gcomp, rc)
call med_io_write(hist_file, iam, is_local%wrap%FBMed_ocnalb_o, &
nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='Med_alb_ocn', rc=rc)
end if
+ if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o,rc=rc) .and. &
+ ESMF_FieldBundleIsCreated(is_local%wrap%FBImp(compatm,compocn))) then
+ ! This provides the atm input on the ocn mesh needed for that atm/ocn calculation
+ ! that currently is restricted to the ocn mesh
+ nx = is_local%wrap%nx(compocn)
+ ny = is_local%wrap%ny(compocn)
+ call med_io_write(hist_file, iam, is_local%wrap%FBImp(compatm,compocn), &
+ nx=nx, ny=ny, nt=1, whead=whead, wdata=wdata, pre='AtmImp_ocn', rc=rc)
+ end if
if (ESMF_FieldBundleIsCreated(is_local%wrap%FBMed_aoflux_o,rc=rc)) then
nx = is_local%wrap%nx(compocn)
ny = is_local%wrap%ny(compocn)
diff --git a/mediator/med_phases_ocnalb_mod.F90 b/mediator/med_phases_ocnalb_mod.F90
index 957641d5e..11822da64 100644
--- a/mediator/med_phases_ocnalb_mod.F90
+++ b/mediator/med_phases_ocnalb_mod.F90
@@ -1,17 +1,14 @@
module med_phases_ocnalb_mod
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
- use shr_const_mod , only : shr_const_pi
- use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
- use med_utils_mod , only : chkerr => med_utils_chkerr
use med_internalstate_mod , only : InternalState, logunit
- use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
- use med_methods_mod , only : FB_getFieldN => med_methods_FB_getFieldN
- use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
+ use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
+ use med_utils_mod , only : chkerr => med_utils_chkerr
+ use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
use esmFlds , only : mapconsf, mapnames, compatm, compocn
use perf_mod , only : t_startf, t_stopf
-#ifdef CESMCOUPLED
+#ifdef CESMCOUPLED
use shr_orb_mod , only : shr_orb_cosz, shr_orb_decl
use shr_orb_mod , only : shr_orb_params, SHR_ORB_UNDEF_INT, SHR_ORB_UNDEF_REAL
#endif
@@ -24,7 +21,6 @@ module med_phases_ocnalb_mod
!--------------------------------------------------------------------------
public med_phases_ocnalb_run
- public med_phases_ocnalb_mapo2a
!--------------------------------------------------------------------------
! Private interfaces
@@ -39,13 +35,13 @@ module med_phases_ocnalb_mod
!--------------------------------------------------------------------------
type ocnalb_type
- real(r8) , pointer :: lats (:) ! latitudes (degrees)
- real(r8) , pointer :: lons (:) ! longitudes (degrees)
- integer , pointer :: mask (:) ! ocn domain mask: 0 <=> inactive cell
- real(r8) , pointer :: anidr (:) ! albedo: near infrared, direct
- real(r8) , pointer :: avsdr (:) ! albedo: visible , direct
- real(r8) , pointer :: anidf (:) ! albedo: near infrared, diffuse
- real(r8) , pointer :: avsdf (:) ! albedo: visible , diffuse
+ real(r8) , pointer :: lats (:) => null() ! latitudes (degrees)
+ real(r8) , pointer :: lons (:) => null() ! longitudes (degrees)
+ integer , pointer :: mask (:) => null() ! ocn domain mask: 0 <=> inactive cell
+ real(r8) , pointer :: anidr (:) => null() ! albedo: near infrared, direct
+ real(r8) , pointer :: avsdr (:) => null() ! albedo: visible , direct
+ real(r8) , pointer :: anidf (:) => null() ! albedo: near infrared, diffuse
+ real(r8) , pointer :: avsdf (:) => null() ! albedo: visible , diffuse
logical :: created ! has memory been allocated here
end type ocnalb_type
@@ -77,9 +73,9 @@ subroutine med_phases_ocnalb_init(gcomp, ocnalb, rc)
!-----------------------------------------------------------------------
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS, ESMF_FAILURE
- use ESMF , only : ESMF_GridComp, ESMF_VM, ESMF_Field, ESMF_Grid, ESMF_Mesh, ESMF_GeomType_Flag
- use ESMF , only : ESMF_GridCompGet, ESMF_VMGet, ESMF_FieldGet, ESMF_GEOMTYPE_MESH
- use ESMF , only : ESMF_MeshGet
+ use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_Mesh, ESMF_MeshGet
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
+ use ESMF , only : ESMF_FieldBundleGet, ESMF_Field, ESMF_FieldGet
use ESMF , only : operator(==)
! Arguments
@@ -92,16 +88,17 @@ subroutine med_phases_ocnalb_init(gcomp, ocnalb, rc)
integer :: iam
type(ESMF_Field) :: lfield
type(ESMF_Mesh) :: lmesh
- type(ESMF_GeomType_Flag) :: geomtype
integer :: n
integer :: lsize
integer :: dimCount
integer :: spatialDim
integer :: numOwnedElements
type(InternalState) :: is_local
- real(R8), pointer :: ownedElemCoords(:)
+ real(R8), pointer :: ownedElemCoords(:) => null()
character(len=CL) :: tempc1,tempc2
logical :: mastertask
+ integer :: fieldCount
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
character(*), parameter :: subname = '(med_phases_ocnalb_init) '
!-----------------------------------------------------------------------
@@ -130,13 +127,24 @@ subroutine med_phases_ocnalb_init(gcomp, ocnalb, rc)
! These must must be on the ocean grid since the ocean albedo computation is on the ocean grid
! The following sets pointers to the module arrays
- call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, fldname='So_avsdr', fldptr1=ocnalb%avsdr, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBMed_ocnalb_o, fieldname='So_avsdr', field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, fldname='So_avsdf', fldptr1=ocnalb%avsdf, rc=rc)
+ call ESMF_FieldGet(lfield, farrayptr=ocnalb%avsdr, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, fldname='So_anidr', fldptr1=ocnalb%anidr, rc=rc)
+
+ call ESMF_FieldBundleGet(is_local%wrap%FBMed_ocnalb_o, fieldname='So_avsdf', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=ocnalb%avsdf, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_FieldBundleGet(is_local%wrap%FBMed_ocnalb_o, fieldname='So_anidr', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=ocnalb%anidr, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ call ESMF_FieldBundleGet(is_local%wrap%FBMed_ocnalb_o, fieldname='So_anidf', field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(is_local%wrap%FBMed_ocnalb_o, fldname='So_anidf', fldptr1=ocnalb%anidf, rc=rc)
+ call ESMF_FieldGet(lfield, farrayptr=ocnalb%anidf, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
!----------------------------------
@@ -145,42 +153,34 @@ subroutine med_phases_ocnalb_init(gcomp, ocnalb, rc)
! The following assumes that all fields in FBMed_ocnalb_o have the same grid - so
! only need to query field 1
- call FB_getFieldN(is_local%wrap%FBMed_ocnalb_o, fieldnum=1, field=lfield, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBMed_ocnalb_o, fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBMed_ocnalb_o, fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=lmesh, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- ! Determine if first field is on a grid or a mesh - default will be mesh
- call ESMF_FieldGet(lfield, geomtype=geomtype, rc=rc)
+ deallocate(fieldlist)
+ call ESMF_MeshGet(lmesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- if (geomtype == ESMF_GEOMTYPE_MESH) then
- call ESMF_LogWrite(trim(subname)//" : FBAtm is on a mesh ", ESMF_LOGMSG_INFO)
- call ESMF_FieldGet(lfield, mesh=lmesh, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_MeshGet(lmesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lsize = size(ocnalb%anidr)
- if (numOwnedElements /= lsize) then
- write(tempc1,'(i10)') numOwnedElements
- write(tempc2,'(i10)') lsize
- call ESMF_LogWrite(trim(subname)//": ERROR numOwnedElements "// trim(tempc1) // &
- " not equal to local size "// trim(tempc2), ESMF_LOGMSG_INFO)
- rc = ESMF_FAILURE
- return
- end if
- allocate(ownedElemCoords(spatialDim*numOwnedElements))
- allocate(ocnalb%lons(numOwnedElements))
- allocate(ocnalb%lats(numOwnedElements))
- call ESMF_MeshGet(lmesh, ownedElemCoords=ownedElemCoords)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- do n = 1,lsize
- ocnalb%lons(n) = ownedElemCoords(2*n-1)
- ocnalb%lats(n) = ownedElemCoords(2*n)
- end do
- else
- call ESMF_LogWrite(trim(subname)//": ERROR field bundle must be either on mesh", ESMF_LOGMSG_INFO)
- rc = ESMF_FAILURE
- return
+ lsize = size(ocnalb%anidr)
+ if (numOwnedElements /= lsize) then
+ write(tempc1,'(i10)') numOwnedElements
+ write(tempc2,'(i10)') lsize
+ call ESMF_LogWrite(trim(subname)//": ERROR numOwnedElements "// trim(tempc1) // &
+ " not equal to local size "// trim(tempc2), ESMF_LOGMSG_INFO)
+ rc = ESMF_FAILURE
+ return
end if
+ allocate(ownedElemCoords(spatialDim*numOwnedElements))
+ allocate(ocnalb%lons(numOwnedElements))
+ allocate(ocnalb%lats(numOwnedElements))
+ call ESMF_MeshGet(lmesh, ownedElemCoords=ownedElemCoords)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ do n = 1,lsize
+ ocnalb%lons(n) = ownedElemCoords(2*n-1)
+ ocnalb%lats(n) = ownedElemCoords(2*n)
+ end do
! Initialize orbital values
call med_phases_ocnalb_orbital_init(gcomp, logunit, iam==0, rc)
@@ -201,14 +201,16 @@ subroutine med_phases_ocnalb_run(gcomp, rc)
! Compute ocean albedos (on the ocean grid)
!-----------------------------------------------------------------------
- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_TimeInterval
- use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_Time, ESMF_TimeGet
- use ESMF , only : ESMF_VM, ESMF_VMGet
- use ESMF , only : ESMF_LogWrite, ESMF_LogFoundError
- use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_LOGMSG_INFO
- use ESMF , only : ESMF_FieldBundleIsCreated
- use ESMF , only : operator(+)
- use NUOPC , only : NUOPC_CompAttributeGet
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_TimeInterval
+ use ESMF , only : ESMF_Clock, ESMF_ClockGet, ESMF_Time, ESMF_TimeGet
+ use ESMF , only : ESMF_VM, ESMF_VMGet
+ use ESMF , only : ESMF_LogWrite, ESMF_LogFoundError
+ use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE, ESMF_LOGMSG_INFO
+ use ESMF , only : ESMF_Field, ESMF_FieldGet
+ use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldBundleIsCreated
+ use ESMF , only : operator(+)
+ use NUOPC , only : NUOPC_CompAttributeGet
+ use shr_const_mod , only : shr_const_pi
! input/output variables
type(ESMF_GridComp) :: gcomp
@@ -217,6 +219,7 @@ subroutine med_phases_ocnalb_run(gcomp, rc)
! local variables
type(ocnalb_type), save :: ocnalb
type(ESMF_VM) :: vm
+ type(ESMF_Field) :: lfield
integer :: iam
logical :: update_alb
type(InternalState) :: is_local
@@ -227,13 +230,12 @@ subroutine med_phases_ocnalb_run(gcomp, rc)
character(CL) :: cvalue
character(CS) :: starttype ! config start type
character(CL) :: runtype ! initial, continue, hybrid, branch
- character(CL) :: aoflux_grid
logical :: flux_albav ! flux avg option
real(R8) :: nextsw_cday ! calendar day of next atm shortwave
- real(R8), pointer :: ofrac(:)
- real(R8), pointer :: ofrad(:)
- real(R8), pointer :: ifrac(:)
- real(R8), pointer :: ifrad(:)
+ real(R8), pointer :: ofrac(:) => null()
+ real(R8), pointer :: ofrad(:) => null()
+ real(R8), pointer :: ifrac(:) => null()
+ real(R8), pointer :: ifrad(:) => null()
integer :: lsize ! local size
integer :: n,i ! indices
real(R8) :: rlat ! gridcell latitude in radians
@@ -378,7 +380,7 @@ subroutine med_phases_ocnalb_run(gcomp, rc)
! Solar declination
! Will only do albedo calculation if nextsw_cday is not -1.
write(msg,*)trim(subname)//' nextsw_cday = ',nextsw_cday
- call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
+ call ESMF_LogWrite(trim(msg), ESMF_LOGMSG_INFO)
if (nextsw_cday >= -0.5_r8) then
call shr_orb_decl(nextsw_cday, eccen, mvelpp,lambm0, obliqr, delta, eccf)
@@ -409,13 +411,21 @@ subroutine med_phases_ocnalb_run(gcomp, rc)
! Update current ifrad/ofrad values if albedo was updated in field bundle
if (update_alb) then
- call FB_getFldPtr(is_local%wrap%FBfrac(compocn), fldname='ifrac', fldptr1=ifrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compocn), fieldname='ifrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=ifrac, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compocn), fieldname='ifrad', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=ifrad, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compocn), fldname='ifrad', fldptr1=ifrad, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compocn), fieldname='ofrac', field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compocn), fldname='ofrac', fldptr1=ofrac, rc=rc)
+ call ESMF_FieldGet(lfield, farrayptr=ofrac, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBfrac(compocn), fldname='ofrad', fldptr1=ofrad, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compocn), fieldname='ofrad', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=ofrad, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
ifrad(:) = ifrac(:)
ofrad(:) = ofrac(:)
@@ -431,55 +441,6 @@ subroutine med_phases_ocnalb_run(gcomp, rc)
end subroutine med_phases_ocnalb_run
- !===============================================================================
-
- subroutine med_phases_ocnalb_mapo2a(gcomp, rc)
-
- !----------------------------------------------------------
- ! Map ocean albedos from ocn to atm grid
- !----------------------------------------------------------
-
- use ESMF , only : ESMF_GridComp
- use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use med_map_mod , only : med_map_FB_Regrid_Norm
- use esmFlds , only : fldListMed_ocnalb
- use esmFlds , only : compatm, compocn
-
- ! Arguments
- type(ESMF_GridComp) :: gcomp
- integer, intent(out) :: rc
-
- ! Local variables
- type(InternalState) :: is_local
- character(*), parameter :: subName = '(med_ocnalb_mapo2a) '
- !-----------------------------------------------------------------------
- call t_startf('MED:'//subname)
-
- if (dbug_flag > 5) then
- call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
- endif
- rc = ESMF_SUCCESS
-
- ! Get the internal state from gcomp
- nullify(is_local%wrap)
- call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- ! Map the field bundle from the ocean to the atm grid
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListMed_ocnalb%flds, &
- srccomp=compocn, destcomp=compatm, &
- FBSrc=is_local%wrap%FBMed_ocnalb_o, &
- FBDst=is_local%wrap%FBMed_ocnalb_a, &
- FBFracSrc=is_local%wrap%FBFrac(compocn), &
- FBNormOne=is_local%wrap%FBNormOne(compocn,compatm,:), &
- RouteHandles=is_local%wrap%RH(compocn,compatm,:), &
- string='FBMed_ocnalb_o_To_FBMed_ocnalb_a', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call t_stopf('MED:'//subname)
-
- end subroutine med_phases_ocnalb_mapo2a
-
!===============================================================================
subroutine med_phases_ocnalb_orbital_init(gcomp, logunit, mastertask, rc)
@@ -488,15 +449,15 @@ subroutine med_phases_ocnalb_orbital_init(gcomp, logunit, mastertask, rc)
! Obtain orbital related values
!----------------------------------------------------------
- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
use ESMF , only : ESMF_LogWrite, ESMF_LogFoundError, ESMF_LogSetError
- use ESMF , only : ESMf_SUCCESS, ESMF_FAILURE, ESMF_LOGMSG_INFO, ESMF_RC_NOT_VALID
+ use ESMF , only : ESMf_SUCCESS, ESMF_FAILURE, ESMF_LOGMSG_INFO, ESMF_RC_NOT_VALID
use NUOPC , only : NUOPC_CompAttributeGet
! input/output variables
type(ESMF_GridComp) :: gcomp
integer , intent(in) :: logunit ! output logunit
- logical , intent(in) :: mastertask
+ logical , intent(in) :: mastertask
integer , intent(out) :: rc ! output error
! local variables
@@ -507,7 +468,7 @@ subroutine med_phases_ocnalb_orbital_init(gcomp, logunit, mastertask, rc)
rc = ESMF_SUCCESS
-#ifdef CESMCOUPLED
+#ifdef CESMCOUPLED
! Determine orbital attributes from input
call NUOPC_CompAttributeGet(gcomp, name="orb_mode", value=cvalue, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -586,7 +547,7 @@ end subroutine med_phases_ocnalb_orbital_init
subroutine med_phases_ocnalb_orbital_update(clock, logunit, mastertask, eccen, obliqr, lambm0, mvelpp, rc)
!----------------------------------------------------------
- ! Update orbital settings
+ ! Update orbital settings
!----------------------------------------------------------
use ESMF, only : ESMF_Clock, ESMF_ClockGet, ESMF_Time, ESMF_TimeGet
@@ -594,7 +555,7 @@ subroutine med_phases_ocnalb_orbital_update(clock, logunit, mastertask, eccen,
! input/output variables
type(ESMF_Clock) , intent(in) :: clock
- integer , intent(in) :: logunit
+ integer , intent(in) :: logunit
logical , intent(in) :: mastertask
real(R8) , intent(inout) :: eccen ! orbital eccentricity
real(R8) , intent(inout) :: obliqr ! Earths obliquity in rad
@@ -604,7 +565,7 @@ subroutine med_phases_ocnalb_orbital_update(clock, logunit, mastertask, eccen,
! local variables
type(ESMF_Time) :: CurrTime ! current time
- integer :: year ! model year at current time
+ integer :: year ! model year at current time
integer :: orb_year ! orbital year for current orbital computation
character(len=CL) :: msgstr ! temporary
logical :: lprint
@@ -612,7 +573,7 @@ subroutine med_phases_ocnalb_orbital_update(clock, logunit, mastertask, eccen,
character(len=*) , parameter :: subname = "(lnd_orbital_update)"
!-------------------------------------------
-#ifdef CESMCOUPLED
+#ifdef CESMCOUPLED
rc = ESMF_SUCCESS
if (trim(orb_mode) == trim(orb_variable_year)) then
@@ -623,7 +584,7 @@ subroutine med_phases_ocnalb_orbital_update(clock, logunit, mastertask, eccen,
orb_year = orb_iyear + (year - orb_iyear_align)
lprint = mastertask
else
- orb_year = orb_iyear
+ orb_year = orb_iyear
if (first_time) then
lprint = mastertask
first_time = .false.
diff --git a/mediator/med_phases_prep_atm_mod.F90 b/mediator/med_phases_prep_atm_mod.F90
index 95994d30f..bacb7af31 100644
--- a/mediator/med_phases_prep_atm_mod.F90
+++ b/mediator/med_phases_prep_atm_mod.F90
@@ -6,27 +6,18 @@ module med_phases_prep_atm_mod
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only : ESMF_FieldBundleGet, ESMF_GridCompGet, ESMF_ClockGet, ESMF_TimeGet
- use ESMF , only : ESMF_GridComp, ESMF_Clock, ESMF_Time, ESMF_ClockPrint
- use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
- use med_utils_mod , only : memcheck => med_memcheck
- use med_utils_mod , only : chkerr => med_utils_ChkErr
- use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk
- use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
- use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_init => med_methods_FB_init
- use med_methods_mod , only : FB_rest => med_methods_FB_reset
- use med_methods_mod , only : FB_getNumFlds => med_methods_FB_getNumFlds
- use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
- use med_methods_mod , only : State_SetScalar => med_methods_State_SetScalar
+ use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
+ use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
+ use med_utils_mod , only : memcheck => med_memcheck
+ use med_utils_mod , only : chkerr => med_utils_ChkErr
+ use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
+ use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk
use med_merge_mod , only : med_merge_auto
- use med_map_mod , only : med_map_FB_Regrid_Norm
+ use med_map_mod , only : med_map_field_packed
use med_internalstate_mod , only : InternalState, mastertask
- use med_phases_ocnalb_mod , only : med_phases_ocnalb_mapo2a
use esmFlds , only : compatm, compocn, compice, ncomps, compname
- use esmFlds , only : fldListFr, fldListTo
- use esmFlds , only : fldListMed_aoflux
- use esmFlds , only : coupling_mode
+ use esmFlds , only : fldListTo, fldListMed_aoflux, coupling_mode
use perf_mod , only : t_startf, t_stopf
implicit none
@@ -48,11 +39,10 @@ subroutine med_phases_prep_atm(gcomp, rc)
integer, intent(out) :: rc
! local variables
- type(ESMF_Clock) :: clock
- type(ESMF_Time) :: time
+ type(ESMF_Field) :: lfield
character(len=64) :: timestr
type(InternalState) :: is_local
- real(R8), pointer :: dataPtr1(:),dataPtr2(:)
+ real(R8), pointer :: dataPtr1(:),dataPtr2(:) => null()
integer :: i, j, n, n1, ncnt
character(len=*),parameter :: subname='(med_phases_prep_atm)'
!-------------------------------------------------------------------------------
@@ -82,71 +72,53 @@ subroutine med_phases_prep_atm(gcomp, rc)
call ESMF_FieldBundleGet(is_local%wrap%FBExp(compatm), fieldCount=ncnt, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
if (ncnt == 0) then
call ESMF_LogWrite(trim(subname)//": only scalar data is present in FBexp(compatm), returning", &
ESMF_LOGMSG_INFO)
else
- !---------------------------------------
- !--- Get the current time from the clock
- !---------------------------------------
- call ESMF_GridCompGet(gcomp, clock=clock)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_ClockGet(clock,currtime=time,rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_TimeGet(time,timestring=timestr)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call ESMF_LogWrite(trim(subname)//": time = "//trim(timestr), ESMF_LOGMSG_INFO)
- if (dbug_flag > 1) then
- if (mastertask) then
- call ESMF_ClockPrint(clock, options="currTime", &
- preString="-------->"//trim(subname)//" mediating for: ", rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- end if
- end if
-
!---------------------------------------
!--- map import field bundles from n1 grid to atm grid - FBimp(:,compatm)
!---------------------------------------
do n1 = 1,ncomps
if (is_local%wrap%med_coupling_active(n1,compatm)) then
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(n1)%flds, &
- srccomp=n1, destcomp=compatm, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImp(n1,n1), &
FBDst=is_local%wrap%FBImp(n1,compatm), &
FBFracSrc=is_local%wrap%FBFrac(n1), &
- FBNormOne=is_local%wrap%FBNormOne(n1,compatm,:), &
- RouteHandles=is_local%wrap%RH(n1,compatm,:), &
- string=trim(compname(n1))//'2'//trim(compname(compatm)), rc=rc)
+ field_NormOne=is_local%wrap%field_normOne(n1,compatm,:), &
+ packed_data=is_local%wrap%packed_data(n1,compatm,:), &
+ routehandles=is_local%wrap%RH(n1,compatm,:), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- endif
- enddo
+ end if
+ end do
!---------------------------------------
!--- map ocean albedos from ocn to atm grid if appropriate
!---------------------------------------
if (trim(coupling_mode) == 'cesm') then
- call med_phases_ocnalb_mapo2a(gcomp, rc)
+ call med_map_field_packed( &
+ FBSrc=is_local%wrap%FBMed_ocnalb_o, &
+ FBDst=is_local%wrap%FBMed_ocnalb_a, &
+ FBFracSrc=is_local%wrap%FBFrac(compocn), &
+ field_normOne=is_local%wrap%field_normOne(compocn,compatm,:), &
+ packed_data=is_local%wrap%packed_data_ocnalb_o2a(:), &
+ routehandles=is_local%wrap%RH(compocn,compatm,:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
!---------------------------------------
!--- map atm/ocn fluxes from ocn to atm grid if appropriate
!---------------------------------------
- ! Assumption here is that fluxes are computed on the ocean grid
-
- if (trim(coupling_mode) == 'cesm' .or. &
- trim(coupling_mode) == 'hafs') then
- call med_map_FB_Regrid_Norm(&
- fldsSrc=fldListMed_aoflux%flds, &
- srccomp=compocn, destcomp=compatm, &
+ if (trim(coupling_mode) == 'cesm' .or. trim(coupling_mode) == 'hafs') then
+ ! Assumption here is that fluxes are computed on the ocean grid
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBMed_aoflux_o, &
FBDst=is_local%wrap%FBMed_aoflux_a, &
FBFracSrc=is_local%wrap%FBFrac(compocn), &
- FBNormOne=is_local%wrap%FBNormOne(compocn,compatm,:), &
- RouteHandles=is_local%wrap%RH(compocn,compatm,:), &
- string='FBMed_aoflux_o_To_FBMEd_aoflux_a', rc=rc)
+ field_normOne=is_local%wrap%field_normOne(compocn,compatm,:), &
+ packed_data=is_local%wrap%packed_data_aoflux_o2a(:), &
+ routehandles=is_local%wrap%RH(compocn,compatm,:), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
endif
@@ -154,22 +126,27 @@ subroutine med_phases_prep_atm(gcomp, rc)
!--- merge all fields to atm
!---------------------------------------
if (trim(coupling_mode) == 'cesm' .or. trim(coupling_mode) == 'hafs') then
- call med_merge_auto(trim(compname(compatm)), &
- is_local%wrap%FBExp(compatm), is_local%wrap%FBFrac(compatm), &
- is_local%wrap%FBImp(:,compatm), fldListTo(compatm), &
+ call med_merge_auto(compatm, &
+ is_local%wrap%med_coupling_active(:,compatm), &
+ is_local%wrap%FBExp(compatm), &
+ is_local%wrap%FBFrac(compatm), &
+ is_local%wrap%FBImp(:,compatm), &
+ fldListTo(compatm), &
FBMed1=is_local%wrap%FBMed_ocnalb_a, &
FBMed2=is_local%wrap%FBMed_aoflux_a, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
else if (trim(coupling_mode) == 'nems_frac' .or. trim(coupling_mode) == 'nems_orig') then
- call med_merge_auto(trim(compname(compatm)), &
- is_local%wrap%FBExp(compatm), is_local%wrap%FBFrac(compatm), &
- is_local%wrap%FBImp(:,compatm), fldListTo(compatm), rc=rc)
+ call med_merge_auto(compatm, &
+ is_local%wrap%med_coupling_active(:,compatm), &
+ is_local%wrap%FBExp(compatm), &
+ is_local%wrap%FBFrac(compatm), &
+ is_local%wrap%FBImp(:,compatm), &
+ fldListTo(compatm), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
if (dbug_flag > 1) then
- call FB_diagnose(is_local%wrap%FBExp(compatm), &
- string=trim(subname)//' FBexp(compatm) ', rc=rc)
+ call FB_diagnose(is_local%wrap%FBExp(compatm),string=trim(subname)//' FBexp(compatm) ', rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
@@ -179,28 +156,40 @@ subroutine med_phases_prep_atm(gcomp, rc)
! set fractions to send back to atm
if (FB_FldChk(is_local%wrap%FBExp(compatm), 'So_ofrac', rc=rc)) then
- call FB_GetFldPtr(is_local%wrap%FBExp(compatm), 'So_ofrac', dataptr1, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(is_local%wrap%FBFrac(compatm), 'ofrac', dataptr2, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compatm), fieldName='So_ofrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr1, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compatm), fieldName='ofrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr2, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
do n = 1,size(dataptr1)
dataptr1(n) = dataptr2(n)
end do
end if
if (FB_FldChk(is_local%wrap%FBExp(compatm), 'Si_ifrac', rc=rc)) then
- call FB_GetFldPtr(is_local%wrap%FBExp(compatm), 'Si_ifrac', dataptr1, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(is_local%wrap%FBFrac(compatm), 'ifrac', dataptr2, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compatm), fieldName='Si_ifrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr1, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compatm), fieldName='ifrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr2, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
do n = 1,size(dataptr1)
dataptr1(n) = dataptr2(n)
end do
end if
if (FB_FldChk(is_local%wrap%FBExp(compatm), 'Sl_lfrac', rc=rc)) then
- call FB_GetFldPtr(is_local%wrap%FBExp(compatm), 'Sl_lfrac', dataptr1, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(is_local%wrap%FBFrac(compatm), 'lfrac', dataptr2, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compatm), fieldName='Sl_lfrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr1, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(compatm), fieldName='lfrac', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayPtr=dataptr2, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
do n = 1,size(dataptr1)
dataptr1(n) = dataptr2(n)
end do
@@ -210,8 +199,6 @@ subroutine med_phases_prep_atm(gcomp, rc)
!--- update local scalar data
!---------------------------------------
- !is_local%wrap%scalar_data(1) =
-
!---------------------------------------
!--- clean up
!---------------------------------------
diff --git a/mediator/med_phases_prep_glc_mod.F90 b/mediator/med_phases_prep_glc_mod.F90
index 704c14520..24dc79e2b 100644
--- a/mediator/med_phases_prep_glc_mod.F90
+++ b/mediator/med_phases_prep_glc_mod.F90
@@ -8,25 +8,20 @@ module med_phases_prep_glc_mod
use NUOPC , only : NUOPC_CompAttributeGet
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_LOGMSG_ERROR, ESMF_SUCCESS, ESMF_FAILURE
use ESMF , only : ESMF_VM, ESMF_VMGet, ESMF_VMAllReduce, ESMF_REDUCE_SUM
- use ESMF , only : ESMF_FieldBundle, ESMF_Clock
- use ESMF , only : ESMF_Alarm, ESMF_ClockGetAlarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff
+ use ESMF , only : ESMF_Clock,ESMF_ClockGetAlarm
+ use ESMF , only : ESMF_Alarm, ESMF_AlarmIsRinging, ESMF_AlarmRingerOff
use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_FieldBundleAdd
use ESMF , only : ESMF_FieldBundleCreate, ESMF_FieldBundleIsCreated
use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate
use ESMF , only : ESMF_Array, ESMF_ArrayGet, ESMF_ArrayCreate, ESMF_ArrayDestroy
use ESMF , only : ESMF_DistGrid, ESMF_AttributeSet
- use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT
- use ESMF , only : ESMF_TYPEKIND_R8
- use esmFlds , only : compglc, complnd, mapbilnr, mapconsf, compname
- use esmFlds , only : med_fldlist_type
+ use ESMF , only : ESMF_Mesh, ESMF_MeshGet, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8
+ use esmFlds , only : compglc, complnd, mapbilnr, mapconsd, mapconsf, compname
use med_internalstate_mod , only : InternalState, mastertask, logunit
use med_constants_mod , only : dbug_flag=>med_constants_dbug_flag
- use med_internalstate_mod , only : InternalState, mastertask, logunit
- use med_map_mod , only : med_map_FB_Regrid_Norm, med_map_RH_is_created
- use med_map_mod , only : med_map_Fractions_Init
- use med_methods_mod , only : FB_Init => med_methods_FB_init
- use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr
+ use med_map_mod , only : med_map_routehandles_init, med_map_rh_is_created
+ use med_map_mod , only : med_map_field_normalized, med_map_field
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
use med_methods_mod , only : FB_reset => med_methods_FB_reset
use med_utils_mod , only : chkerr => med_utils_ChkErr
@@ -42,7 +37,7 @@ module med_phases_prep_glc_mod
public :: med_phases_prep_glc_accum
public :: med_phases_prep_glc_avg
- private :: med_phases_prep_glc_map_lnd2glc
+ private :: map_lnd2glc
private :: med_phases_prep_glc_renormalize_smb
! glc fields with multiple elevation classes: lnd->glc
@@ -54,7 +49,6 @@ module med_phases_prep_glc_mod
type(ESMF_FieldBundle) :: FBlndAccum_lnd
type(ESMF_FieldBundle) :: FBlndAccum_glc
integer :: FBlndAccumCnt
- type(med_fldlist_type) :: fldlist_lnd2glc
character(len=14) :: fldnames_fr_lnd(3) = (/'Flgl_qice_elev','Sl_tsrf_elev ','Sl_topo_elev '/)
character(len=14) :: fldnames_to_glc(2) = (/'Flgl_qice ','Sl_tsrf '/)
@@ -64,18 +58,22 @@ module med_phases_prep_glc_mod
logical :: smb_renormalize
! Needed if renormalize SMB
- type(ESMF_FieldBundle) :: FBglc_icemask
- type(ESMF_FieldBundle) :: FBlnd_icemask
- type(med_fldlist_type) :: fldlist_glc2lnd_icemask
- type(ESMF_FieldBundle) :: FBglc_frac
- type(ESMF_FieldBundle) :: FBlnd_frac
- type(med_fldlist_type) :: fldlist_glc2lnd_frac
- real(r8) , pointer :: aream_l(:) ! cell areas on land grid, for mapping
- real(r8) , pointer :: aream_g(:) ! cell areas on glc grid, for mapping
+ type(ESMF_Field) :: field_glc_icemask_g
+ type(ESMF_Field) :: field_glc_icemask_l
+ type(ESMF_Field) :: field_glc_frac_g
+ type(ESMF_Field) :: field_glc_frac_l
+ type(ESMF_Field) :: field_glc_frac_g_ec
+ type(ESMF_Field) :: field_glc_frac_l_ec
+ type(ESMF_Field) :: field_lnd_icemask_l
+ type(ESMF_Field) :: field_lfrac_g
+
+ real(r8) , pointer :: aream_l(:) => null() ! cell areas on land grid, for mapping
+ real(r8) , pointer :: aream_g(:) => null() ! cell areas on glc grid, for mapping
+
character(len=*), parameter :: qice_fieldname = 'Flgl_qice' ! Name of flux field giving surface mass balance
- character(len=*), parameter :: Sg_frac_field = 'Sg_ice_covered'
- character(len=*), parameter :: Sg_topo_field = 'Sg_topo'
- character(len=*), parameter :: Sg_icemask_field = 'Sg_icemask'
+ character(len=*), parameter :: Sg_frac_fieldname = 'Sg_ice_covered'
+ character(len=*), parameter :: Sg_topo_fieldname = 'Sg_topo'
+ character(len=*), parameter :: Sg_icemask_fieldname = 'Sg_icemask'
! Size of undistributed dimension from land
integer :: ungriddedCount ! this equals the number of elevation classes + 1 (for bare land)
@@ -100,21 +98,23 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
integer, intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- integer :: i,n,ncnt
- type(ESMF_Mesh) :: lmesh_glc
- type(ESMF_Mesh) :: lmesh_lnd
- type(ESMF_Field) :: lfield
- real(r8), pointer :: data2d_in(:,:)
- real(r8), pointer :: data2d_out(:,:)
- real(r8), pointer :: dataptr1d(:)
- character(len=CS) :: glc_renormalize_smb
- logical :: glc_coupled_fluxes
- type(ESMF_Array) :: larray
- type(ESMF_DistGrid) :: ldistgrid
- integer :: lsize
- logical :: isPresent
- integer :: ungriddedUBound_output(1) ! currently the size must equal 1 for rank 2 fieldds
+ type(InternalState) :: is_local
+ integer :: i,n,ncnt
+ type(ESMF_Mesh) :: lmesh_glc
+ type(ESMF_Mesh) :: lmesh_lnd
+ type(ESMF_Field) :: lfield
+ real(r8), pointer :: data2d_in(:,:) => null()
+ real(r8), pointer :: data2d_out(:,:) => null()
+ real(r8), pointer :: dataptr1d(:) => null()
+ character(len=CS) :: glc_renormalize_smb
+ logical :: glc_coupled_fluxes
+ type(ESMF_Array) :: larray
+ type(ESMF_DistGrid) :: ldistgrid
+ integer :: lsize
+ logical :: isPresent
+ integer :: fieldCount
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
+ integer :: ungriddedUBound_output(1) ! currently the size must equal 1 for rank 2 fieldds
character(len=*),parameter :: subname='(med_phases_prep_glc_init)'
!---------------------------------------
@@ -161,11 +161,14 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
ungriddedCount = ungriddedUBound_output(1)
! TODO: check that ungriddedCount = glc_nec+1
-
- call FB_GetFldPtr(is_local%wrap%FBImp(complnd,complnd), fldnames_fr_lnd(1), fldptr2=data2d_in, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, mesh=lmesh_lnd, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=lmesh_lnd, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(fieldlist)
FBlndAccum_lnd = ESMF_FieldBundleCreate(name='FBlndAccum_lnd', rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -185,15 +188,17 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
! Create accumulation field bundle from land on the glc grid
! Determine glc mesh from the mesh from the first export field to glc
! However FBlndAccum_glc has the fields fldnames_fr_lnd BUT ON the glc grid
-
- call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc), fldnames_to_glc(1), field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, mesh=lmesh_glc, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=lmesh_glc, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(fieldlist)
FBlndAccum_glc = ESMF_FieldBundleCreate(name='FBlndAccum_glc', rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
do n = 1,size(fldnames_fr_lnd)
lfield = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, name=fldnames_fr_lnd(n), &
meshloc=ESMF_MESHLOC_ELEMENT, &
@@ -205,26 +210,16 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
call FB_reset(FBlndAccum_glc, value=0.0_r8, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- FBlndAccumCnt = 0
-
- allocate(fldlist_lnd2glc%flds(3))
- fldlist_lnd2glc%flds(1)%shortname = trim(fldnames_fr_lnd(1))
- fldlist_lnd2glc%flds(2)%shortname = trim(fldnames_fr_lnd(2))
- fldlist_lnd2glc%flds(3)%shortname = trim(fldnames_fr_lnd(3))
- fldlist_lnd2glc%flds(1)%mapindex(compglc) = mapbilnr
- fldlist_lnd2glc%flds(2)%mapindex(compglc) = mapbilnr
- fldlist_lnd2glc%flds(3)%mapindex(compglc) = mapbilnr
- fldlist_lnd2glc%flds(1)%mapnorm(compglc) = 'lfrac'
- fldlist_lnd2glc%flds(2)%mapnorm(compglc) = 'lfrac'
- fldlist_lnd2glc%flds(3)%mapnorm(compglc) = 'lfrac'
+ ! Create land fraction field on glc mesh (this is just needed for normalization mapping)
+ field_lfrac_g = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
! Create route handle if it has not been created
if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,compglc,:),mapbilnr,rc=rc)) then
- call med_map_Fractions_init( gcomp, complnd, compglc, &
- FBSrc=FBlndAccum_lnd, &
- FBDst=FBlndAccum_glc, &
- RouteHandle=is_local%wrap%RH(complnd,compglc,mapbilnr), rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_LogWrite(trim(subname)//" mapbilnr is not created for lnd->glc mapping", &
+ ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u)
+ rc = ESMF_FAILURE
+ return
end if
! Determine if renormalize smb
@@ -263,14 +258,6 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
! -------------------------------
if (smb_renormalize) then
- ! -------------------------------
- ! get land and glc meshes and determine areas on corresponding meshes
- ! -------------------------------
- call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), mesh=lmesh_lnd, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc), mesh=lmesh_glc, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
! determine areas on land mesh
call ESMF_MeshGet(lmesh_lnd, numOwnedElements=lsize, elementDistGrid=ldistgrid, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
@@ -295,54 +282,36 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
deallocate(dataptr1d)
- ! -------------------------------
! ice mask without elevation classes on glc and lnd
- ! -------------------------------
- call FB_init(FBglc_icemask, is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBExp(compglc), fieldnameList=(/Sg_icemask_field/), rc=rc)
+ field_glc_icemask_g = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_init(FBlnd_icemask, is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(complnd,complnd), fieldNameList=(/Sg_icemask_field/), rc=rc)
+ field_glc_icemask_l = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(fldlist_glc2lnd_icemask%flds(1))
- fldlist_glc2lnd_icemask%flds(1)%shortname = Sg_icemask_field
- fldlist_glc2lnd_icemask%flds(1)%mapindex(complnd) = mapconsf
- fldlist_glc2lnd_icemask%flds(1)%mapnorm(complnd) = 'none'
-
- ! -------------------------------
- ! ice fraction in multiple elevation classes on glc and lnd - NOTE that this includes bare land
- ! -------------------------------
- FBglc_frac = ESMF_FieldBundleCreate(rc=rc)
+ ! ice fraction without multiple elevation classes on glc and lnd
+ field_glc_frac_g = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, name=trim(Sg_frac_field), meshloc=ESMF_MESHLOC_ELEMENT, &
- ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBglc_frac, (/lfield/), rc=rc)
+ field_glc_frac_l = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- FBlnd_frac = ESMF_FieldBundleCreate(rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, name=trim(Sg_frac_field), meshloc=ESMF_MESHLOC_ELEMENT, &
+ ! ice fraction in multiple elevation classes on glc and lnd - NOTE that this includes bare land
+ field_glc_frac_g_ec = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBlnd_frac, (/lfield/), rc=rc)
+ field_glc_frac_l_ec = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
+ ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(fldlist_glc2lnd_frac%flds(1))
- fldlist_glc2lnd_frac%flds(1)%shortname = Sg_frac_field
- fldlist_glc2lnd_frac%flds(1)%mapindex(complnd) = mapconsf
- fldlist_glc2lnd_frac%flds(1)%mapnorm(complnd) = trim(Sg_icemask_field) ! will use FBglc_icemask
-
- ! Create route handle if it has not been created
+ ! Create route handle if it has not been created - this will be needed to map the fractions
if (.not. med_map_RH_is_created(is_local%wrap%RH(compglc,complnd,:),mapconsf,rc=rc)) then
- call med_map_Fractions_init( gcomp, compglc, complnd, &
- FBSrc=FBlndAccum_glc, &
- FBDst=FBlndAccum_lnd, &
- RouteHandle=is_local%wrap%RH(compglc,complnd,mapconsf), rc=rc)
+ call med_map_routehandles_init( compglc, complnd, &
+ FBSrc=is_local%wrap%FBImp(compglc,compglc), &
+ FBDst=is_local%wrap%FBImp(compglc,complnd), &
+ mapindex=mapconsf, &
+ RouteHandle=is_local%wrap%RH, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
+
end if
end if
@@ -354,7 +323,6 @@ subroutine med_phases_prep_glc_init(gcomp, rc)
end subroutine med_phases_prep_glc_init
!================================================================================================
-
subroutine med_phases_prep_glc_accum(gcomp, rc)
!---------------------------------------
@@ -369,9 +337,10 @@ subroutine med_phases_prep_glc_accum(gcomp, rc)
! local variables
type(InternalState) :: is_local
+ type(ESMF_Field) :: lfield
integer :: i,n,ncnt
- real(r8), pointer :: data2d_in(:,:)
- real(r8), pointer :: data2d_out(:,:)
+ real(r8), pointer :: data2d_in(:,:) => null()
+ real(r8), pointer :: data2d_out(:,:) => null()
character(len=*),parameter :: subname='(med_phases_prep_glc_accum)'
!---------------------------------------
@@ -408,19 +377,21 @@ subroutine med_phases_prep_glc_accum(gcomp, rc)
!---------------------------------------
if (ncnt > 0) then
-
! Initialize module variables needed to accumulate input to glc
if (.not. init_prep_glc) then
- call med_phases_prep_glc_init(gcomp, rc)
+ call med_phases_prep_glc_init(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
init_prep_glc = .true.
end if
do n = 1, size(fldnames_fr_lnd)
- call FB_GetFldPtr(is_local%wrap%FBImp(complnd,complnd), &
- fldnames_fr_lnd(n), fldptr2=data2d_in, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldname=trim(fldnames_fr_lnd(n)), field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_GetFldPtr(FBlndAccum_lnd, fldnames_fr_lnd(n), fldptr2=data2d_out, rc=rc)
+ call ESMF_FieldGet(lfield, farrayptr=data2d_in, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(FBlndAccum_lnd, fieldname=fldnames_fr_lnd(n), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=data2d_out, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
do i = 1,size(data2d_out, dim=2)
data2d_out(:,i) = data2d_out(:,i) + data2d_in(:,i)
@@ -433,7 +404,6 @@ subroutine med_phases_prep_glc_accum(gcomp, rc)
call FB_diagnose(FBlndAccum_lnd, string=trim(subname)// ' FBlndAccum_lnd ', rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
end if
-
end if
if (dbug_flag > 5) then
@@ -444,7 +414,6 @@ subroutine med_phases_prep_glc_accum(gcomp, rc)
end subroutine med_phases_prep_glc_accum
!================================================================================================
-
subroutine med_phases_prep_glc_avg(gcomp, rc)
!---------------------------------------
@@ -459,9 +428,10 @@ subroutine med_phases_prep_glc_avg(gcomp, rc)
type(InternalState) :: is_local
type(ESMF_Clock) :: clock
type(ESMF_Alarm) :: alarm
+ type(ESMF_Field) :: lfield
integer :: i, n, ncnt ! counters
- real(r8), pointer :: data2d(:,:)
- real(r8), pointer :: data2d_import(:,:)
+ real(r8), pointer :: data2d(:,:) => null()
+ real(r8), pointer :: data2d_import(:,:) => null()
character(len=*) , parameter :: subname='(med_phases_prep_glc_avg)'
!---------------------------------------
@@ -536,7 +506,9 @@ subroutine med_phases_prep_glc_avg(gcomp, rc)
call ESMF_LogWrite(trim(subname)//": glc_avg alarm is ringing - averaging input from lnd to glc", ESMF_LOGMSG_INFO)
do n = 1, size(fldnames_fr_lnd)
- call FB_GetFldPtr(FBlndAccum_lnd, fldnames_fr_lnd(n), fldptr2=data2d, rc=rc)
+ call ESMF_FieldBundleGet(FBlndAccum_lnd, fieldname=fldnames_fr_lnd(n), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=data2d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (FBlndAccumCnt > 0) then
! If accumulation count is greater than 0, do the averaging
@@ -544,15 +516,16 @@ subroutine med_phases_prep_glc_avg(gcomp, rc)
else
! If accumulation count is 0, then simply set the averaged field bundle values from the land
! to the import field bundle values
- call FB_GetFldPtr(is_local%wrap%FBImp(complnd,complnd), fldnames_fr_lnd(n), fldptr2=data2d_import, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldname=fldnames_fr_lnd(n), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=data2d_import, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
data2d(:,:) = data2d_import(:,:)
end if
end do
if (dbug_flag > 1) then
- call FB_diagnose(FBlndAccum_lnd, string=trim(subname)//&
- ' FBlndAccum for after avg for field bundle ', rc=rc)
+ call FB_diagnose(FBlndAccum_lnd, string=trim(subname)//' FBlndAccum for after avg for field bundle ', rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
end if
@@ -564,7 +537,7 @@ subroutine med_phases_prep_glc_avg(gcomp, rc)
call FB_reset(FBlndAccum_glc, value=0.0_r8, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_phases_prep_glc_map_lnd2glc(gcomp, rc)
+ call map_lnd2glc(gcomp, rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 1) then
@@ -599,7 +572,7 @@ end subroutine med_phases_prep_glc_avg
!================================================================================================
- subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
+ subroutine map_lnd2glc(gcomp, rc)
!---------------------------------------
! map accumulated land fields from the land to the glc mesh
@@ -611,25 +584,31 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
! local variables
type(InternalState) :: is_local
- real(r8), pointer :: topolnd_g_ec(:,:) ! topo in elevation classes
- real(r8), pointer :: dataptr_g(:) ! temporary data pointer for one elevation class
- real(r8), pointer :: topoglc_g(:) ! ice topographic height on the glc grid extracted from glc import
- real(r8), pointer :: data_ice_covered_g(:) ! data for ice-covered regions on the GLC grid
- real(r8), pointer :: glc_ice_covered(:) ! if points on the glc grid is ice-covered (1) or ice-free (0)
- integer , pointer :: glc_elevclass(:) ! elevation classes glc grid
- real(r8), pointer :: dataexp_g(:) ! pointer into
- real(r8), pointer :: dataptr2d(:,:)
- real(r8), pointer :: dataptr1d(:)
- real(r8) :: elev_l, elev_u ! lower and upper elevations in interpolation range
- real(r8) :: d_elev ! elev_u - elev_l
+ real(r8), pointer :: topolnd_g_ec(:,:) => null() ! topo in elevation classes
+ real(r8), pointer :: dataptr_g(:) => null() ! temporary data pointer for one elevation class
+ real(r8), pointer :: topoglc_g(:) => null() ! ice topographic height on the glc grid extracted from glc import
+ real(r8), pointer :: data_ice_covered_g(:) => null() ! data for ice-covered regions on the GLC grid
+ real(r8), pointer :: ice_covered_g(:) => null() ! if points on the glc grid is ice-covered (1) or ice-free (0)
+ integer , pointer :: elevclass_g(:) => null() ! elevation classes glc grid
+ real(r8), pointer :: dataexp_g(:) => null() ! pointer into
+ real(r8), pointer :: dataptr2d(:,:) => null()
+ real(r8), pointer :: dataptr1d(:) => null()
+ real(r8) :: elev_l, elev_u ! lower and upper elevations in interpolation range
+ real(r8) :: d_elev ! elev_u - elev_l
integer :: nfld, ec
integer :: i,j,n,g,lsize_g
+ integer :: ungriddedUBound_output(1)
+ integer :: fieldCount
+ type(ESMF_Field) :: lfield
+ type(ESMF_Field) :: field_lfrac_l
+ type(ESMF_Field), pointer :: fieldlist_lnd(:) => null()
+ type(ESMF_Field), pointer :: fieldlist_glc(:) => null()
character(len=*) , parameter :: subname='(med_phases_prep_glc_mod:med_phases_prep_glc_map_lnd2glc)'
!---------------------------------------
+
!---------------------------------------
! Get the internal state
!---------------------------------------
-
nullify(is_local%wrap)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
@@ -645,20 +624,35 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
! notes that this could lead to a loss of conservation). Figure out how to handle
! this case.
+ ! get fieldlist from FBlndAccum_lnd
+ call ESMF_FieldBundleGet(FBlndAccum_lnd, fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist_lnd(fieldcount))
+ call ESMF_FieldBundleGet(FBlndAccum_lnd, fieldlist=fieldlist_lnd, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist_glc(fieldcount))
+ call ESMF_FieldBundleGet(FBlndAccum_glc, fieldlist=fieldlist_glc, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! get land fraction field on land mesh
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(complnd), fieldname='lfrac', field=field_lfrac_l, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+
+ ! TODO: is this needed?
call FB_reset(FBlndAccum_glc, value=0.0_r8, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldList_lnd2glc%flds, &
- srccomp=complnd, &
- destcomp=compglc, &
- FBSrc=FBlndAccum_lnd, &
- FBDst=FBlndAccum_glc, &
- FBFracSrc=is_local%wrap%FBFrac(complnd), &
- FBNormOne=is_local%wrap%FBNormOne(complnd,compglc,:), &
- RouteHandles=is_local%wrap%RH(complnd,compglc,:), &
- string=trim(compname(complnd))//'2'//trim(compname(compglc)), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! map accumlated land fields and normalize by the land fraction
+ do n = 1,fieldcount
+ call med_map_field_normalized( &
+ field_src=fieldlist_lnd(n), &
+ field_dst=fieldlist_glc(n), &
+ routehandles=is_local%wrap%RH(complnd,compglc,:), &
+ maptype=mapbilnr, &
+ field_normsrc=field_lfrac_l, &
+ field_normdst=field_lfrac_g, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ end do
if (dbug_flag > 1) then
call FB_diagnose(FBlndAccum_lnd, string=trim(subname)//' FBlndAccum_lnd ', rc=rc)
@@ -678,24 +672,28 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
string=trim(subname)//' FBImp(compglc,compglc) ', rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
end if
-
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), Sg_frac_field, fldptr1=glc_ice_covered, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_frac_fieldname), field=lfield, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
-
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), Sg_topo_field, fldptr1=topoglc_g, rc=rc)
+ call ESMF_FieldGet(lfield, farrayptr=ice_covered_g, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_topo_fieldname), field=lfield, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=topoglc_g, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
! get elevation classes with bare land
! for grid cells that are ice-free, the elevation class is set to 0.
- lsize_g = size(glc_ice_covered)
- allocate(glc_elevclass(lsize_g))
- call glc_get_elevation_classes(glc_ice_covered, topoglc_g, glc_elevclass, logunit)
+ lsize_g = size(ice_covered_g)
+ allocate(elevclass_g(lsize_g))
+ call glc_get_elevation_classes(ice_covered_g, topoglc_g, elevclass_g, logunit)
! ------------------------------------------------------------------------
! Determine topo field in multiple elevation classes on the glc grid
! ------------------------------------------------------------------------
- call FB_getFldPtr(FBlndAccum_glc, 'Sl_topo_elev', fldptr2=topolnd_g_ec, rc=rc)
+ call ESMF_FieldBundleGet(FBlndAccum_glc, fieldname='Sl_topo_elev', field=lfield, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=topolnd_g_ec, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
! ------------------------------------------------------------------------
@@ -707,7 +705,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
! current glint implementation, which sets acab and artm to 0 over ocean (although
! notes that this could lead to a loss of conservation). Figure out how to handle this case.
- allocate(data_ice_covered_g (lsize_g))
+ allocate(data_ice_covered_g(lsize_g))
do nfld = 1, size(fldnames_to_glc)
! ------------------------------------------------------------------------
@@ -716,11 +714,17 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
! ------------------------------------------------------------------------
! Get a pointer to the land data in multiple elevation classes on the glc grid
- call FB_getFldPtr(FBlndAccum_glc, fldnames_fr_lnd(nfld), fldptr2=dataptr2d, rc=rc)
+ call ESMF_FieldBundleGet(FBlndAccum_glc, fieldname=trim(fldnames_fr_lnd(nfld)), &
+ field=lfield, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=dataptr2d, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
! Get a pointer to the data for the field that will be sent to glc (without elevation classes)
- call FB_getFldPtr(is_local%wrap%FBExp(compglc), fldnames_to_glc(nfld), fldptr1=dataexp_g, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc), fieldname=trim(fldnames_to_glc(nfld)), &
+ field=lfield, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=dataexp_g, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
! First set data_ice_covered_g to bare land everywehre
@@ -730,7 +734,6 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
do n = 1, lsize_g
! For each ice sheet point, find bounding EC values...
-
if (topoglc_g(n) < topolnd_g_ec(2,n)) then
! lower than lowest mean EC elevation value
@@ -768,7 +771,7 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
end do
end if ! topoglc_g(n)
- if (glc_elevclass(n) /= 0) then
+ if (elevclass_g(n) /= 0) then
! ice-covered cells have interpolated values
dataexp_g(n) = data_ice_covered_g(n)
else
@@ -795,10 +798,10 @@ subroutine med_phases_prep_glc_map_lnd2glc(gcomp, rc)
end do ! end of loop over fields
! clean up memory
- deallocate(glc_elevclass)
+ deallocate(elevclass_g)
deallocate(data_ice_covered_g)
- end subroutine med_phases_prep_glc_map_lnd2glc
+ end subroutine map_lnd2glc
!================================================================================================
@@ -847,20 +850,19 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc)
! Note: Sg_icemask defines where the ice sheet model can receive a nonzero SMB from the land model.
type(InternalState) :: is_local
type(ESMF_VM) :: vm
- type(ESMF_Mesh) :: lmesh
type(ESMF_Field) :: lfield
- real(r8) , pointer :: qice_l(:,:) ! SMB (Flgl_qice) on land grid with elev classes
- real(r8) , pointer :: qice_g(:) ! SMB (Flgl_qice) on glc grid without elev classes
- real(r8) , pointer :: glc_topo_g(:) ! ice topographic height on the glc grid cell
- real(r8) , pointer :: glc_frac_g(:) ! total ice fraction in each glc cell
- real(r8) , pointer :: glc_frac_g_ec(:,:) ! total ice fraction in each glc cell
- real(r8) , pointer :: glc_frac_l_ec(:,:) ! EC fractions (Sg_ice_covered) on land grid
- real(r8) , pointer :: Sg_icemask_g(:) ! icemask on glc grid
- real(r8) , pointer :: Sg_icemask_l(:) ! icemask on land grid
- real(r8) , pointer :: lfrac(:) ! land fraction on land grid
- real(r8) , pointer :: dataptr1d(:) ! temporary 1d pointer
- real(r8) , pointer :: dataptr2d(:,:) ! temporary 2d pointer
- integer :: ec ! loop index over elevation classes
+ real(r8) , pointer :: qice_g(:) => null() ! SMB (Flgl_qice) on glc grid without elev classes
+ real(r8) , pointer :: qice_l_ec(:,:) => null() ! SMB (Flgl_qice) on land grid with elev classes
+ real(r8) , pointer :: glc_topo_g(:) => null() ! ice topographic height on the glc grid cell
+ real(r8) , pointer :: glc_frac_g(:) => null() ! total ice fraction in each glc cell
+ real(r8) , pointer :: glc_frac_g_ec(:,:) => null() ! total ice fraction in each glc cell
+ real(r8) , pointer :: glc_frac_l_ec(:,:) => null() ! EC fractions (Sg_ice_covered) on land grid
+ real(r8) , pointer :: Sg_icemask_g(:) => null() ! icemask on glc grid
+ real(r8) , pointer :: Sg_icemask_l(:) => null() ! icemask on land grid
+ real(r8) , pointer :: lfrac(:) => null() ! land fraction on land grid
+ real(r8) , pointer :: dataptr1d(:) => null() ! temporary 1d pointer
+ real(r8) , pointer :: dataptr2d(:,:) => null() ! temporary 2d pointer
+ integer :: ec ! loop index over elevation classes
integer :: n
! local and global sums of accumulation and ablation; used to compute renormalization factors
@@ -893,36 +895,27 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
- !---------------------------------------
- ! Get vm
- !---------------------------------------
-
- call ESMF_GridCompGet(gcomp, vm=vm, rc=rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
!---------------------------------------
! Map Sg_icemask_g from the glc grid to the land grid.
!---------------------------------------
! determine Sg_icemask_g and set as contents of FBglc_icemask
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_icemask_field), fldptr1=dataptr1d, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_icemask_fieldname), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(FBglc_icemask, trim(Sg_icemask_field), fldptr1=Sg_icemask_g, rc=rc)
+ call ESMF_FieldGet(field_glc_icemask_g, farrayptr=Sg_icemask_g, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
Sg_icemask_g(:) = dataptr1d(:)
- ! BUG(wjs, 2017-05-11, #1516) I think we actually want norm = .false. here, but this
- ! requires some more thought
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldList_glc2lnd_icemask%flds, &
- srccomp=compglc, &
- destcomp=complnd, &
- FBSrc=FBglc_icemask, &
- FBDst=FBlnd_icemask, &
- FBFracSrc=FBglc_icemask, & ! this will not be used since are asking for 'none' normalization
- FBNormOne=is_local%wrap%FBNormOne(compglc,complnd,:), &
- RouteHandles=is_local%wrap%RH(compglc,complnd,:), &
- string='mapping Sg_imask_g to Sg_imask_l (from glc to land)', rc=rc)
+ ! map ice mask from glc to lnd with no normalization
+ ! BUG(wjs, 2017-05-11, #1516) I think we actually want norm = .false. here, but this needs more thought
+ ! Below the implementation is without normalization - this should be checked moving forwards
+ call med_map_field( &
+ field_src=field_glc_icemask_g, &
+ field_dst=field_glc_icemask_l, &
+ routehandles=is_local%wrap%RH(compglc,complnd,:), &
+ maptype=mapconsf, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! ------------------------------------------------------------------------
@@ -934,46 +927,55 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc)
! glc_frac_g(:) is the total ice fraction in each glc gridcell
! glc_frac_g_ec(:,:) are the glc fractions on the glc grid for each elevation class (inner dimension)
! setting glc_frac_g_ec (in the call to glc_get_fractional_icecov) sets the contents of FBglc_frac
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_topo_field), fldptr1=glc_topo_g, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_topo_fieldname), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=glc_topo_g, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_frac_fieldname), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=glc_frac_g, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_frac_field), fldptr1=glc_frac_g, rc=rc)
+ call ESMF_FieldGet(field_glc_frac_g, farrayptr=glc_frac_g, rc=rc) ! module field
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(FBglc_frac, Sg_frac_field, fldptr2=glc_frac_g_ec, rc=rc)
+ call ESMF_FieldGet(field_glc_frac_g_ec, farrayptr=glc_frac_g_ec, rc=rc) ! module field
if (chkerr(rc,__LINE__,u_FILE_u)) return
+
! note that nec = ungriddedCount - 1
call glc_get_fractional_icecov(ungriddedCount-1, glc_topo_g, glc_frac_g, glc_frac_g_ec, logunit)
- ! map fraction in each elevation class from the glc grid to the land grid
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldList_glc2lnd_frac%flds, &
- srccomp=compglc, &
- destcomp=complnd, &
- FBSrc=FBglc_frac, & ! this has multiple elevation classes
- FBDst=FBlnd_frac, & ! this has multiple elvation classes
- FBFracSrc=FBglc_icemask, & ! this is used with a mapnorm of Sg_icemask_field
- FBNormOne=is_local%wrap%FBNormOne(compglc,complnd,:), & ! this will not be used
- RouteHandles=is_local%wrap%RH(compglc,complnd,:), &
- string='mapping elevation class fractions from glc to land ', rc=rc)
+ ! 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=field_glc_frac_g_ec, &
+ field_dst=field_glc_frac_l_ec, &
+ routehandles=is_local%wrap%RH(compglc,complnd,:), &
+ maptype=mapconsf, &
+ field_normsrc=field_glc_icemask_g, &
+ field_normdst=field_glc_icemask_l, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! get fractional ice coverage for each elevation class on the land grid, glc_frac_l_ec(:,:)
- call FB_getFldPtr(FBlnd_frac, trim(Sg_frac_field), fldptr2=glc_frac_l_ec, rc=rc)
+ call ESMF_FieldGet(field_glc_frac_l_ec, farrayptr=glc_frac_l_ec, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
! determine fraction on land grid, lfrac(:)
- call FB_getFldPtr(is_local%wrap%FBFrac(complnd), 'lfrac', fldptr1=lfrac, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(complnd), fieldname='lfrac', field=lfield, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=lfrac, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
! get Sg_icemask_l(:)
- call FB_getFldPtr(FBlnd_icemask, Sg_icemask_field, fldptr1=Sg_icemask_l, rc=rc)
+ call ESMF_FieldGet(field_glc_icemask_l, farrayptr=Sg_icemask_l, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
- ! determine qice_l
- call FB_getFldPtr(FBlndAccum_lnd, trim(qice_fieldname)//'_elev', fldptr2=qice_l, rc=rc)
+ ! determine qice_l_ec
+ call ESMF_FieldBundleGet(FBlndAccum_lnd, trim(qice_fieldname)//'_elev', field=lfield, rc=rc)
+ if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=qice_l_ec, rc=rc)
if (chkErr(rc,__LINE__,u_FILE_u)) return
!---------------------------------------
- ! Sum qice_l 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
!---------------------------------------
local_accum_lnd(1) = 0.0_r8
@@ -983,15 +985,19 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc)
effective_area = min(lfrac(n), Sg_icemask_l(n)) * aream_l(n)
do ec = 1, ungriddedCount
- if (qice_l(ec,n) >= 0.0_r8) then
- local_accum_lnd(1) = local_accum_lnd(1) + effective_area * glc_frac_l_ec(ec,n) * qice_l(ec,n)
+ if (qice_l_ec(ec,n) >= 0.0_r8) then
+ local_accum_lnd(1) = local_accum_lnd(1) + effective_area * glc_frac_l_ec(ec,n) * qice_l_ec(ec,n)
else
- local_ablat_lnd(1) = local_ablat_lnd(1) + effective_area * glc_frac_l_ec(ec,n) * qice_l(ec,n)
+ local_ablat_lnd(1) = local_ablat_lnd(1) + effective_area * glc_frac_l_ec(ec,n) * qice_l_ec(ec,n)
endif
enddo ! ec
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
!---------------------------------------
! Sum qice_g over local glc grid cells.
@@ -1006,8 +1012,10 @@ subroutine med_phases_prep_glc_renormalize_smb(gcomp, rc)
! then it would be appropriate to use the native CISM areas in this sum.
! determine qice_g
- call FB_getFldPtr(is_local%wrap%FBExp(compglc), qice_fieldname, fldptr1=qice_g, rc=rc)
- if (chkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compglc), fieldname=trim(qice_fieldname), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=qice_g, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
local_accum_glc(1) = 0.0_r8
local_ablat_glc(1) = 0.0_r8
diff --git a/mediator/med_phases_prep_ice_mod.F90 b/mediator/med_phases_prep_ice_mod.F90
index 3aabc5691..a65680681 100644
--- a/mediator/med_phases_prep_ice_mod.F90
+++ b/mediator/med_phases_prep_ice_mod.F90
@@ -7,15 +7,12 @@ module med_phases_prep_ice_mod
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
use med_utils_mod , only : chkerr => med_utils_ChkErr
use med_methods_mod , only : fldchk => med_methods_FB_FldChk
- use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_getNumFlds => med_methods_FB_getNumFlds
use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
use med_methods_mod , only : State_SetScalar => med_methods_State_SetScalar
use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
use med_merge_mod , only : med_merge_auto
- use med_map_mod , only : med_map_FB_Regrid_Norm, med_map_RH_is_created
- use med_map_mod , only : med_map_FB_Field_Regrid
+ use med_map_mod , only : med_map_field_packed
use med_internalstate_mod , only : InternalState, logunit, mastertask
use esmFlds , only : compatm, compice, comprof, compglc, ncomps, compname
use esmFlds , only : fldListFr, fldListTo
@@ -41,7 +38,7 @@ subroutine med_phases_prep_ice(gcomp, rc)
use ESMF , only : operator(/=)
use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_StateGet
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only : ESMF_FieldBundleGet
+ use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet, ESMF_Field
use ESMF , only : ESMF_LOGMSG_ERROR, ESMF_FAILURE
use ESMF , only : ESMF_StateItem_Flag, ESMF_STATEITEM_NOTFOUND
use NUOPC , only : NUOPC_IsConnected
@@ -53,16 +50,12 @@ subroutine med_phases_prep_ice(gcomp, rc)
! local variables
type(ESMF_StateItem_Flag) :: itemType
type(InternalState) :: is_local
+ type(ESMF_Field) :: lfield
integer :: i,n,n1,ncnt
character(len=CS) :: fldname
integer :: fldnum
integer :: mapindex
- real(R8), pointer :: dataptr(:)
- real(R8), pointer :: temperature(:)
- real(R8), pointer :: pressure(:)
- real(R8), pointer :: humidity(:)
- real(R8), pointer :: air_density(:)
- real(R8), pointer :: pot_temp(:)
+ real(R8), pointer :: dataptr(:) => null()
real(R8) :: precip_fact
character(len=CS) :: cvalue
character(len=64), allocatable :: fldnames(:)
@@ -93,37 +86,35 @@ subroutine med_phases_prep_ice(gcomp, rc)
! Note - the scalar field has been removed from all mediator field bundles - so this is why we check if the
! fieldCount is 0 and not 1 here
- call FB_getNumFlds(is_local%wrap%FBExp(compice), trim(subname)//"FBexp(compice)", ncnt, rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compice), fieldCount=ncnt, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (ncnt > 0) then
- !---------------------------------------
- !--- map to create FBImp(:,compice)
- !---------------------------------------
-
+ ! map all fields in FBImp that have active ice coupling
do n1 = 1,ncomps
if (is_local%wrap%med_coupling_active(n1,compice)) then
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(n1)%flds, &
- srccomp=n1, destcomp=compice, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImp(n1,n1), &
FBDst=is_local%wrap%FBImp(n1,compice), &
FBFracSrc=is_local%wrap%FBFrac(n1), &
- FBNormOne=is_local%wrap%FBNormOne(n1,compice,:), &
- RouteHandles=is_local%wrap%RH(n1,compice,:), &
- string=trim(compname(n1))//'2'//trim(compname(compice)), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_normOne=is_local%wrap%field_normOne(n1,compice,:), &
+ packed_data=is_local%wrap%packed_data(n1,compice,:), &
+ routehandles=is_local%wrap%RH(n1,compice,:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- enddo
+ end do
!---------------------------------------
!--- auto merges to create FBExp(compice)
!---------------------------------------
- call med_merge_auto(trim(compname(compice)), &
- is_local%wrap%FBExp(compice), is_local%wrap%FBFrac(compice), &
- is_local%wrap%FBImp(:,compice), fldListTo(compice), rc=rc)
+ call med_merge_auto(compice, &
+ is_local%wrap%med_coupling_active(:,compice), &
+ is_local%wrap%FBExp(compice), &
+ is_local%wrap%FBFrac(compice), &
+ is_local%wrap%FBImp(:,compice), &
+ fldListTo(compice), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
!---------------------------------------
@@ -148,7 +139,10 @@ subroutine med_phases_prep_ice(gcomp, rc)
fldnames = (/'Faxa_rain', 'Faxa_snow', 'Fixx_rofi'/)
do n = 1,size(fldnames)
if (fldchk(is_local%wrap%FBExp(compice), trim(fldnames(n)), rc=rc)) then
- call FB_GetFldPtr(is_local%wrap%FBExp(compice), trim(fldnames(n)) , dataptr, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compice), fieldname=trim(fldnames(n)), &
+ field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=dataptr, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
dataptr(:) = dataptr(:) * precip_fact
end if
diff --git a/mediator/med_phases_prep_lnd_mod.F90 b/mediator/med_phases_prep_lnd_mod.F90
index f8d140bad..d8290aa37 100644
--- a/mediator/med_phases_prep_lnd_mod.F90
+++ b/mediator/med_phases_prep_lnd_mod.F90
@@ -8,29 +8,22 @@ module med_phases_prep_lnd_mod
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_FieldBundleCreate, ESMF_FieldBundleAdd
- use ESMF , only : ESMF_RouteHandle
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
+ use ESMF , only : ESMF_Mesh, ESMF_MeshLoc, ESMF_MESHLOC_ELEMENT, ESMF_TYPEKIND_R8
use ESMF , only : ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate
- use ESMF , only : ESMF_TYPEKIND_R8
- use esmFlds , only : complnd, compatm, compglc, ncomps, compname, mapconsf
- use esmFlds , only : fldListFr, fldListTo
- use esmFlds , only : med_fldlist_type
- use med_methods_mod , only : FB_getFieldN => med_methods_FB_getFieldN
- use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr
- use med_methods_mod , only : FB_getNumFlds => med_methods_FB_getNumFlds
- use med_methods_mod , only : FB_init => med_methods_FB_init
+ use ESMF , only : ESMF_RouteHandle, ESMF_RouteHandleIsCreated
+ use esmFlds , only : complnd, compatm, compglc, ncomps, compname, mapconsd
+ use esmFlds , only : fldListTo
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_FldChk => med_methods_FB_FldChk
+ use med_methods_mod , only : FB_FldChk => med_methods_FB_fldchk
use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
use med_methods_mod , only : State_SetScalar => med_methods_State_SetScalar
use med_utils_mod , only : chkerr => med_utils_ChkErr
use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
- use med_internalstate_mod , only : InternalState, logunit
- use med_map_mod , only : med_map_FB_Regrid_Norm, med_map_RH_is_created
- use med_map_mod , only : med_map_Fractions_Init
+ 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
@@ -42,8 +35,8 @@ module med_phases_prep_lnd_mod
public :: med_phases_prep_lnd
- private :: med_map_glc2lnd_init
- private :: med_map_glc2lnd
+ private :: map_glc2lnd_init
+ private :: map_glc2lnd
! private module variables
character(len =*), parameter :: Sg_icemask = 'Sg_icemask'
@@ -52,11 +45,14 @@ module med_phases_prep_lnd_mod
character(len =*), parameter :: Sg_topo = 'Sg_topo'
character(len =*), parameter :: Flgg_hflx = 'Flgg_hflx'
- type(ESMF_FieldBundle) :: FBglc_icemask ! no elevation classes
- type(ESMF_FieldBundle) :: FBglc_frac_x_icemask ! elevation classes
- type(ESMF_FieldBundle) :: FBlnd_frac_x_icemask ! elevation classes
- type(ESMF_FieldBundle) :: FBglc_ec
- type(ESMF_FieldBundle) :: FBlnd_ec
+ type(ESMF_Field) :: field_icemask_g ! no elevation classes
+ type(ESMF_Field) :: field_icemask_l ! no elevation classes
+ type(ESMF_Field) :: field_frac_g_ec ! elevation classes
+ type(ESMF_Field) :: field_frac_l_ec ! elevation classes
+ type(ESMF_Field) :: field_frac_x_icemask_g_ec ! elevation classes
+ type(ESMF_Field) :: field_frac_x_icemask_l_ec ! elevation classes
+ type(ESMF_Field) :: field_topo_x_icemask_g_ec ! elevation classes
+ type(ESMF_Field) :: field_topo_x_icemask_l_ec ! elevation classes
! the number of elevation classes (excluding bare land) = ungriddedCount - 1
integer :: ungriddedCount ! this equals the number of elevation classes + 1 (for bare land)
@@ -90,54 +86,45 @@ subroutine med_phases_prep_lnd(gcomp, rc)
call ESMF_LogWrite(trim(subname)//": called", ESMF_LOGMSG_INFO)
end if
- !---------------------------------------
- ! --- Get the internal state
- !---------------------------------------
-
+ ! Get the internal state
nullify(is_local%wrap)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- !---------------------------------------
- !--- Count the number of fields outside of scalar data, if zero, then return
- !---------------------------------------
-
+ ! Count the number of fields outside of scalar data, if zero, then return
! Note - the scalar field has been removed from all mediator field bundles - so this is why we check if the
! fieldCount is 0 and not 1 here
- call FB_getNumFlds(is_local%wrap%FBExp(complnd), trim(subname)//"FBexp(complnd)", ncnt, rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), fieldCount=ncnt, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (ncnt > 0) then
!---------------------------------------
- !--- map to create FBimp(:,complnd)
+ ! map to create FBimp(:,complnd)
!---------------------------------------
do n1 = 1,ncomps
if (is_local%wrap%med_coupling_active(n1,complnd)) then
- ! The following will map all atm->lnd, rof->lnd, and
- ! glc->lnd only for Sg_icemask_field and Sg_icemask_coupled_fluxes
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(n1)%flds, &
- srccomp=n1, destcomp=complnd, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImp(n1,n1), &
FBDst=is_local%wrap%FBImp(n1,complnd), &
FBFracSrc=is_local%wrap%FBFrac(n1), &
- FBNormOne=is_local%wrap%FBNormOne(n1,complnd,:), &
- RouteHandles=is_local%wrap%RH(n1,complnd,:), &
- string=trim(compname(n1))//'2'//trim(compname(complnd)), rc=rc)
+ field_normOne=is_local%wrap%field_normOne(n1,complnd,:), &
+ packed_data=is_local%wrap%packed_data(n1,complnd,:), &
+ routehandles=is_local%wrap%RH(n1,complnd,:), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- enddo
+ end do
!---------------------------------------
- !--- auto merges to create FBExp(complnd)
+ ! auto merges to create FBExp(complnd)
!---------------------------------------
- ! The following will merge all fields in fldsSrc
+ ! The following will merge all fields in fldsSrc
! (for glc these are Sg_icemask and Sg_icemask_coupled_fluxes)
- call med_merge_auto(trim(compname(complnd)), &
+ call med_merge_auto(complnd, &
+ is_local%wrap%med_coupling_active(:,complnd), &
is_local%wrap%FBExp(complnd), &
is_local%wrap%FBFrac(complnd), &
is_local%wrap%FBImp(:,complnd), &
@@ -145,26 +132,23 @@ subroutine med_phases_prep_lnd(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
!---------------------------------------
- !--- custom calculations
+ ! custom calculations
!---------------------------------------
! The following is only done if glc->lnd coupling is active
if (is_local%wrap%comp_present(compglc) .and. (is_local%wrap%med_coupling_active(compglc,complnd))) then
if (first_call) then
- call med_map_glc2lnd_init(gcomp, rc=rc)
+ call map_glc2lnd_init(gcomp, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- first_call = .false.
end if
-
! The will following will map and merge Sg_frac and Sg_topo (and in the future Flgg_hflx)
- call med_map_glc2lnd(gcomp, rc=rc)
+ call map_glc2lnd(gcomp, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
!---------------------------------------
- !--- update scalar data
+ ! update scalar data
!---------------------------------------
-
call ESMF_StateGet(is_local%wrap%NStateImp(compatm), trim(is_local%wrap%flds_scalar_name), itemType, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (itemType /= ESMF_STATEITEM_NOTFOUND) then
@@ -185,22 +169,15 @@ subroutine med_phases_prep_lnd(gcomp, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- !---------------------------------------
- !--- diagnose
- !---------------------------------------
-
+ ! diagnose
if (dbug_flag > 1) then
call FB_diagnose(is_local%wrap%FBExp(complnd), &
string=trim(subname)//' FBexp(complnd) ', rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
-
- !---------------------------------------
- !--- clean up
- !---------------------------------------
-
end if
+ first_call = .false.
if (dbug_flag > 5) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
@@ -211,19 +188,21 @@ end subroutine med_phases_prep_lnd
!================================================================================================
- subroutine med_map_glc2lnd_init(gcomp, rc)
+ subroutine map_glc2lnd_init(gcomp, rc)
! input/output variables
type(ESMF_GridComp) , intent(inout) :: gcomp
integer , intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- type(ESMF_Field) :: lfield
- type(ESMF_Mesh) :: lmesh_lnd
- type(ESMF_Mesh) :: lmesh_glc
- integer :: ungriddedUBound_output(1) ! currently the size must equal 1 for rank 2 fieldds
- character(len=*) , parameter :: subname='(med_map_glc2lnd_mod:med_map_glc2lnd_init)'
+ type(InternalState) :: is_local
+ type(ESMF_Field) :: lfield
+ type(ESMF_Mesh) :: lmesh_lnd
+ type(ESMF_Mesh) :: lmesh_glc
+ integer :: ungriddedUBound_output(1)
+ integer :: fieldCount
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
+ character(len=*) , parameter :: subname='(map_glc2lnd_mod:map_glc2lnd_init)'
!---------------------------------------
rc = ESMF_SUCCESS
@@ -241,7 +220,7 @@ subroutine med_map_glc2lnd_init(gcomp, rc)
!---------------------------------------
! Determine number of elevation classes by querying a field that has elevation classes in it
- call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), 'Sg_topo_elev', field=lfield, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), fieldname='Sg_topo_elev', field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
call ESMF_FieldGet(lfield, ungriddedUBound=ungriddedUBound_output, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
@@ -252,74 +231,62 @@ subroutine med_map_glc2lnd_init(gcomp, rc)
! Get the glc and land meshes
!---------------------------------------
- call FB_getFieldN(is_local%wrap%FBExp(complnd), 1, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, mesh=lmesh_lnd, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=lmesh_lnd, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(fieldlist)
- call FB_getFieldN(is_local%wrap%FBImp(compglc,compglc), 1, field=lfield, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldGet(lfield, mesh=lmesh_glc, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist(1), mesh=lmesh_glc, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(fieldlist)
! -------------------------------
! Create module field bundles
! -------------------------------
- FBglc_icemask = ESMF_FieldBundleCreate(rc=rc)
+ field_icemask_g = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, name=trim(Sg_icemask), meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBglc_icemask, (/lfield/), rc=rc)
+ field_icemask_l = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- FBglc_frac_x_icemask = ESMF_FieldBundleCreate(rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, name=trim(Sg_frac_x_icemask), meshloc=ESMF_MESHLOC_ELEMENT, &
+ field_frac_g_ec = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBglc_frac_x_icemask, (/lfield/), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- FBlnd_frac_x_icemask = ESMF_FieldBundleCreate(rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, name=trim(Sg_frac_x_icemask), meshloc=ESMF_MESHLOC_ELEMENT, &
+ field_frac_l_ec = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBlnd_frac_x_icemask, (/lfield/), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- FBglc_ec = ESMF_FieldBundleCreate(rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, name='field_ec', meshloc=ESMF_MESHLOC_ELEMENT, &
+ field_frac_x_icemask_g_ec = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBglc_ec, (/lfield/), rc=rc)
+ field_frac_x_icemask_l_ec = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
+ ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- FBlnd_ec = ESMF_FieldBundleCreate(rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- lfield = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, name='field_ec', meshloc=ESMF_MESHLOC_ELEMENT, &
+ field_topo_x_icemask_g_ec = ESMF_FieldCreate(lmesh_glc, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call ESMF_FieldBundleAdd(FBlnd_ec, (/lfield/), rc=rc)
+ field_topo_x_icemask_l_ec = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, &
+ ungriddedLbound=(/1/), ungriddedUbound=(/ungriddedCount/), gridToFieldMap=(/2/), rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- ! -------------------------------
! Create route handle if it has not been created
- ! -------------------------------
-
- if (.not. med_map_RH_is_created(is_local%wrap%RH(compglc,complnd,:),mapconsf,rc=rc)) then
- call med_map_Fractions_init( gcomp, compglc, complnd, &
- FBSrc=FBglc_ec, FBDst=FBlnd_ec, &
- RouteHandle=is_local%wrap%RH(compglc,complnd,mapconsf), rc=rc)
+ if (.not. ESMF_RouteHandleIsCreated(is_local%wrap%RH(compglc,complnd,mapconsd), rc=rc)) then
+ call med_map_routehandles_init( compglc, complnd, field_icemask_g, field_icemask_l, &
+ mapindex=mapconsd, routehandles=is_local%wrap%rh(compglc,complnd,:), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
- ! -------------------------------
! Currently cannot map hflx in multiple elevation classes from glc to land
- ! -------------------------------
-
if (FB_fldchk(is_local%wrap%FBExp(complnd), trim(Flgg_hflx), rc=rc)) then
call ESMF_LogWrite(trim(subname)//'ERROR: Flgg_hflx to land has not been implemented yet', &
ESMF_LOGMSG_ERROR, line=__LINE__, file=__FILE__)
@@ -327,11 +294,10 @@ subroutine med_map_glc2lnd_init(gcomp, rc)
return
end if
- end subroutine med_map_glc2lnd_init
+ end subroutine map_glc2lnd_init
!================================================================================================
-
- subroutine med_map_glc2lnd( gcomp, rc)
+ subroutine map_glc2lnd( gcomp, rc)
!------------------
! Maps fields from the GLC grid to the LND grid.
@@ -345,23 +311,22 @@ subroutine med_map_glc2lnd( gcomp, rc)
! local variables
type(InternalState) :: is_local
- type(med_fldlist_type) :: fldlist
- integer :: ec, nfld, n, l, g
+ type(ESMF_Field) :: lfield
+ integer :: ec, l, g
real(r8) :: topo_virtual
- real(r8), pointer :: icemask_g(:) ! glc ice mask field on glc grid
- real(r8), pointer :: frac_g(:) ! total ice fraction in each glc cell
- real(r8), pointer :: frac_g_ec(:,:) ! glc fractions on the glc grid
- real(r8), pointer :: frac_l_ec(:,:) ! glc fractions on the land grid
- real(r8), pointer :: frac_x_icemask_g_ec(:,:) ! (glc fraction) x (icemask), on the glc grid
- real(r8), pointer :: topo_g(:) ! topographic height of each glc cell (no elevation classes)
- real(r8), pointer :: topo_l_ec(:,:) ! topographic height in each land gridcell for each elevation class
- real(r8), pointer :: topo_x_icemask_g(:,:)
- real(r8), pointer :: topo_x_icemask_l(:,:)
- real(r8), pointer :: frac_x_icemask_g(:,:)
- real(r8), pointer :: frac_x_icemask_l(:,:)
- real(r8), pointer :: dataptr1d(:)
- real(r8), pointer :: dataptr2d_exp(:,:)
- character(len=*), parameter :: subname = 'med_map_glc2lnd'
+ real(r8), pointer :: icemask_g(:) => null() ! glc ice mask field on glc grid
+ real(r8), pointer :: frac_g(:) => null() ! total ice fraction in each glc cell
+ real(r8), pointer :: frac_g_ec(:,:) => null() ! glc fractions on the glc grid
+ real(r8), pointer :: frac_l_ec(:,:) => null() ! glc fractions on the land grid
+ real(r8), pointer :: topo_g(:) => null() ! topographic height of each glc cell (no elevation classes)
+ real(r8), pointer :: topo_l_ec(:,:) => null() ! topographic height in each land gridcell for each elevation class
+ real(r8), pointer :: frac_x_icemask_g_ec(:,:) => null() ! (glc fraction) x (icemask), on the glc grid
+ real(r8), pointer :: frac_x_icemask_l_ec(:,:) => null()
+ real(r8), pointer :: topo_x_icemask_g_ec(:,:) => null()
+ real(r8), pointer :: topo_x_icemask_l_ec(:,:) => null()
+ real(r8), pointer :: dataptr1d(:) => null()
+ real(r8), pointer :: dataptr2d(:,:) => null()
+ character(len=*), parameter :: subname = 'map_glc2lnd'
!-----------------------------------------------------------------------
call t_startf('MED:'//subname)
@@ -389,55 +354,58 @@ subroutine med_map_glc2lnd( gcomp, rc)
! topo_g(:) is the topographic height of each glc gridcell
! frac_g(:) is the total ice fraction in each glc gridcell
! frac_g_ec(:,:) are the glc fractions on the glc grid for each elevation class (inner dimension)
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_topo), fldptr1=topo_g, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_frac), fldptr1=frac_g, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_topo), field=lfield, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(FBglc_ec, 'field_ec', fldptr2=frac_g_ec, rc=rc)
+ call ESMF_FieldGet(lfield, farrayptr=topo_g, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
+
! compute frac_g_ec
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_frac), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=frac_g, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_frac_g_ec, farrayptr=frac_g_ec, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
call glc_get_fractional_icecov(ungriddedCount-1, topo_g, frac_g, frac_g_ec, logunit)
- ! Set the contents of FBglc_icemask
- call FB_getFldPtr(FBglc_icemask, trim(Sg_icemask), fldptr1=icemask_g, rc=rc)
+ ! compute icemask_g
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_icemask), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=dataptr1d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_icemask), fldptr1=dataptr1d, rc=rc)
+ call ESMF_FieldGet(field_icemask_g, farrayptr=icemask_g, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
icemask_g(:) = dataptr1d(:)
- ! Only include grid cells that are both (a) within the icemask and (b) in this elevation class
- call FB_getFldPtr(FBglc_frac_x_icemask, trim(Sg_frac_x_icemask), fldptr2=frac_x_icemask_g_ec, rc=rc)
+ ! compute frac_x_icemask_g_ec
+ ! only include grid cells that are both (a) within the icemask and (b) in this elevation class
+ call ESMF_FieldGet(field_frac_x_icemask_g_ec, farrayptr=frac_x_icemask_g_ec, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
do ec = 1, ungriddedCount
frac_x_icemask_g_ec(ec,:) = frac_g_ec(ec,:) * icemask_g(:)
end do
- ! map to lnd and normalize by Sg_icemask_field
+ ! map frac_g_ec to frac_l_ec and normalize by icemask_g
if (dbug_flag > 1) then
call ESMF_LogWrite(trim(subname)//": calling mapping elevation class fractions from glc to land", ESMF_LOGMSG_INFO)
end if
- allocate(fldlist%flds(1))
- fldlist%flds(1)%shortname = 'field_ec'
- fldlist%flds(1)%mapindex(complnd) = mapconsf
- fldlist%flds(1)%mapnorm(complnd) = trim(Sg_icemask)
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldList%flds, &
- srccomp=compglc, &
- destcomp=complnd, &
- FBSrc=FBglc_ec, & ! this has multiple elevation classes
- FBDst=FBlnd_ec, & ! this has multiple elvation classes
- FBFracSrc=FBglc_icemask, & ! this is used with a mapnorm of Sg_icemask_field
- FBNormOne=is_local%wrap%FBNormOne(compglc,complnd,:), & ! this will not be used
- RouteHandles=is_local%wrap%RH(compglc,complnd,:), &
- string='mapping elevation class fractions from glc to land ', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- deallocate(fldlist%flds)
- call FB_getFldPtr(FBlnd_ec, 'field_ec', fldptr2=frac_l_ec, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(is_local%wrap%FBExp(complnd), trim(Sg_frac)//'_elev', fldptr2=dataptr2d_exp, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- dataptr2d_exp(:,:) = frac_l_ec(:,:)
+ call med_map_field_normalized( &
+ field_src=field_frac_g_ec, &
+ field_dst=field_frac_l_ec, &
+ routehandles=is_local%wrap%RH(compglc,complnd,:), &
+ maptype=mapconsd, &
+ field_normsrc=field_icemask_g, &
+ field_normdst=field_icemask_l, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+
+ ! now set values in land export state for Sg_frac_elev
+ call ESMF_fieldGet(field_frac_l_ec, farrayptr=frac_l_ec, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), fieldname=trim(Sg_frac)//'_elev', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_fieldGet(lfield, farrayptr=dataptr2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr2d(:,:) = frac_l_ec(:,:)
!---------------------------------
! Map topo to the land grid (multiple elevation classes)
@@ -449,60 +417,42 @@ subroutine med_map_glc2lnd( gcomp, rc)
! land grid (with elevation classes)
! Note that bare land values are mapped in the same way as ice-covered values
- call FB_getFldPtr(is_local%wrap%FBImp(compglc,compglc), trim(Sg_topo), fldptr1=topo_g, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(compglc,compglc), fieldname=trim(Sg_topo), field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_fieldGet(lfield, farrayptr=topo_g, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(FBglc_ec, 'field_ec', fldptr2=topo_x_icemask_g, rc=rc)
+ call ESMF_FieldGet(field_topo_x_icemask_g_ec, farrayptr=topo_x_icemask_g_ec, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
do ec = 1,ungriddedCount
do l = 1,size(topo_g)
- topo_x_icemask_g(ec,l) = topo_g(l) * frac_x_icemask_g_ec(ec,l)
+ topo_x_icemask_g_ec(ec,l) = topo_g(l) * frac_x_icemask_g_ec(ec,l)
end do
end do
- ! map FBglc_topo_x_icemask from glc to land (with multiple elevation classes) - no normalization
+ ! map field_topo_x_icemask_g_ec from glc to land (with multiple elevation classes) - no normalization
if (dbug_flag > 1) then
call ESMF_LogWrite(trim(subname)//": calling mapping of topo from glc to land", ESMF_LOGMSG_INFO)
end if
- allocate(fldlist%flds(1))
- fldlist%flds(1)%shortname = 'field_ec'
- fldlist%flds(1)%mapindex(complnd) = mapconsf
- fldlist%flds(1)%mapnorm(complnd) = 'none'
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldlist%flds, &
- srccomp=compglc, &
- destcomp=complnd, &
- FBSrc=FBglc_ec, &
- FBDst=FBlnd_ec, &
- FBFracSrc=is_local%wrap%FBFrac(compglc), & ! this will not be used
- FBNormOne=is_local%wrap%FBNormOne(compglc,complnd,:), & ! this will not be used
- RouteHandles=is_local%wrap%RH(compglc,complnd,:), &
- string='mapping topo from glc to land (with elevation classes)', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- deallocate(fldlist%flds)
- call FB_getFldPtr(FBlnd_ec, 'field_ec', fldptr2=topo_l_ec , rc=rc)
+ call med_map_field( &
+ field_src=field_topo_x_icemask_g_ec, &
+ field_dst=field_topo_x_icemask_l_ec, &
+ routehandles=is_local%wrap%RH(compglc,complnd,:), &
+ maptype=mapconsd, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_topo_x_icemask_l_ec, farrayptr=topo_l_ec, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! map FBglc_frac_x_icemask from glc to land (with multiple elevation classes) - no normalization
if (dbug_flag > 1) then
call ESMF_LogWrite(trim(subname)//": calling mapping of frac_x_icemask from glc to land", ESMF_LOGMSG_INFO)
end if
- allocate(fldlist%flds(1))
- fldlist%flds(1)%shortname = trim(Sg_frac_x_icemask)
- fldlist%flds(1)%mapindex(complnd) = mapconsf
- fldlist%flds(1)%mapnorm(complnd) = 'none'
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldList%flds, &
- srccomp=compglc, &
- destcomp=complnd, &
- FBSrc=FBglc_frac_x_icemask, &
- FBDst=FBlnd_frac_x_icemask, &
- FBFracSrc=is_local%wrap%FBFrac(compglc), & ! this will not be used
- FBNormOne=is_local%wrap%FBNormOne(compglc,complnd,:), & ! this will not be used
- RouteHandles=is_local%wrap%RH(compglc,complnd,:), &
- string='mapping frac_x_icemask from glc to land (with elevation classes)', rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
- deallocate(fldlist%flds)
- call FB_getFldPtr(FBlnd_frac_x_icemask, trim(Sg_frac_x_icemask), fldptr2=frac_x_icemask_l , rc=rc)
+ call med_map_field( &
+ field_src=field_frac_x_icemask_g_ec, &
+ field_dst=field_frac_x_icemask_l_ec, &
+ routehandles=is_local%wrap%RH(compglc,complnd,:), &
+ maptype=mapconsd, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_frac_x_icemask_l_ec, farrayptr=frac_x_icemask_l_ec, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! set Sg_topo values in export state to land (in multiple elevation classes)
@@ -510,18 +460,20 @@ subroutine med_map_glc2lnd( gcomp, rc)
! 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.
- call FB_getFldPtr(is_local%wrap%FBExp(complnd), trim(Sg_topo)//'_elev', fldptr2=dataptr2d_exp, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(complnd), fieldname=trim(Sg_topo)//'_elev', field=lfield, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(lfield, farrayptr=dataptr2d, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
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, dim=2)
+ do l = 1,size(frac_x_icemask_l_ec, dim=2)
if (frac_l_ec(ec,l) <= 0._r8) then
- dataptr2d_exp(ec,l) = topo_virtual
+ dataptr2d(ec,l) = topo_virtual
else
- if (frac_x_icemask_l(ec,l) == 0.0_r8) then
- dataptr2d_exp(ec,l) = 0.0_r8
+ if (frac_x_icemask_l_ec(ec,l) == 0.0_r8) then
+ dataptr2d(ec,l) = 0.0_r8
else
- dataptr2d_exp(ec,l) = topo_l_ec(ec,l) / frac_x_icemask_l(ec,l)
+ dataptr2d(ec,l) = topo_l_ec(ec,l) / frac_x_icemask_l_ec(ec,l)
end if
end if
end do
@@ -532,6 +484,6 @@ subroutine med_map_glc2lnd( gcomp, rc)
end if
call t_stopf('MED:'//subname)
- end subroutine med_map_glc2lnd
+ end subroutine map_glc2lnd
end module med_phases_prep_lnd_mod
diff --git a/mediator/med_phases_prep_ocn_mod.F90 b/mediator/med_phases_prep_ocn_mod.F90
index 69eab1a42..4352239b9 100644
--- a/mediator/med_phases_prep_ocn_mod.F90
+++ b/mediator/med_phases_prep_ocn_mod.F90
@@ -9,19 +9,18 @@ module med_phases_prep_ocn_mod
use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
use med_internalstate_mod , only : InternalState, mastertask, logunit
use med_merge_mod , only : med_merge_auto, med_merge_field
- use med_map_mod , only : med_map_FB_Regrid_Norm
+ use med_map_mod , only : med_map_field_packed
use med_utils_mod , only : memcheck => med_memcheck
use med_utils_mod , only : chkerr => med_utils_ChkErr
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_getNumFlds => med_methods_FB_getNumFlds
use med_methods_mod , only : FB_fldchk => med_methods_FB_FldChk
use med_methods_mod , only : FB_GetFldPtr => med_methods_FB_GetFldPtr
use med_methods_mod , only : FB_accum => med_methods_FB_accum
use med_methods_mod , only : FB_average => med_methods_FB_average
use med_methods_mod , only : FB_copy => med_methods_FB_copy
use med_methods_mod , only : FB_reset => med_methods_FB_reset
- use esmFlds , only : fldListFr, fldListTo
- use esmFlds , only : compocn, compatm, compice, ncomps, compname
+ use esmFlds , only : fldListTo
+ use esmFlds , only : compocn, compatm, compice, ncomps, compname, comprof
use esmFlds , only : coupling_mode
use perf_mod , only : t_startf, t_stopf
@@ -49,7 +48,7 @@ subroutine med_phases_prep_ocn_map(gcomp, rc)
! Map all fields in from relevant source components to the ocean grid
!---------------------------------------
- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_FieldBundleGet
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
! input/output variables
@@ -57,8 +56,9 @@ subroutine med_phases_prep_ocn_map(gcomp, rc)
integer, intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- integer :: n1, ncnt
+ type(InternalState) :: is_local
+ integer :: n1, ncnt
+ logical :: first_call = .true.
character(len=*), parameter :: subname='(med_phases_prep_ocn_map)'
!-------------------------------------------------------------------------------
@@ -76,26 +76,23 @@ subroutine med_phases_prep_ocn_map(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! Count the number of fields outside of scalar data, if zero, then return
- call FB_getNumFlds(is_local%wrap%FBExp(compocn), trim(subname)//"FBexp(compocn)", ncnt, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compocn), fieldCount=ncnt, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ ! map all fields in FBImp that have active ocean coupling
if (ncnt > 0) then
-
- ! map all fields in FBImp that have active ocean coupling to the ocean grid
do n1 = 1,ncomps
if (is_local%wrap%med_coupling_active(n1,compocn)) then
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(n1)%flds,&
- srccomp=n1, destcomp=compocn, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImp(n1,n1), &
FBDst=is_local%wrap%FBImp(n1,compocn), &
FBFracSrc=is_local%wrap%FBFrac(n1), &
- FBNormOne=is_local%wrap%FBNormOne(n1,compocn,:), &
- RouteHandles=is_local%wrap%RH(n1,compocn,:), &
- string=trim(compname(n1))//'2'//trim(compname(compocn)), rc=rc)
+ field_normOne=is_local%wrap%field_normOne(n1,compocn,:), &
+ packed_data=is_local%wrap%packed_data(n1,compocn,:), &
+ routehandles=is_local%wrap%RH(n1,compocn,:), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- endif
- enddo
+ end if
+ end do
endif
call t_stopf('MED:'//subname)
@@ -108,7 +105,8 @@ end subroutine med_phases_prep_ocn_map
!-----------------------------------------------------------------------------
subroutine med_phases_prep_ocn_merge(gcomp, rc)
- use ESMF , only : ESMF_GridComp, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
+ use ESMF , only : ESMF_GridComp, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
use ESMF , only : ESMF_FAILURE, ESMF_LOGMSG_ERROR
! input/output variables
@@ -134,8 +132,8 @@ subroutine med_phases_prep_ocn_merge(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! Count the number of fields outside of scalar data, if zero, then return
- call FB_getNumFlds(is_local%wrap%FBExp(compocn), trim(subname)//"FBexp(compocn)", ncnt, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compocn), fieldCount=ncnt, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
if (ncnt > 0) then
@@ -147,15 +145,21 @@ subroutine med_phases_prep_ocn_merge(gcomp, rc)
if (trim(coupling_mode) == 'cesm' .or. &
trim(coupling_mode) == 'nems_orig_data' .or. &
trim(coupling_mode) == 'hafs') then
- call med_merge_auto(trim(compname(compocn)), &
- is_local%wrap%FBExp(compocn), is_local%wrap%FBFrac(compocn), &
- is_local%wrap%FBImp(:,compocn), fldListTo(compocn), &
+ call med_merge_auto(compocn, &
+ is_local%wrap%med_coupling_active(:,compocn), &
+ is_local%wrap%FBExp(compocn), &
+ is_local%wrap%FBFrac(compocn), &
+ is_local%wrap%FBImp(:,compocn), &
+ fldListTo(compocn), &
FBMed1=is_local%wrap%FBMed_aoflux_o, rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
else if (trim(coupling_mode) == 'nems_frac' .or. trim(coupling_mode) == 'nems_orig') then
- call med_merge_auto(trim(compname(compocn)), &
- is_local%wrap%FBExp(compocn), is_local%wrap%FBFrac(compocn), &
- is_local%wrap%FBImp(:,compocn), fldListTo(compocn), rc=rc)
+ call med_merge_auto(compocn, &
+ is_local%wrap%med_coupling_active(:,compocn), &
+ is_local%wrap%FBExp(compocn), &
+ is_local%wrap%FBFrac(compocn), &
+ is_local%wrap%FBImp(:,compocn), &
+ fldListTo(compocn), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
end if
@@ -188,7 +192,8 @@ subroutine med_phases_prep_ocn_accum_fast(gcomp, rc)
! Carry out fast accumulation for the ocean
- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_Clock, ESMF_Time
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet, ESMF_FieldBundleGet
+ use ESMF , only : ESMF_Clock, ESMF_Time
use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
! input/output variables
@@ -216,8 +221,8 @@ subroutine med_phases_prep_ocn_accum_fast(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! Count the number of fields outside of scalar data, if zero, then return
- call FB_getNumFlds(is_local%wrap%FBExp(compocn), trim(subname)//"FBexp(compocn)", ncnt, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compocn), fieldCount=ncnt, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
if (ncnt > 0) then
! ocean accumulator
@@ -246,6 +251,7 @@ subroutine med_phases_prep_ocn_accum_avg(gcomp, rc)
! Prepare the OCN import Fields.
use ESMF , only : ESMF_GridComp, ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
+ use ESMF , only : ESMF_FieldBundleGet
! input/output variables
type(ESMF_GridComp) :: gcomp
@@ -270,8 +276,8 @@ subroutine med_phases_prep_ocn_accum_avg(gcomp, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
! Count the number of fields outside of scalar data, if zero, then return
- call FB_getNumFlds(is_local%wrap%FBExpAccum(compocn), trim(subname)//"FBExpAccum(compocn)", ncnt, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldBundleGet(is_local%wrap%FBExpAccum(compocn), fieldCount=ncnt, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
if (ncnt > 0) then
@@ -326,21 +332,21 @@ subroutine med_phases_prep_ocn_custom_cesm(gcomp, rc)
! local variables
type(InternalState) :: is_local
- real(R8), pointer :: ifrac(:), ofrac(:)
- real(R8), pointer :: ifracr(:), ofracr(:)
- real(R8), pointer :: avsdr(:), avsdf(:)
- real(R8), pointer :: anidr(:), anidf(:)
- real(R8), pointer :: Faxa_swvdf(:), Faxa_swndf(:)
- real(R8), pointer :: Faxa_swvdr(:), Faxa_swndr(:)
- real(R8), pointer :: Foxx_swnet(:)
- real(R8), pointer :: Foxx_swnet_afracr(:)
- real(R8), pointer :: Foxx_swnet_vdr(:), Foxx_swnet_vdf(:)
- real(R8), pointer :: Foxx_swnet_idr(:), Foxx_swnet_idf(:)
- real(R8), pointer :: Fioi_swpen_vdr(:), Fioi_swpen_vdf(:)
- real(R8), pointer :: Fioi_swpen_idr(:), Fioi_swpen_idf(:)
- real(R8), pointer :: Fioi_swpen(:)
- real(R8), pointer :: dataptr(:)
- real(R8), pointer :: dataptr_o(:)
+ real(R8), pointer :: ifrac(:), ofrac(:) => null()
+ real(R8), pointer :: ifracr(:), ofracr(:) => null()
+ real(R8), pointer :: avsdr(:), avsdf(:) => null()
+ real(R8), pointer :: anidr(:), anidf(:) => null()
+ real(R8), pointer :: Faxa_swvdf(:), Faxa_swndf(:) => null()
+ real(R8), pointer :: Faxa_swvdr(:), Faxa_swndr(:) => null()
+ real(R8), pointer :: Foxx_swnet(:) => null()
+ real(R8), pointer :: Foxx_swnet_afracr(:) => null()
+ real(R8), pointer :: Foxx_swnet_vdr(:), Foxx_swnet_vdf(:) => null()
+ real(R8), pointer :: Foxx_swnet_idr(:), Foxx_swnet_idf(:) => null()
+ real(R8), pointer :: Fioi_swpen_vdr(:), Fioi_swpen_vdf(:) => null()
+ real(R8), pointer :: Fioi_swpen_idr(:), Fioi_swpen_idf(:) => null()
+ real(R8), pointer :: Fioi_swpen(:) => null()
+ real(R8), pointer :: dataptr(:) => null()
+ real(R8), pointer :: dataptr_o(:) => null()
real(R8) :: frac_sum
real(R8) :: ifrac_scaled, ofrac_scaled
real(R8) :: ifracr_scaled, ofracr_scaled
@@ -594,13 +600,13 @@ subroutine med_phases_prep_ocn_custom_nems(gcomp, rc)
! local variables
type(InternalState) :: is_local
- real(R8), pointer :: ocnwgt1(:)
- real(R8), pointer :: icewgt1(:)
- real(R8), pointer :: wgtp01(:)
- real(R8), pointer :: wgtm01(:)
- real(R8), pointer :: customwgt(:)
- real(R8), pointer :: ifrac(:)
- real(R8), pointer :: ofrac(:)
+ real(R8), pointer :: ocnwgt1(:) => null()
+ real(R8), pointer :: icewgt1(:) => null()
+ real(R8), pointer :: wgtp01(:) => null()
+ real(R8), pointer :: wgtm01(:) => null()
+ real(R8), pointer :: customwgt(:) => null()
+ real(R8), pointer :: ifrac(:) => null()
+ real(R8), pointer :: ofrac(:) => null()
integer :: lsize
real(R8) , parameter :: const_lhvap = 2.501e6_R8 ! latent heat of evaporation ~ J/kg
character(len=*), parameter :: subname='(med_phases_prep_ocn_custom_nems)'
diff --git a/mediator/med_phases_prep_rof_mod.F90 b/mediator/med_phases_prep_rof_mod.F90
index f8f89f2c8..483be2693 100644
--- a/mediator/med_phases_prep_rof_mod.F90
+++ b/mediator/med_phases_prep_rof_mod.F90
@@ -2,7 +2,7 @@ module med_phases_prep_rof_mod
!-----------------------------------------------------------------------------
! Create rof export fields
- ! - accumulate import lnd fields on the land grid that are sent to rof
+ ! - accumulate import lnd fields on the land grid that are sent to rof
! this will be done in med_phases_prep_rof_accum
! - time avergage accumulated import lnd fields when necessary
! map the time averaged accumulated lnd fields to the rof grid
@@ -11,27 +11,15 @@ module med_phases_prep_rof_mod
!-----------------------------------------------------------------------------
use med_kind_mod , only : CX=>SHR_KIND_CX, CS=>SHR_KIND_CS, CL=>SHR_KIND_CL, R8=>SHR_KIND_R8
- use ESMF , only : ESMF_FieldBundle
- use esmFlds , only : ncomps, complnd, comprof, compname, mapconsf
- use esmFlds , only : med_fldlist_type
- use esmFlds , only : fldListTo, fldListFr
- use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
- use med_constants_mod , only : czero => med_constants_czero
+ use ESMF , only : ESMF_FieldBundle, ESMF_Field
+ use esmFlds , only : ncomps, complnd, comprof, compname, mapconsf, mapconsd
use med_internalstate_mod , only : InternalState, mastertask
- use med_utils_mod , only : chkerr => med_utils_ChkErr
- use med_methods_mod , only : FB_init => med_methods_FB_init
- use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_getNumFlds => med_methods_FB_getNumFlds
- use med_methods_mod , only : FB_accum => med_methods_FB_accum
- use med_methods_mod , only : FB_getFldPtr => med_methods_FB_getFldPtr
- use med_methods_mod , only : FB_average => med_methods_FB_average
- use med_methods_mod , only : FB_reset => med_methods_FB_reset
- use med_methods_mod , only : FB_clean => med_methods_FB_clean
- use med_methods_mod , only : State_GetScalar => med_methods_State_GetScalar
- use med_methods_mod , only : State_SetScalar => med_methods_State_SetScalar
- use med_merge_mod , only : med_merge_auto
- use med_map_mod , only : med_map_FB_Regrid_Norm, med_map_RH_is_created
- use med_map_mod , only : med_map_FB_Field_Regrid
+ use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
+ use med_constants_mod , only : czero => med_constants_czero
+ use med_utils_mod , only : chkerr => med_utils_chkerr
+ use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
+ use med_methods_mod , only : FB_accum => med_methods_FB_accum
+ use med_methods_mod , only : FB_average => med_methods_FB_average
use perf_mod , only : t_startf, t_stopf
implicit none
@@ -40,31 +28,34 @@ module med_phases_prep_rof_mod
public :: med_phases_prep_rof_accum
public :: med_phases_prep_rof_avg
- private :: med_phases_prep_rof_irrig
+ private :: med_phases_prep_rof_irrig
- type(ESMF_FieldBundle) :: FBlndVolr ! needed for lnd2rof irrigation
- type(ESMF_FieldBundle) :: FBrofVolr ! needed for lnd2rof irrigation
- type(ESMF_FieldBundle) :: FBlndIrrig ! needed for lnd2rof irrigation
- type(ESMF_FieldBundle) :: FBrofIrrig ! needed for lnd2rof irrigation
- type(med_fldlist_type) :: fldlist_lnd2rof ! needed for lnd2rof irrigation
+ ! the following are needed for lnd2rof irrigation
+ type(ESMF_Field) :: field_lndVolr
+ type(ESMF_Field) :: field_rofVolr
+ type(ESMF_Field) :: field_lndIrrig
+ type(ESMF_Field) :: field_rofIrrig
+ type(ESMF_Field) :: field_lndIrrig0
+ type(ESMF_Field) :: field_rofIrrig0
+ type(ESMF_Field) :: field_lfrac_rof
character(len=*), parameter :: volr_field = 'Flrr_volrmch'
character(len=*), parameter :: irrig_flux_field = 'Flrl_irrig'
character(len=*), parameter :: irrig_normalized_field = 'Flrl_irrig_normalized'
- character(len=*), parameter :: irrig_volr0_field = 'Flrl_irrig_volr0 '
+ character(len=*), parameter :: irrig_volr0_field = 'Flrl_irrig_volr0 '
character(*) , parameter :: u_FILE_u = &
__FILE__
-!-----------------------------------------------------------------------------
+!===============================================================================
contains
-!-----------------------------------------------------------------------------
+!===============================================================================
subroutine med_phases_prep_rof_accum(gcomp, rc)
!------------------------------------
! Carry out fast accumulation for the river (rof) component
- ! Accumulation and averaging is done on the land input on the land grid for the fields that will
+ ! Accumulation and averaging is done on the land input on the land grid for the fields that will
! will be sent to the river component
! Mapping from the land to the rof grid is then done with the time averaged fields
!------------------------------------
@@ -108,7 +99,7 @@ subroutine med_phases_prep_rof_accum(gcomp, rc)
ncnt = 0
call ESMF_LogWrite(trim(subname)//": FBImp(complnd,complnd) is not created", &
ESMF_LOGMSG_INFO)
- else
+ else
! The scalar field has been removed from all mediator field bundles - so check if the fieldCount is
! 0 and not 1 here
call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldCount=ncnt, rc=rc)
@@ -118,7 +109,7 @@ subroutine med_phases_prep_rof_accum(gcomp, rc)
end if
!---------------------------------------
- ! Accumulate lnd input on lnd grid
+ ! Accumulate lnd input on lnd grid
!---------------------------------------
! Note that all import fields from the land are accumulated - but
@@ -146,28 +137,36 @@ subroutine med_phases_prep_rof_accum(gcomp, rc)
end subroutine med_phases_prep_rof_accum
- !-----------------------------------------------------------------------------
-
+ !===============================================================================
subroutine med_phases_prep_rof_avg(gcomp, rc)
!------------------------------------
! Prepare the ROF export Fields from the mediator
!------------------------------------
- use NUOPC , only : NUOPC_IsConnected
- use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
- use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
- use ESMF , only : ESMF_FieldBundleGet
+ use NUOPC , only : NUOPC_IsConnected
+ use ESMF , only : ESMF_GridComp, ESMF_GridCompGet
+ use ESMF , only : ESMF_FieldBundleGet, ESMF_FieldGet
+ use ESMF , only : ESMF_LogWrite, ESMF_LOGMSG_INFO, ESMF_SUCCESS
+ use esmFlds , only : fldListTo
+ use med_map_mod , only : med_map_field_packed
+ use med_merge_mod , only : med_merge_auto
! input/output variables
type(ESMF_GridComp) :: gcomp
integer, intent(out) :: rc
! local variables
- type(InternalState) :: is_local
- integer :: i,j,n,n1,ncnt
- logical :: connected
- real(r8), pointer :: dataptr(:)
+ type(InternalState) :: is_local
+ integer :: i,j,n,n1,ncnt
+ logical :: connected
+ real(r8), pointer :: dataptr(:) => null()
+ real(r8), pointer :: dataptr1d(:) => null()
+ real(r8), pointer :: dataptr2d(:,:) => null()
+ type(ESMF_Field) :: field_irrig_flux
+ integer :: fieldcount
+ type(ESMF_Field), pointer :: fieldlist(:) => null()
+ integer :: ungriddedUBound(1)
character(len=*),parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof_avg)'
!---------------------------------------
@@ -186,9 +185,8 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
!---------------------------------------
- !--- Count the number of fields outside of scalar data, if zero, then return
+ ! Count the number of fields outside of scalar data, if zero, then return
!---------------------------------------
-
! Note - the scalar field has been removed from all mediator field bundles - so this is why we check if the
! fieldCount is 0 and not 1 here
@@ -202,7 +200,7 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
else
!---------------------------------------
- !--- average import from land accumuled FB
+ ! average import from land accumuled FB
!---------------------------------------
call FB_average(is_local%wrap%FBImpAccum(complnd,complnd), is_local%wrap%FBImpAccumCnt(complnd), rc=rc)
@@ -215,28 +213,25 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
end if
!---------------------------------------
- !--- map to create FBImpAccum(complnd,comprof)
+ ! map to create FBImpAccum(complnd,comprof)
!---------------------------------------
! The following assumes that only land import fields are needed to create the
! export fields for the river component and that ALL mappings are done with mapconsf
if (is_local%wrap%med_coupling_active(complnd,comprof)) then
-
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(complnd)%flds, &
- srccomp=complnd, destcomp=comprof, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImpAccum(complnd,complnd), &
FBDst=is_local%wrap%FBImpAccum(complnd,comprof), &
FBFracSrc=is_local%wrap%FBFrac(complnd), &
- FBNormOne=is_local%wrap%FBNormOne(complnd,comprof,:), &
- RouteHandles=is_local%wrap%RH(complnd,comprof,:), &
- string=trim(compname(complnd))//'2'//trim(compname(comprof)), rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_normOne=is_local%wrap%field_normOne(complnd,comprof,:), &
+ packed_data=is_local%wrap%packed_data(complnd,comprof,:), &
+ routehandles=is_local%wrap%RH(complnd,comprof,:), rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
if (dbug_flag > 1) then
call FB_diagnose(is_local%wrap%FBImpAccum(complnd,comprof), &
- string=trim(subname)//' FBImpAccum(complnd,comprof) after avg ', rc=rc)
+ string=trim(subname)//' FBImpAccum(complnd,comprof) after map ', rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
@@ -246,15 +241,17 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
else
! This will ensure that no irrig is sent from the land
- call FB_getFldPtr(is_local%wrap%FBImpAccum(complnd,comprof), &
- trim(irrig_flux_field), dataptr, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,comprof), fieldname=trim(irrig_flux_field), &
+ field=field_irrig_flux, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_irrig_flux, farrayptr=dataptr, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
dataptr(:) = 0._r8
end if
endif
!---------------------------------------
- !--- auto merges to create FBExp(comprof)
+ ! auto merges to create FBExp(comprof)
!---------------------------------------
if (dbug_flag > 1) then
@@ -263,7 +260,8 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
end if
- call med_merge_auto(trim(compname(comprof)), &
+ call med_merge_auto(comprof, &
+ is_local%wrap%med_coupling_active(:,comprof), &
is_local%wrap%FBExp(comprof), &
is_local%wrap%FBFrac(comprof), &
is_local%wrap%FBImpAccum(:,comprof), &
@@ -277,24 +275,32 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
end if
!---------------------------------------
- !--- zero accumulator
+ ! zero accumulator and FBAccum
!---------------------------------------
is_local%wrap%FBImpAccumCnt(complnd) = 0
- call FB_reset(is_local%wrap%FBImpAccum(complnd,complnd), value=czero, rc=rc)
- if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- !---------------------------------------
- !--- custom calculations
- !---------------------------------------
-
- !---------------------------------------
- !--- clean up
- !---------------------------------------
+ call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,complnd), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,complnd), fieldlist=fieldlist, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ do n = 1, fieldCount
+ call ESMF_FieldGet(fieldlist(n), ungriddedUBound=ungriddedUBound, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ if (ungriddedUbound(1) > 0) then
+ call ESMF_FieldGet(fieldlist(n), farrayPtr=dataptr2d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr2d(:,:) = czero
+ else
+ call ESMF_FieldGet(fieldlist(n), farrayPtr=dataptr1d, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ dataptr1d(:) = czero
+ end if
+ end do
+ deallocate(fieldlist)
endif
-
if (dbug_flag > 20) then
call ESMF_LogWrite(trim(subname)//": done", ESMF_LOGMSG_INFO)
end if
@@ -302,8 +308,7 @@ subroutine med_phases_prep_rof_avg(gcomp, rc)
end subroutine med_phases_prep_rof_avg
- !-----------------------------------------------------------------------------
-
+ !===============================================================================
subroutine med_phases_prep_rof_irrig(gcomp, rc)
!---------------------------------------------------------------
@@ -327,26 +332,37 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
! (non-volr-normalized) flux on the rof grid.
!---------------------------------------------------------------
- use ESMF , only : ESMF_GridComp, ESMF_Field
- use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_FieldBundleIsCreated
- use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE
- use ESMF , only : ESMF_LOGMSG_INFO, ESMF_LogWrite
+ use ESMF , only : ESMF_GridComp, ESMF_Field, ESMF_FieldGet, ESMF_FieldCreate
+ use ESMF , only : ESMF_FieldBundle, ESMF_FieldBundleGet, ESMF_FieldIsCreated
+ use ESMF , only : ESMF_Mesh, ESMF_TYPEKIND_R8, ESMF_MESHLOC_ELEMENT
+ use ESMF , only : ESMF_SUCCESS, ESMF_FAILURE
+ use ESMF , only : ESMF_LOGMSG_INFO, ESMF_LogWrite, ESMF_LOGMSG_ERROR
+ use med_map_mod , only : med_map_rh_is_created, med_map_field, med_map_field_normalized
! input/output variables
type(ESMF_GridComp) :: gcomp
integer, intent(out) :: rc
! local variables
- integer :: r,l
- type(InternalState) :: is_local
- real(r8), pointer :: volr_l(:)
- real(r8), pointer :: volr_r(:), volr_r_import(:)
- real(r8), pointer :: irrig_normalized_l(:)
- real(r8), pointer :: irrig_normalized_r(:)
- real(r8), pointer :: irrig_volr0_l(:)
- real(r8), pointer :: irrig_volr0_r(:)
- real(r8), pointer :: irrig_flux_l(:)
- real(r8), pointer :: irrig_flux_r(:)
+ integer :: r,l
+ type(InternalState) :: is_local
+ integer :: fieldcount
+ type(ESMF_Field) :: field_import_rof
+ type(ESMF_Field) :: field_import_lnd
+ type(ESMF_Field) :: field_irrig_flux
+ type(ESMF_Field) :: field_lfrac_lnd
+ type(ESMF_Field), pointer :: fieldlist_lnd(:) => null()
+ type(ESMF_Field), pointer :: fieldlist_rof(:) => null()
+ type(ESMF_Mesh) :: lmesh_lnd
+ type(ESMF_Mesh) :: lmesh_rof
+ real(r8), pointer :: volr_l(:) => null()
+ real(r8), pointer :: volr_r(:), volr_r_import(:) => null()
+ real(r8), pointer :: irrig_normalized_l(:) => null()
+ real(r8), pointer :: irrig_normalized_r(:) => null()
+ real(r8), pointer :: irrig_volr0_l(:) => null()
+ real(r8), pointer :: irrig_volr0_r(:) => null()
+ real(r8), pointer :: irrig_flux_l(:) => null()
+ real(r8), pointer :: irrig_flux_r(:) => null()
character(len=*), parameter :: subname='(med_phases_prep_rof_mod: med_phases_prep_rof_irrig)'
!---------------------------------------------------------------
@@ -366,14 +382,14 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
if (.not. med_map_RH_is_created(is_local%wrap%RH(complnd,comprof,:),mapconsf, rc=rc)) then
- call ESMF_LogWrite(trim(subname)//": ERROR conservativing route handle not created for lnd->rof mapping", &
- ESMF_LOGMSG_INFO)
+ call ESMF_LogWrite(trim(subname)//": ERROR conservative route handle not created for lnd->rof mapping", &
+ ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
end if
if (.not. med_map_RH_is_created(is_local%wrap%RH(comprof,complnd,:),mapconsf, rc=rc)) then
- call ESMF_LogWrite(trim(subname)//": ERROR conservativing route handle not created for rof->lnd mapping", &
- ESMF_LOGMSG_INFO)
+ call ESMF_LogWrite(trim(subname)//": ERROR conservative route handle not created for rof->lnd mapping", &
+ ESMF_LOGMSG_ERROR)
rc = ESMF_FAILURE
return
end if
@@ -382,42 +398,51 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
! Initialize module field bundles if not already initialized
! ------------------------------------------------------------------------
- if (.not. ESMF_FieldBundleIsCreated(FBlndVolr) .and. &
- .not. ESMF_FieldBundleIsCreated(FBrofVolr) .and. &
- .not. ESMF_FieldBundleIsCreated(FBlndIrrig) .and. &
- .not. ESMF_FieldBundleIsCreated(FBrofIrrig)) then
+ if (.not. ESMF_FieldIsCreated(field_lndVolr) .and. &
+ .not. ESMF_FieldIsCreated(field_rofVolr) .and. &
+ .not. ESMF_FieldIsCreated(field_lndIrrig) .and. &
+ .not. ESMF_FieldIsCreated(field_rofIrrig) .and. &
+ .not. ESMF_FieldIsCreated(field_lndIrrig0) .and. &
+ .not. ESMF_FieldIsCreated(field_rofIrrig0) .and. &
+ .not. ESMF_FieldIsCreated(field_lfrac_rof)) then
+
+ ! get fields in source and destination field bundles
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist_lnd(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(complnd,complnd), fieldlist=fieldlist_lnd, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist_lnd(1), mesh=lmesh_lnd, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(fieldlist_lnd)
+
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), fieldCount=fieldCount, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ allocate(fieldlist_rof(fieldcount))
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), fieldlist=fieldlist_rof, rc=rc)
+ if (ChkErr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(fieldlist_rof(1), mesh=lmesh_rof, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ deallocate(fieldlist_rof)
- call FB_init(FBout=FBlndVolr, &
- flds_scalar_name=is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(complnd,complnd), &
- fieldNameList=(/trim(volr_field)/), rc=rc)
+ field_lndVolr = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_rofVolr = ESMF_FieldCreate(lmesh_rof, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_init(FBout=FBrofVolr, &
- flds_scalar_name=is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(comprof,comprof), &
- fieldNameList=(/trim(volr_field)/), rc=rc)
+ field_lndIrrig = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_rofIrrig = ESMF_FieldCreate(lmesh_rof, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_init(FBout=FBlndIrrig, &
- flds_scalar_name=is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(complnd,complnd), &
- fieldNameList=(/irrig_normalized_field, irrig_volr0_field/), rc=rc)
+ field_lndIrrig0 = ESMF_FieldCreate(lmesh_lnd, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ field_rofIrrig0 = ESMF_FieldCreate(lmesh_rof, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_init(FBout=FBrofIrrig, &
- flds_scalar_name=is_local%wrap%flds_scalar_name, &
- FBgeom=is_local%wrap%FBImp(comprof,comprof), &
- fieldNameList=(/irrig_normalized_field, irrig_volr0_field/), rc=rc)
+ field_lfrac_rof = ESMF_FieldCreate(lmesh_rof, ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- allocate(fldlist_lnd2rof%flds(2))
- fldlist_lnd2rof%flds(1)%shortname = irrig_normalized_field
- fldlist_lnd2rof%flds(2)%shortname = irrig_volr0_field
- fldlist_lnd2rof%flds(1)%mapindex(comprof) = mapconsf
- fldlist_lnd2rof%flds(2)%mapindex(comprof) = mapconsf
- fldlist_lnd2rof%flds(1)%mapnorm(comprof) = 'lfrac'
- fldlist_lnd2rof%flds(2)%mapnorm(comprof) = 'lfrac'
end if
! ------------------------------------------------------------------------
@@ -429,13 +454,14 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
! cells: while conservative, this would be unphysical (it would mean that irrigation
! actually adds water to those cells).
- call FB_getFldPtr(is_local%wrap%FBImp(comprof,comprof), &
- trim(volr_field), volr_r_import, rc=rc)
+ ! Create volr_r
+ call ESMF_FieldBundleGet(is_local%wrap%FBImp(comprof,comprof), fieldname=trim(volr_field), &
+ field=field_import_rof, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_getFldPtr(FBrofVolr, trim(volr_field), volr_r, rc=rc)
+ call ESMF_FieldGet(field_import_rof, farrayptr=volr_r_import, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_rofVolr, farrayptr=volr_r, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
do r = 1, size(volr_r)
if (volr_r_import(r) < 0._r8) then
volr_r(r) = 0._r8
@@ -445,12 +471,15 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
end do
! Map volr_r to volr_l (rof->lnd) using conservative mapping without any fractional weighting
- call med_map_FB_Field_Regrid(FBrofVolr, trim(volr_field), FBlndVolr, trim(volr_field), &
- is_local%wrap%RH(comprof, complnd, :), mapconsf, rc=rc)
+ call med_map_field( &
+ field_src=field_rofVolr, &
+ field_dst=field_lndVolr, &
+ routehandles=is_local%wrap%RH(comprof,complnd,:), &
+ maptype=mapconsf, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Get volr_l
- call FB_getFldPtr(FBlndVolr, trim(volr_field), volr_l, rc=rc)
+ call ESMF_FieldGet(field_lndVolr, farrayptr=volr_l, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! ------------------------------------------------------------------------
@@ -469,15 +498,16 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
! flux on the rof grid.
! First extract accumulated irrigation flux from land
- call FB_getFldPtr(is_local%wrap%FBImpAccum(complnd,complnd), &
- trim(irrig_flux_field), irrig_flux_l, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,complnd), fieldname=trim(irrig_flux_field), &
+ field=field_irrig_flux, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- ! Fill in values for irrig_normalized_l and irrig_volr0_l in temporary FBlndIrrig field bundle
- call FB_getFldPtr(FBlndIrrig, trim(irrig_normalized_field), irrig_normalized_l, rc=rc)
+ call ESMF_FieldGet(field_irrig_flux, farrayptr=irrig_flux_l, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
- call FB_getFldPtr(FBlndIrrig, trim(irrig_volr0_field), irrig_volr0_l, rc=rc)
+ ! Fill in values for irrig_normalized_l and irrig_volr0_l
+ call ESMF_FieldGet(field_lndIrrig, farrayptr=irrig_normalized_l, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_lndIrrig0, farrayptr=irrig_volr0_l, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
do l = 1, size(volr_l)
@@ -495,26 +525,36 @@ subroutine med_phases_prep_rof_irrig(gcomp, rc)
! convert to a total irrigation flux on the ROF grid
! ------------------------------------------------------------------------
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldList_lnd2rof%flds, &
- srccomp=complnd, destcomp=comprof, &
- FBSrc=FBlndIrrig, &
- FBDst=FBrofIrrig, &
- FBFracSrc=is_local%wrap%FBFrac(complnd), &
- FBNormOne=is_local%wrap%FBNormOne(complnd,comprof,:), &
- RouteHandles=is_local%wrap%RH(complnd,comprof,:), &
- string=trim(compname(complnd))//'2'//trim(compname(comprof)), rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBFrac(complnd), 'lfrac', field=field_lfrac_lnd, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_getFldPtr(FBrofIrrig, trim(irrig_normalized_field), irrig_normalized_r, rc=rc)
+ call med_map_field_normalized( &
+ field_src=field_lndIrrig, &
+ field_dst=field_rofIrrig, &
+ routehandles=is_local%wrap%RH(complnd,comprof,:), &
+ maptype=mapconsf, &
+ field_normsrc=field_lfrac_lnd, &
+ field_normdst=field_lfrac_rof, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
-
- call FB_getFldPtr(FBrofIrrig, trim(irrig_volr0_field), irrig_volr0_r, rc=rc)
+ call med_map_field_normalized( &
+ field_src=field_lndIrrig0, &
+ field_dst=field_rofIrrig0, &
+ routehandles=is_local%wrap%RH(complnd,comprof,:), &
+ maptype=mapconsf, &
+ field_normsrc=field_lfrac_lnd, &
+ field_normdst=field_lfrac_rof, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_rofIrrig, farrayptr=irrig_normalized_r, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_rofIrrig0, farrayptr=irrig_volr0_r, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
! Convert to a total irrigation flux on the ROF grid, and put this in the pre-merge FBImpAccum(complnd,comprof)
- call FB_getFldPtr(is_local%wrap%FBImpAccum(complnd,comprof), &
- trim(irrig_flux_field), irrig_flux_r, rc=rc)
+ call ESMF_FieldBundleGet(is_local%wrap%FBImpAccum(complnd,comprof), fieldname=trim(irrig_flux_field), &
+ field=field_import_rof, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_import_rof, farrayptr=irrig_flux_r, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
+ call ESMF_FieldGet(field_rofIrrig0, farrayptr=irrig_volr0_r, rc=rc)
if (chkerr(rc,__LINE__,u_FILE_u)) return
do r = 1, size(irrig_flux_r)
diff --git a/mediator/med_phases_prep_wav_mod.F90 b/mediator/med_phases_prep_wav_mod.F90
index bee6ad614..9d5e51f54 100644
--- a/mediator/med_phases_prep_wav_mod.F90
+++ b/mediator/med_phases_prep_wav_mod.F90
@@ -8,9 +8,8 @@ module med_phases_prep_wav_mod
use med_constants_mod , only : dbug_flag => med_constants_dbug_flag
use med_utils_mod , only : chkerr => med_utils_ChkErr
use med_methods_mod , only : FB_diagnose => med_methods_FB_diagnose
- use med_methods_mod , only : FB_getNumFlds => med_methods_FB_getNumFlds
use med_merge_mod , only : med_merge_auto
- use med_map_mod , only : med_map_FB_Regrid_Norm
+ use med_map_mod , only : med_map_field_packed
use med_internalstate_mod , only : InternalState, mastertask
use esmFlds , only : compwav, ncomps, compname
use esmFlds , only : fldListFr, fldListTo
@@ -59,42 +58,30 @@ subroutine med_phases_prep_wav(gcomp, rc)
call ESMF_GridCompGetInternalState(gcomp, is_local, rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- !---------------------------------------
- ! --- Count the number of fields outside of scalar data, if zero, then return
- !---------------------------------------
-
+ ! Count the number of fields outside of scalar data, if zero, then return
! Note - the scalar field has been removed from all mediator field bundles - so this is why we check if the
! fieldCount is 0 and not 1 here
-
- call FB_getNumFlds(is_local%wrap%FBExp(compwav), trim(subname)//"FBexp(compwav)", ncnt, rc)
- if (ChkErr(rc,__LINE__,u_FILE_u)) return
-
+ call ESMF_FieldBundleGet(is_local%wrap%FBExp(compwav), fieldCount=ncnt, rc=rc)
+ if (chkerr(rc,__LINE__,u_FILE_u)) return
if (ncnt > 0) then
- !---------------------------------------
- !--- map to create FBimp(:,compwav)
- !---------------------------------------
-
+ ! map to create FBimp(:,compwav)
do n1 = 1,ncomps
if (is_local%wrap%med_coupling_active(n1,compwav)) then
- call med_map_FB_Regrid_Norm( &
- fldsSrc=fldListFr(n1)%flds, &
- srccomp=n1, destcomp=compwav, &
+ call med_map_field_packed( &
FBSrc=is_local%wrap%FBImp(n1,n1), &
FBDst=is_local%wrap%FBImp(n1,compwav), &
FBFracSrc=is_local%wrap%FBFrac(n1), &
- FBNormOne=is_local%wrap%FBNormOne(n1,compwav,:), &
- RouteHandles=is_local%wrap%RH(n1,compwav,:), &
- string=trim(compname(n1))//'2'//trim(compname(compwav)), rc=rc)
+ field_normOne=is_local%wrap%field_normOne(n1,compwav,:), &
+ packed_data=is_local%wrap%packed_data(n1,compwav,:), &
+ routehandles=is_local%wrap%RH(n1,compwav,:), rc=rc)
if (ChkErr(rc,__LINE__,u_FILE_u)) return
- endif
- enddo
-
- !---------------------------------------
- !--- auto merges to create FBExp(compwav)
- !---------------------------------------
+ end if
+ end do
- call med_merge_auto(trim(compname(compwav)), &
+ ! auto merges to create FBExp(compwav)
+ call med_merge_auto(compwav, &
+ is_local%wrap%med_coupling_active(:,compwav), &
is_local%wrap%FBExp(compwav), &
is_local%wrap%FBFrac(compwav), &
is_local%wrap%FBImp(:,compwav), &
diff --git a/mediator/med_utils_mod.F90 b/mediator/med_utils_mod.F90
index 9aef4cff9..12a846466 100644
--- a/mediator/med_utils_mod.F90
+++ b/mediator/med_utils_mod.F90
@@ -23,10 +23,12 @@ subroutine med_memcheck(string, level, mastertask)
logical, intent(in) :: mastertask
integer :: ierr
#ifndef INTERNAL_PIO_INIT
+#ifdef CESMCOUPLED
integer, external :: GPTLprint_memusage
if((mastertask .and. memdebug_level > level) .or. memdebug_level > level+1) then
ierr = GPTLprint_memusage(string)
endif
+#endif
#endif
end subroutine med_memcheck
diff --git a/nuopc_cap_share/nuopc_shr_methods.F90 b/nuopc_cap_share/nuopc_shr_methods.F90
index 44ead6c8f..8d3283a4f 100644
--- a/nuopc_cap_share/nuopc_shr_methods.F90
+++ b/nuopc_cap_share/nuopc_shr_methods.F90
@@ -83,12 +83,16 @@ subroutine memcheck(string, level, mastertask)
! local variables
integer :: ierr
+#ifdef CESMCOUPLED
integer, external :: GPTLprint_memusage
+#endif
!-----------------------------------------------------------------------
+#ifdef CESMCOUPLED
if ((mastertask .and. memdebug_level > level) .or. memdebug_level > level+1) then
ierr = GPTLprint_memusage(string)
endif
+#endif
end subroutine memcheck
diff --git a/tcipylint b/tcipylint
index 00c371711..e9517f94b 100755
--- a/tcipylint
+++ b/tcipylint
@@ -1,6 +1,8 @@
#!/usr/bin/env sh
args="--disable=I,C,R,logging-not-lazy,wildcard-import,unused-wildcard-import,fixme,broad-except,bare-except,eval-used,exec-used,global-statement,logging-format-interpolation,no-name-in-module,import-error"
+failed=0
for file in cime_config/buildexe cime_config/buildnml cime_config/runseq/*
do
- pylint $args $file
-done
\ No newline at end of file
+ pylint $args $file || failed=$(( failed + 1 ))
+done
+exit $failed